Mercurial > hg > xemacs-beta

comparison src/eval.c @ 4990:8f0cf4fd3d2c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Automatic merge
author Ben Wing <ben@xemacs.org>
date Sat, 06 Feb 2010 04:01:46 -0600
parents 3c3c1d139863
children ae48681c47fa
comparison
equal deleted inserted replaced
4989:d2ec55325515 4990:8f0cf4fd3d2c
1 /* Evaluator for XEmacs Lisp interpreter. 1 /* Evaluator for XEmacs Lisp interpreter.
2 Copyright (C) 1985-1987, 1992-1994 Free Software Foundation, Inc. 2 Copyright (C) 1985-1987, 1992-1994 Free Software Foundation, Inc.
3 Copyright (C) 1995 Sun Microsystems, Inc. 3 Copyright (C) 1995 Sun Microsystems, Inc.
4 Copyright (C) 2000, 2001, 2002, 2003, 2004 Ben Wing. 4 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2010 Ben Wing.
5 5
6 This file is part of XEmacs. 6 This file is part of XEmacs.
7 7
8 XEmacs is free software; you can redistribute it and/or modify it 8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the 9 under the terms of the GNU General Public License as published by the
424 424
425 static void 425 static void
426 print_subr (Lisp_Object obj, Lisp_Object printcharfun, int UNUSED (escapeflag)) 426 print_subr (Lisp_Object obj, Lisp_Object printcharfun, int UNUSED (escapeflag))
427 { 427 {
428 Lisp_Subr *subr = XSUBR (obj); 428 Lisp_Subr *subr = XSUBR (obj);
429 const CIbyte *header = 429 const Ascbyte *header =
430 (subr->max_args == UNEVALLED) ? "#<special-operator " : "#<subr "; 430 (subr->max_args == UNEVALLED) ? "#<special-operator " : "#<subr ";
431 const CIbyte *name = subr_name (subr); 431 const Ascbyte *name = subr_name (subr);
432 const CIbyte *trailer = subr->prompt ? " (interactive)>" : ">"; 432 const Ascbyte *trailer = subr->prompt ? " (interactive)>" : ">";
433 433
434 if (print_readably) 434 if (print_readably)
435 printing_unreadable_object ("%s%s%s", header, name, trailer); 435 printing_unreadable_object ("%s%s%s", header, name, trailer);
436 436
437 write_c_string (printcharfun, header); 437 write_ascstring (printcharfun, header);
438 write_c_string (printcharfun, name); 438 write_ascstring (printcharfun, name);
439 write_c_string (printcharfun, trailer); 439 write_ascstring (printcharfun, trailer);
440 } 440 }
441 441
442 static const struct memory_description subr_description[] = { 442 static const struct memory_description subr_description[] = {
443 { XD_DOC_STRING, offsetof (Lisp_Subr, doc), 0, { 0 }, XD_FLAG_NO_KKCC }, 443 { XD_DOC_STRING, offsetof (Lisp_Subr, doc), 0, { 0 }, XD_FLAG_NO_KKCC },
444 { XD_END } 444 { XD_END }
736 specbind (Qstack_trace_on_error, Qnil); 736 specbind (Qstack_trace_on_error, Qnil);
737 specbind (Qdebug_on_signal, Qnil); 737 specbind (Qdebug_on_signal, Qnil);
738 specbind (Qstack_trace_on_signal, Qnil); 738 specbind (Qstack_trace_on_signal, Qnil);
739 739
740 if (!noninteractive) 740 if (!noninteractive)
741 internal_with_output_to_temp_buffer (build_string ("*Backtrace*"), 741 internal_with_output_to_temp_buffer (build_ascstring ("*Backtrace*"),
742 backtrace_259, 742 backtrace_259,
743 Qnil, 743 Qnil,
744 Qnil); 744 Qnil);
745 else /* in batch mode, we want this going to stderr. */ 745 else /* in batch mode, we want this going to stderr. */
746 backtrace_259 (Qnil); 746 backtrace_259 (Qnil);
778 specbind (Qstack_trace_on_error, Qnil); 778 specbind (Qstack_trace_on_error, Qnil);
779 specbind (Qdebug_on_signal, Qnil); 779 specbind (Qdebug_on_signal, Qnil);
780 specbind (Qstack_trace_on_signal, Qnil); 780 specbind (Qstack_trace_on_signal, Qnil);
781 781
782 if (!noninteractive) 782 if (!noninteractive)
783 internal_with_output_to_temp_buffer (build_string ("*Backtrace*"), 783 internal_with_output_to_temp_buffer (build_ascstring ("*Backtrace*"),
784 backtrace_259, 784 backtrace_259,
785 Qnil, 785 Qnil,
786 Qnil); 786 Qnil);
787 else /* in batch mode, we want this going to stderr. */ 787 else /* in batch mode, we want this going to stderr. */
788 backtrace_259 (Qnil); 788 backtrace_259 (Qnil);
2608 else if (ERRB_EQ (errb, ERROR_ME_DEBUG_WARN)) 2608 else if (ERRB_EQ (errb, ERROR_ME_DEBUG_WARN))
2609 warn_when_safe_lispobj (class_, Qdebug, Fcons (sig, data)); 2609 warn_when_safe_lispobj (class_, Qdebug, Fcons (sig, data));
2610 else if (ERRB_EQ (errb, ERROR_ME_WARN)) 2610 else if (ERRB_EQ (errb, ERROR_ME_WARN))
2611 warn_when_safe_lispobj (class_, Qwarning, Fcons (sig, data)); 2611 warn_when_safe_lispobj (class_, Qwarning, Fcons (sig, data));
2612 else 2612 else
2613 for (;;) 2613 signal_error_1 (sig, data);
2614 Fsignal (sig, data);
2615 } 2614 }
2616 2615
2617 /* Signal a continuable error or display a warning or do nothing, 2616 /* Signal a continuable error or display a warning or do nothing,
2618 according to ERRB. */ 2617 according to ERRB. */
2619 2618
2652 2651
2653 /* Out of REASON and FROB, return a list of elements suitable for passing 2652 /* Out of REASON and FROB, return a list of elements suitable for passing
2654 to signal_error_1(). */ 2653 to signal_error_1(). */
2655 2654
2656 Lisp_Object 2655 Lisp_Object
2657 build_error_data (const CIbyte *reason, Lisp_Object frob) 2656 build_error_data (const Ascbyte *reason, Lisp_Object frob)
2658 { 2657 {
2659 if (EQ (frob, Qunbound)) 2658 if (EQ (frob, Qunbound))
2660 frob = Qnil; 2659 frob = Qnil;
2661 else if (CONSP (frob) && EQ (XCAR (frob), Qunbound)) 2660 else if (CONSP (frob) && EQ (XCAR (frob), Qunbound))
2662 frob = XCDR (frob); 2661 frob = XCDR (frob);
2667 else 2666 else
2668 return Fcons (build_msg_string (reason), frob); 2667 return Fcons (build_msg_string (reason), frob);
2669 } 2668 }
2670 2669
2671 DOESNT_RETURN 2670 DOESNT_RETURN
2672 signal_error (Lisp_Object type, const CIbyte *reason, Lisp_Object frob) 2671 signal_error (Lisp_Object type, const Ascbyte *reason, Lisp_Object frob)
2673 { 2672 {
2674 signal_error_1 (type, build_error_data (reason, frob)); 2673 signal_error_1 (type, build_error_data (reason, frob));
2675 } 2674 }
2676 2675
2676 /* NOTE NOTE NOTE: If you feel you need signal_ierror() or something
2677 similar when reason is a non-ASCII message, you're probably doing
2678 something wrong. When you have an error message from an external
2679 source, you should put the error message as the first item in FROB and
2680 put a string in REASON indicating what you were doing when the error
2681 message occurred. Use signal_error_2() for such a case. */
2682
2677 void 2683 void
2678 maybe_signal_error (Lisp_Object type, const CIbyte *reason, 2684 maybe_signal_error (Lisp_Object type, const Ascbyte *reason,
2679 Lisp_Object frob, Lisp_Object class_, 2685 Lisp_Object frob, Lisp_Object class_,
2680 Error_Behavior errb) 2686 Error_Behavior errb)
2681 { 2687 {
2682 /* Optimization: */ 2688 /* Optimization: */
2683 if (ERRB_EQ (errb, ERROR_ME_NOT)) 2689 if (ERRB_EQ (errb, ERROR_ME_NOT))
2684 return; 2690 return;
2685 maybe_signal_error_1 (type, build_error_data (reason, frob), class_, errb); 2691 maybe_signal_error_1 (type, build_error_data (reason, frob), class_, errb);
2686 } 2692 }
2687 2693
2688 Lisp_Object 2694 Lisp_Object
2689 signal_continuable_error (Lisp_Object type, const CIbyte *reason, 2695 signal_continuable_error (Lisp_Object type, const Ascbyte *reason,
2690 Lisp_Object frob) 2696 Lisp_Object frob)
2691 { 2697 {
2692 return Fsignal (type, build_error_data (reason, frob)); 2698 return Fsignal (type, build_error_data (reason, frob));
2693 } 2699 }
2694 2700
2695 Lisp_Object 2701 Lisp_Object
2696 maybe_signal_continuable_error (Lisp_Object type, const CIbyte *reason, 2702 maybe_signal_continuable_error (Lisp_Object type, const Ascbyte *reason,
2697 Lisp_Object frob, Lisp_Object class_, 2703 Lisp_Object frob, Lisp_Object class_,
2698 Error_Behavior errb) 2704 Error_Behavior errb)
2699 { 2705 {
2700 /* Optimization: */ 2706 /* Optimization: */
2701 if (ERRB_EQ (errb, ERROR_ME_NOT)) 2707 if (ERRB_EQ (errb, ERROR_ME_NOT))
2713 is three objects, a string and two related Lisp objects. 2719 is three objects, a string and two related Lisp objects.
2714 (The equivalent could be accomplished using the class 2 functions, 2720 (The equivalent could be accomplished using the class 2 functions,
2715 but these are more convenient in this particular case.) */ 2721 but these are more convenient in this particular case.) */
2716 2722
2717 DOESNT_RETURN 2723 DOESNT_RETURN
2718 signal_error_2 (Lisp_Object type, const CIbyte *reason, 2724 signal_error_2 (Lisp_Object type, const Ascbyte *reason,
2719 Lisp_Object frob0, Lisp_Object frob1) 2725 Lisp_Object frob0, Lisp_Object frob1)
2720 { 2726 {
2721 signal_error_1 (type, list3 (build_msg_string (reason), frob0, 2727 signal_error_1 (type, list3 (build_msg_string (reason), frob0,
2722 frob1)); 2728 frob1));
2723 } 2729 }
2724 2730
2725 void 2731 void
2726 maybe_signal_error_2 (Lisp_Object type, const CIbyte *reason, 2732 maybe_signal_error_2 (Lisp_Object type, const Ascbyte *reason,
2727 Lisp_Object frob0, Lisp_Object frob1, 2733 Lisp_Object frob0, Lisp_Object frob1,
2728 Lisp_Object class_, Error_Behavior errb) 2734 Lisp_Object class_, Error_Behavior errb)
2729 { 2735 {
2730 /* Optimization: */ 2736 /* Optimization: */
2731 if (ERRB_EQ (errb, ERROR_ME_NOT)) 2737 if (ERRB_EQ (errb, ERROR_ME_NOT))
2733 maybe_signal_error_1 (type, list3 (build_msg_string (reason), frob0, 2739 maybe_signal_error_1 (type, list3 (build_msg_string (reason), frob0,
2734 frob1), class_, errb); 2740 frob1), class_, errb);
2735 } 2741 }
2736 2742
2737 Lisp_Object 2743 Lisp_Object
2738 signal_continuable_error_2 (Lisp_Object type, const CIbyte *reason, 2744 signal_continuable_error_2 (Lisp_Object type, const Ascbyte *reason,
2739 Lisp_Object frob0, Lisp_Object frob1) 2745 Lisp_Object frob0, Lisp_Object frob1)
2740 { 2746 {
2741 return Fsignal (type, list3 (build_msg_string (reason), frob0, 2747 return Fsignal (type, list3 (build_msg_string (reason), frob0,
2742 frob1)); 2748 frob1));
2743 } 2749 }
2744 2750
2745 Lisp_Object 2751 Lisp_Object
2746 maybe_signal_continuable_error_2 (Lisp_Object type, const CIbyte *reason, 2752 maybe_signal_continuable_error_2 (Lisp_Object type, const Ascbyte *reason,
2747 Lisp_Object frob0, Lisp_Object frob1, 2753 Lisp_Object frob0, Lisp_Object frob1,
2748 Lisp_Object class_, Error_Behavior errb) 2754 Lisp_Object class_, Error_Behavior errb)
2749 { 2755 {
2750 /* Optimization: */ 2756 /* Optimization: */
2751 if (ERRB_EQ (errb, ERROR_ME_NOT)) 2757 if (ERRB_EQ (errb, ERROR_ME_NOT))
2761 /* Class 4: Printf-like functions that signal an error. 2767 /* Class 4: Printf-like functions that signal an error.
2762 These functions signal an error of a specified type, whose data 2768 These functions signal an error of a specified type, whose data
2763 is a single string, created using the arguments. */ 2769 is a single string, created using the arguments. */
2764 2770
2765 DOESNT_RETURN 2771 DOESNT_RETURN
2766 signal_ferror (Lisp_Object type, const CIbyte *fmt, ...) 2772 signal_ferror (Lisp_Object type, const Ascbyte *fmt, ...)
2767 { 2773 {
2768 Lisp_Object obj; 2774 Lisp_Object obj;
2769 va_list args; 2775 va_list args;
2770 2776
2771 va_start (args, fmt); 2777 va_start (args, fmt);
2772 obj = emacs_vsprintf_string (CGETTEXT (fmt), args); 2778 obj = emacs_vsprintf_string (GETTEXT (fmt), args);
2773 va_end (args); 2779 va_end (args);
2774 2780
2775 /* Fsignal GC-protects its args */ 2781 /* Fsignal GC-protects its args */
2776 signal_error (type, 0, obj); 2782 signal_error (type, 0, obj);
2777 } 2783 }
2778 2784
2779 void 2785 void
2780 maybe_signal_ferror (Lisp_Object type, Lisp_Object class_, Error_Behavior errb, 2786 maybe_signal_ferror (Lisp_Object type, Lisp_Object class_, Error_Behavior errb,
2781 const CIbyte *fmt, ...) 2787 const Ascbyte *fmt, ...)
2782 { 2788 {
2783 Lisp_Object obj; 2789 Lisp_Object obj;
2784 va_list args; 2790 va_list args;
2785 2791
2786 /* Optimization: */ 2792 /* Optimization: */
2787 if (ERRB_EQ (errb, ERROR_ME_NOT)) 2793 if (ERRB_EQ (errb, ERROR_ME_NOT))
2788 return; 2794 return;
2789 2795
2790 va_start (args, fmt); 2796 va_start (args, fmt);
2791 obj = emacs_vsprintf_string (CGETTEXT (fmt), args); 2797 obj = emacs_vsprintf_string (GETTEXT (fmt), args);
2792 va_end (args); 2798 va_end (args);
2793 2799
2794 /* Fsignal GC-protects its args */ 2800 /* Fsignal GC-protects its args */
2795 maybe_signal_error (type, 0, obj, class_, errb); 2801 maybe_signal_error (type, 0, obj, class_, errb);
2796 } 2802 }
2797 2803
2798 Lisp_Object 2804 Lisp_Object
2799 signal_continuable_ferror (Lisp_Object type, const CIbyte *fmt, ...) 2805 signal_continuable_ferror (Lisp_Object type, const Ascbyte *fmt, ...)
2800 { 2806 {
2801 Lisp_Object obj; 2807 Lisp_Object obj;
2802 va_list args; 2808 va_list args;
2803 2809
2804 va_start (args, fmt); 2810 va_start (args, fmt);
2805 obj = emacs_vsprintf_string (CGETTEXT (fmt), args); 2811 obj = emacs_vsprintf_string (GETTEXT (fmt), args);
2806 va_end (args); 2812 va_end (args);
2807 2813
2808 /* Fsignal GC-protects its args */ 2814 /* Fsignal GC-protects its args */
2809 return Fsignal (type, list1 (obj)); 2815 return Fsignal (type, list1 (obj));
2810 } 2816 }
2811 2817
2812 Lisp_Object 2818 Lisp_Object
2813 maybe_signal_continuable_ferror (Lisp_Object type, Lisp_Object class_, 2819 maybe_signal_continuable_ferror (Lisp_Object type, Lisp_Object class_,
2814 Error_Behavior errb, const CIbyte *fmt, ...) 2820 Error_Behavior errb, const Ascbyte *fmt, ...)
2815 { 2821 {
2816 Lisp_Object obj; 2822 Lisp_Object obj;
2817 va_list args; 2823 va_list args;
2818 2824
2819 /* Optimization: */ 2825 /* Optimization: */
2820 if (ERRB_EQ (errb, ERROR_ME_NOT)) 2826 if (ERRB_EQ (errb, ERROR_ME_NOT))
2821 return Qnil; 2827 return Qnil;
2822 2828
2823 va_start (args, fmt); 2829 va_start (args, fmt);
2824 obj = emacs_vsprintf_string (CGETTEXT (fmt), args); 2830 obj = emacs_vsprintf_string (GETTEXT (fmt), args);
2825 va_end (args); 2831 va_end (args);
2826 2832
2827 /* Fsignal GC-protects its args */ 2833 /* Fsignal GC-protects its args */
2828 return maybe_signal_continuable_error (type, 0, obj, class_, errb); 2834 return maybe_signal_continuable_error (type, 0, obj, class_, errb);
2829 } 2835 }
2842 elements, the first of which is Qunbound), and these functions are 2848 elements, the first of which is Qunbound), and these functions are
2843 not commonly used. 2849 not commonly used.
2844 */ 2850 */
2845 2851
2846 DOESNT_RETURN 2852 DOESNT_RETURN
2847 signal_ferror_with_frob (Lisp_Object type, Lisp_Object frob, const CIbyte *fmt, 2853 signal_ferror_with_frob (Lisp_Object type, Lisp_Object frob, const Ascbyte *fmt,
2848 ...) 2854 ...)
2849 { 2855 {
2850 Lisp_Object obj; 2856 Lisp_Object obj;
2851 va_list args; 2857 va_list args;
2852 2858
2853 va_start (args, fmt); 2859 va_start (args, fmt);
2854 obj = emacs_vsprintf_string (CGETTEXT (fmt), args); 2860 obj = emacs_vsprintf_string (GETTEXT (fmt), args);
2855 va_end (args); 2861 va_end (args);
2856 2862
2857 /* Fsignal GC-protects its args */ 2863 /* Fsignal GC-protects its args */
2858 signal_error_1 (type, Fcons (obj, build_error_data (0, frob))); 2864 signal_error_1 (type, Fcons (obj, build_error_data (0, frob)));
2859 } 2865 }
2860 2866
2861 void 2867 void
2862 maybe_signal_ferror_with_frob (Lisp_Object type, Lisp_Object frob, 2868 maybe_signal_ferror_with_frob (Lisp_Object type, Lisp_Object frob,
2863 Lisp_Object class_, Error_Behavior errb, 2869 Lisp_Object class_, Error_Behavior errb,
2864 const CIbyte *fmt, ...) 2870 const Ascbyte *fmt, ...)
2865 { 2871 {
2866 Lisp_Object obj; 2872 Lisp_Object obj;
2867 va_list args; 2873 va_list args;
2868 2874
2869 /* Optimization: */ 2875 /* Optimization: */
2870 if (ERRB_EQ (errb, ERROR_ME_NOT)) 2876 if (ERRB_EQ (errb, ERROR_ME_NOT))
2871 return; 2877 return;
2872 2878
2873 va_start (args, fmt); 2879 va_start (args, fmt);
2874 obj = emacs_vsprintf_string (CGETTEXT (fmt), args); 2880 obj = emacs_vsprintf_string (GETTEXT (fmt), args);
2875 va_end (args); 2881 va_end (args);
2876 2882
2877 /* Fsignal GC-protects its args */ 2883 /* Fsignal GC-protects its args */
2878 maybe_signal_error_1 (type, Fcons (obj, build_error_data (0, frob)), class_, 2884 maybe_signal_error_1 (type, Fcons (obj, build_error_data (0, frob)), class_,
2879 errb); 2885 errb);
2880 } 2886 }
2881 2887
2882 Lisp_Object 2888 Lisp_Object
2883 signal_continuable_ferror_with_frob (Lisp_Object type, Lisp_Object frob, 2889 signal_continuable_ferror_with_frob (Lisp_Object type, Lisp_Object frob,
2884 const CIbyte *fmt, ...) 2890 const Ascbyte *fmt, ...)
2885 { 2891 {
2886 Lisp_Object obj; 2892 Lisp_Object obj;
2887 va_list args; 2893 va_list args;
2888 2894
2889 va_start (args, fmt); 2895 va_start (args, fmt);
2890 obj = emacs_vsprintf_string (CGETTEXT (fmt), args); 2896 obj = emacs_vsprintf_string (GETTEXT (fmt), args);
2891 va_end (args); 2897 va_end (args);
2892 2898
2893 /* Fsignal GC-protects its args */ 2899 /* Fsignal GC-protects its args */
2894 return Fsignal (type, Fcons (obj, build_error_data (0, frob))); 2900 return Fsignal (type, Fcons (obj, build_error_data (0, frob)));
2895 } 2901 }
2896 2902
2897 Lisp_Object 2903 Lisp_Object
2898 maybe_signal_continuable_ferror_with_frob (Lisp_Object type, Lisp_Object frob, 2904 maybe_signal_continuable_ferror_with_frob (Lisp_Object type, Lisp_Object frob,
2899 Lisp_Object class_, 2905 Lisp_Object class_,
2900 Error_Behavior errb, 2906 Error_Behavior errb,
2901 const CIbyte *fmt, ...) 2907 const Ascbyte *fmt, ...)
2902 { 2908 {
2903 Lisp_Object obj; 2909 Lisp_Object obj;
2904 va_list args; 2910 va_list args;
2905 2911
2906 /* Optimization: */ 2912 /* Optimization: */
2907 if (ERRB_EQ (errb, ERROR_ME_NOT)) 2913 if (ERRB_EQ (errb, ERROR_ME_NOT))
2908 return Qnil; 2914 return Qnil;
2909 2915
2910 va_start (args, fmt); 2916 va_start (args, fmt);
2911 obj = emacs_vsprintf_string (CGETTEXT (fmt), args); 2917 obj = emacs_vsprintf_string (GETTEXT (fmt), args);
2912 va_end (args); 2918 va_end (args);
2913 2919
2914 /* Fsignal GC-protects its args */ 2920 /* Fsignal GC-protects its args */
2915 return maybe_signal_continuable_error_1 (type, 2921 return maybe_signal_continuable_error_1 (type,
2916 Fcons (obj, 2922 Fcons (obj,
2985 signal_error (Qcircular_property_list, 0, list); 2991 signal_error (Qcircular_property_list, 0, list);
2986 } 2992 }
2987 2993
2988 /* Called from within emacs_doprnt_1, so REASON is not formatted. */ 2994 /* Called from within emacs_doprnt_1, so REASON is not formatted. */
2989 DOESNT_RETURN 2995 DOESNT_RETURN
2990 syntax_error (const CIbyte *reason, Lisp_Object frob) 2996 syntax_error (const Ascbyte *reason, Lisp_Object frob)
2991 { 2997 {
2992 signal_error (Qsyntax_error, reason, frob); 2998 signal_error (Qsyntax_error, reason, frob);
2993 } 2999 }
2994 3000
2995 DOESNT_RETURN 3001 DOESNT_RETURN
2996 syntax_error_2 (const CIbyte *reason, Lisp_Object frob1, Lisp_Object frob2) 3002 syntax_error_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2)
2997 { 3003 {
2998 signal_error_2 (Qsyntax_error, reason, frob1, frob2); 3004 signal_error_2 (Qsyntax_error, reason, frob1, frob2);
2999 } 3005 }
3000 3006
3001 void 3007 void
3002 maybe_syntax_error (const CIbyte *reason, Lisp_Object frob, 3008 maybe_syntax_error (const Ascbyte *reason, Lisp_Object frob,
3003 Lisp_Object class_, Error_Behavior errb) 3009 Lisp_Object class_, Error_Behavior errb)
3004 { 3010 {
3005 maybe_signal_error (Qsyntax_error, reason, frob, class_, errb); 3011 maybe_signal_error (Qsyntax_error, reason, frob, class_, errb);
3006 } 3012 }
3007 3013
3008 DOESNT_RETURN 3014 DOESNT_RETURN
3009 sferror (const CIbyte *reason, Lisp_Object frob) 3015 sferror (const Ascbyte *reason, Lisp_Object frob)
3010 { 3016 {
3011 signal_error (Qstructure_formation_error, reason, frob); 3017 signal_error (Qstructure_formation_error, reason, frob);
3012 } 3018 }
3013 3019
3014 DOESNT_RETURN 3020 DOESNT_RETURN
3015 sferror_2 (const CIbyte *reason, Lisp_Object frob1, Lisp_Object frob2) 3021 sferror_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2)
3016 { 3022 {
3017 signal_error_2 (Qstructure_formation_error, reason, frob1, frob2); 3023 signal_error_2 (Qstructure_formation_error, reason, frob1, frob2);
3018 } 3024 }
3019 3025
3020 void 3026 void
3021 maybe_sferror (const CIbyte *reason, Lisp_Object frob, 3027 maybe_sferror (const Ascbyte *reason, Lisp_Object frob,
3022 Lisp_Object class_, Error_Behavior errb) 3028 Lisp_Object class_, Error_Behavior errb)
3023 { 3029 {
3024 maybe_signal_error (Qstructure_formation_error, reason, frob, class_, errb); 3030 maybe_signal_error (Qstructure_formation_error, reason, frob, class_, errb);
3025 } 3031 }
3026 3032
3027 DOESNT_RETURN 3033 DOESNT_RETURN
3028 invalid_argument (const CIbyte *reason, Lisp_Object frob) 3034 invalid_argument (const Ascbyte *reason, Lisp_Object frob)
3029 { 3035 {
3030 signal_error (Qinvalid_argument, reason, frob); 3036 signal_error (Qinvalid_argument, reason, frob);
3031 } 3037 }
3032 3038
3033 DOESNT_RETURN 3039 DOESNT_RETURN
3034 invalid_argument_2 (const CIbyte *reason, Lisp_Object frob1, 3040 invalid_argument_2 (const Ascbyte *reason, Lisp_Object frob1,
3035 Lisp_Object frob2) 3041 Lisp_Object frob2)
3036 { 3042 {
3037 signal_error_2 (Qinvalid_argument, reason, frob1, frob2); 3043 signal_error_2 (Qinvalid_argument, reason, frob1, frob2);
3038 } 3044 }
3039 3045
3040 void 3046 void
3041 maybe_invalid_argument (const CIbyte *reason, Lisp_Object frob, 3047 maybe_invalid_argument (const Ascbyte *reason, Lisp_Object frob,
3042 Lisp_Object class_, Error_Behavior errb) 3048 Lisp_Object class_, Error_Behavior errb)
3043 { 3049 {
3044 maybe_signal_error (Qinvalid_argument, reason, frob, class_, errb); 3050 maybe_signal_error (Qinvalid_argument, reason, frob, class_, errb);
3045 } 3051 }
3046 3052
3047 DOESNT_RETURN 3053 DOESNT_RETURN
3048 invalid_constant (const CIbyte *reason, Lisp_Object frob) 3054 invalid_constant (const Ascbyte *reason, Lisp_Object frob)
3049 { 3055 {
3050 signal_error (Qinvalid_constant, reason, frob); 3056 signal_error (Qinvalid_constant, reason, frob);
3051 } 3057 }
3052 3058
3053 DOESNT_RETURN 3059 DOESNT_RETURN
3054 invalid_constant_2 (const CIbyte *reason, Lisp_Object frob1, 3060 invalid_constant_2 (const Ascbyte *reason, Lisp_Object frob1,
3055 Lisp_Object frob2) 3061 Lisp_Object frob2)
3056 { 3062 {
3057 signal_error_2 (Qinvalid_constant, reason, frob1, frob2); 3063 signal_error_2 (Qinvalid_constant, reason, frob1, frob2);
3058 } 3064 }
3059 3065
3060 void 3066 void
3061 maybe_invalid_constant (const CIbyte *reason, Lisp_Object frob, 3067 maybe_invalid_constant (const Ascbyte *reason, Lisp_Object frob,
3062 Lisp_Object class_, Error_Behavior errb) 3068 Lisp_Object class_, Error_Behavior errb)
3063 { 3069 {
3064 maybe_signal_error (Qinvalid_constant, reason, frob, class_, errb); 3070 maybe_signal_error (Qinvalid_constant, reason, frob, class_, errb);
3065 } 3071 }
3066 3072
3067 DOESNT_RETURN 3073 DOESNT_RETURN
3068 invalid_operation (const CIbyte *reason, Lisp_Object frob) 3074 invalid_operation (const Ascbyte *reason, Lisp_Object frob)
3069 { 3075 {
3070 signal_error (Qinvalid_operation, reason, frob); 3076 signal_error (Qinvalid_operation, reason, frob);
3071 } 3077 }
3072 3078
3073 DOESNT_RETURN 3079 DOESNT_RETURN
3074 invalid_operation_2 (const CIbyte *reason, Lisp_Object frob1, 3080 invalid_operation_2 (const Ascbyte *reason, Lisp_Object frob1,
3075 Lisp_Object frob2) 3081 Lisp_Object frob2)
3076 { 3082 {
3077 signal_error_2 (Qinvalid_operation, reason, frob1, frob2); 3083 signal_error_2 (Qinvalid_operation, reason, frob1, frob2);
3078 } 3084 }
3079 3085
3080 void 3086 void
3081 maybe_invalid_operation (const CIbyte *reason, Lisp_Object frob, 3087 maybe_invalid_operation (const Ascbyte *reason, Lisp_Object frob,
3082 Lisp_Object class_, Error_Behavior errb) 3088 Lisp_Object class_, Error_Behavior errb)
3083 { 3089 {
3084 maybe_signal_error (Qinvalid_operation, reason, frob, class_, errb); 3090 maybe_signal_error (Qinvalid_operation, reason, frob, class_, errb);
3085 } 3091 }
3086 3092
3087 DOESNT_RETURN 3093 DOESNT_RETURN
3088 invalid_change (const CIbyte *reason, Lisp_Object frob) 3094 invalid_change (const Ascbyte *reason, Lisp_Object frob)
3089 { 3095 {
3090 signal_error (Qinvalid_change, reason, frob); 3096 signal_error (Qinvalid_change, reason, frob);
3091 } 3097 }
3092 3098
3093 DOESNT_RETURN 3099 DOESNT_RETURN
3094 invalid_change_2 (const CIbyte *reason, Lisp_Object frob1, Lisp_Object frob2) 3100 invalid_change_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2)
3095 { 3101 {
3096 signal_error_2 (Qinvalid_change, reason, frob1, frob2); 3102 signal_error_2 (Qinvalid_change, reason, frob1, frob2);
3097 } 3103 }
3098 3104
3099 void 3105 void
3100 maybe_invalid_change (const CIbyte *reason, Lisp_Object frob, 3106 maybe_invalid_change (const Ascbyte *reason, Lisp_Object frob,
3101 Lisp_Object class_, Error_Behavior errb) 3107 Lisp_Object class_, Error_Behavior errb)
3102 { 3108 {
3103 maybe_signal_error (Qinvalid_change, reason, frob, class_, errb); 3109 maybe_signal_error (Qinvalid_change, reason, frob, class_, errb);
3104 } 3110 }
3105 3111
3106 DOESNT_RETURN 3112 DOESNT_RETURN
3107 invalid_state (const CIbyte *reason, Lisp_Object frob) 3113 invalid_state (const Ascbyte *reason, Lisp_Object frob)
3108 { 3114 {
3109 signal_error (Qinvalid_state, reason, frob); 3115 signal_error (Qinvalid_state, reason, frob);
3110 } 3116 }
3111 3117
3112 DOESNT_RETURN 3118 DOESNT_RETURN
3113 invalid_state_2 (const CIbyte *reason, Lisp_Object frob1, Lisp_Object frob2) 3119 invalid_state_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2)
3114 { 3120 {
3115 signal_error_2 (Qinvalid_state, reason, frob1, frob2); 3121 signal_error_2 (Qinvalid_state, reason, frob1, frob2);
3116 } 3122 }
3117 3123
3118 void 3124 void
3119 maybe_invalid_state (const CIbyte *reason, Lisp_Object frob, 3125 maybe_invalid_state (const Ascbyte *reason, Lisp_Object frob,
3120 Lisp_Object class_, Error_Behavior errb) 3126 Lisp_Object class_, Error_Behavior errb)
3121 { 3127 {
3122 maybe_signal_error (Qinvalid_state, reason, frob, class_, errb); 3128 maybe_signal_error (Qinvalid_state, reason, frob, class_, errb);
3123 } 3129 }
3124 3130
3125 DOESNT_RETURN 3131 DOESNT_RETURN
3126 wtaerror (const CIbyte *reason, Lisp_Object frob) 3132 wtaerror (const Ascbyte *reason, Lisp_Object frob)
3127 { 3133 {
3128 signal_error (Qwrong_type_argument, reason, frob); 3134 signal_error (Qwrong_type_argument, reason, frob);
3129 } 3135 }
3130 3136
3131 DOESNT_RETURN 3137 DOESNT_RETURN
3132 stack_overflow (const CIbyte *reason, Lisp_Object frob) 3138 stack_overflow (const Ascbyte *reason, Lisp_Object frob)
3133 { 3139 {
3134 signal_error (Qstack_overflow, reason, frob); 3140 signal_error (Qstack_overflow, reason, frob);
3135 } 3141 }
3136 3142
3137 DOESNT_RETURN 3143 DOESNT_RETURN
3138 out_of_memory (const CIbyte *reason, Lisp_Object frob) 3144 out_of_memory (const Ascbyte *reason, Lisp_Object frob)
3139 { 3145 {
3140 signal_error (Qout_of_memory, reason, frob); 3146 signal_error (Qout_of_memory, reason, frob);
3141 } 3147 }
3142 3148
3143 3149
3618 } 3624 }
3619 3625
3620 { 3626 {
3621 Lisp_Object value = 3627 Lisp_Object value =
3622 execute_optimized_program ((Opbyte *) XOPAQUE_DATA (f->instructions), 3628 execute_optimized_program ((Opbyte *) XOPAQUE_DATA (f->instructions),
3629 #ifdef ERROR_CHECK_BYTE_CODE
3630 XOPAQUE_SIZE (f->instructions) /
3631 sizeof (Opbyte),
3632 #endif
3623 f->stack_depth, 3633 f->stack_depth,
3624 XVECTOR_DATA (f->constants)); 3634 XVECTOR_DATA (f->constants));
3625 3635
3626 /* The attempt to optimize this by only unbinding variables failed 3636 /* The attempt to optimize this by only unbinding variables failed
3627 because using buffer-local variables as function parameters 3637 because using buffer-local variables as function parameters
4570 printing_unreadable_object ("multiple values"); 4580 printing_unreadable_object ("multiple values");
4571 } 4581 }
4572 4582
4573 if (0 == count) 4583 if (0 == count)
4574 { 4584 {
4575 write_c_string (printcharfun, "#<zero-length multiple value>"); 4585 write_msg_string (printcharfun, "#<zero-length multiple value>");
4576 } 4586 }
4577 4587
4578 for (index = 0; index < count;) 4588 for (index = 0; index < count;)
4579 { 4589 {
4580 if (index != 0 && 4590 if (index != 0 &&
4592 4602
4593 ++index; 4603 ++index;
4594 4604
4595 if (count > 1 && index < count) 4605 if (count > 1 && index < count)
4596 { 4606 {
4597 write_c_string (printcharfun, " ;\n"); 4607 write_ascstring (printcharfun, " ;\n");
4598 } 4608 }
4599 } 4609 }
4600 } 4610 }
4601 4611
4602 static Lisp_Object 4612 static Lisp_Object
5711 Lisp_Object errstr = 5721 Lisp_Object errstr =
5712 emacs_sprintf_string_lisp 5722 emacs_sprintf_string_lisp
5713 ("%s: Attempt to throw outside of function:" 5723 ("%s: Attempt to throw outside of function:"
5714 "To catch `%s' with value `%s'\n\nBacktrace follows:\n\n%s", 5724 "To catch `%s' with value `%s'\n\nBacktrace follows:\n\n%s",
5715 Qnil, 4, 5725 Qnil, 4,
5716 build_msg_string (warning_string ? warning_string : "error"), 5726 build_msg_cistring (warning_string ? warning_string : "error"),
5717 p->thrown_tag, p->thrown_value, p->backtrace); 5727 p->thrown_tag, p->thrown_value, p->backtrace);
5718 warn_when_safe_lispobj (Qerror, current_warning_level (), errstr); 5728 warn_when_safe_lispobj (Qerror, current_warning_level (), errstr);
5719 } 5729 }
5720 else if (p->caught_error && !EQ (p->error_conditions, Qquit)) 5730 else if (p->caught_error && !EQ (p->error_conditions, Qquit))
5721 { 5731 {
5726 but that stuff is all in Lisp currently. */ 5736 but that stuff is all in Lisp currently. */
5727 errstr = 5737 errstr =
5728 emacs_sprintf_string_lisp 5738 emacs_sprintf_string_lisp
5729 ("%s: (%s %s)\n\nBacktrace follows:\n\n%s", 5739 ("%s: (%s %s)\n\nBacktrace follows:\n\n%s",
5730 Qnil, 4, 5740 Qnil, 4,
5731 build_msg_string (warning_string ? warning_string : "error"), 5741 build_msg_cistring (warning_string ? warning_string : "error"),
5732 p->error_conditions, p->data, p->backtrace); 5742 p->error_conditions, p->data, p->backtrace);
5733 5743
5734 warn_when_safe_lispobj (warning_class, current_warning_level (), 5744 warn_when_safe_lispobj (warning_class, current_warning_level (),
5735 errstr); 5745 errstr);
5736 } 5746 }
6797 } 6807 }
6798 6808
6799 static Lisp_Object 6809 static Lisp_Object
6800 free_pointer (Lisp_Object opaque) 6810 free_pointer (Lisp_Object opaque)
6801 { 6811 {
6802 xfree (get_opaque_ptr (opaque), void *); 6812 xfree (get_opaque_ptr (opaque));
6803 free_opaque_ptr (opaque); 6813 free_opaque_ptr (opaque);
6804 return Qnil; 6814 return Qnil;
6805 } 6815 }
6806 6816
6807 /* Establish an unwind-protect which will free the specified block. 6817 /* Establish an unwind-protect which will free the specified block.
6998 { 7008 {
6999 if (specpdl[speccount - 1].func == 0 7009 if (specpdl[speccount - 1].func == 0
7000 || specpdl[speccount - 1].func == specbind_unwind_local 7010 || specpdl[speccount - 1].func == specbind_unwind_local
7001 || specpdl[speccount - 1].func == specbind_unwind_wasnt_local) 7011 || specpdl[speccount - 1].func == specbind_unwind_wasnt_local)
7002 { 7012 {
7003 write_c_string (stream, !printing_bindings ? " # bind (" : " "); 7013 write_ascstring (stream, !printing_bindings ? " # bind (" : " ");
7004 Fprin1 (specpdl[speccount - 1].symbol, stream); 7014 Fprin1 (specpdl[speccount - 1].symbol, stream);
7005 printing_bindings = 1; 7015 printing_bindings = 1;
7006 } 7016 }
7007 else 7017 else
7008 { 7018 {
7009 if (printing_bindings) write_c_string (stream, ")\n"); 7019 if (printing_bindings) write_ascstring (stream, ")\n");
7010 write_c_string (stream, " # (unwind-protect ...)\n"); 7020 write_ascstring (stream, " # (unwind-protect ...)\n");
7011 printing_bindings = 0; 7021 printing_bindings = 0;
7012 } 7022 }
7013 } 7023 }
7014 if (printing_bindings) write_c_string (stream, ")\n"); 7024 if (printing_bindings) write_ascstring (stream, ")\n");
7015 } 7025 }
7016 7026
7017 static Lisp_Object 7027 static Lisp_Object
7018 backtrace_unevalled_args (Lisp_Object *args) 7028 backtrace_unevalled_args (Lisp_Object *args)
7019 { 7029 {
7020 if (args) 7030 if (args)
7021 return *args; 7031 return *args;
7022 else 7032 else
7023 return list1 (build_string ("[internal]")); 7033 return list1 (build_ascstring ("[internal]"));
7024 } 7034 }
7025 7035
7026 DEFUN ("backtrace", Fbacktrace, 0, 2, "", /* 7036 DEFUN ("backtrace", Fbacktrace, 0, 2, "", /*
7027 Print a trace of Lisp function calls currently active. 7037 Print a trace of Lisp function calls currently active.
7028 Optional arg STREAM specifies the output stream to send the backtrace to, 7038 Optional arg STREAM specifies the output stream to send the backtrace to,
7076 backtrace_specials (speccount, catchpdl, stream); 7086 backtrace_specials (speccount, catchpdl, stream);
7077 7087
7078 speccount = catches->pdlcount; 7088 speccount = catches->pdlcount;
7079 if (catchpdl == speccount) 7089 if (catchpdl == speccount)
7080 { 7090 {
7081 write_c_string (stream, " # (catch "); 7091 write_ascstring (stream, " # (catch ");
7082 Fprin1 (catches->tag, stream); 7092 Fprin1 (catches->tag, stream);
7083 write_c_string (stream, " ...)\n"); 7093 write_ascstring (stream, " ...)\n");
7084 } 7094 }
7085 else 7095 else
7086 { 7096 {
7087 write_c_string (stream, " # (condition-case ... . "); 7097 write_ascstring (stream, " # (condition-case ... . ");
7088 Fprin1 (Fcdr (Fcar (catches->tag)), stream); 7098 Fprin1 (Fcdr (Fcar (catches->tag)), stream);
7089 write_c_string (stream, ")\n"); 7099 write_ascstring (stream, ")\n");
7090 } 7100 }
7091 catches = catches->next; 7101 catches = catches->next;
7092 } 7102 }
7093 else if (!backlist) 7103 else if (!backlist)
7094 break; 7104 break;
7097 if (!NILP (detailed) && backlist->pdlcount < speccount) 7107 if (!NILP (detailed) && backlist->pdlcount < speccount)
7098 { 7108 {
7099 backtrace_specials (speccount, backlist->pdlcount, stream); 7109 backtrace_specials (speccount, backlist->pdlcount, stream);
7100 speccount = backlist->pdlcount; 7110 speccount = backlist->pdlcount;
7101 } 7111 }
7102 write_c_string (stream, backlist->debug_on_exit ? "* " : " "); 7112 write_ascstring (stream, backlist->debug_on_exit ? "* " : " ");
7103 if (backlist->nargs == UNEVALLED) 7113 if (backlist->nargs == UNEVALLED)
7104 { 7114 {
7105 Fprin1 (Fcons (*backlist->function, 7115 Fprin1 (Fcons (*backlist->function,
7106 backtrace_unevalled_args (backlist->args)), 7116 backtrace_unevalled_args (backlist->args)),
7107 stream); 7117 stream);
7108 write_c_string (stream, "\n"); /* from FSFmacs 19.30 */ 7118 write_ascstring (stream, "\n"); /* from FSFmacs 19.30 */
7109 } 7119 }
7110 else 7120 else
7111 { 7121 {
7112 Lisp_Object tem = *backlist->function; 7122 Lisp_Object tem = *backlist->function;
7113 Fprin1 (tem, stream); /* This can QUIT */ 7123 Fprin1 (tem, stream); /* This can QUIT */
7114 write_c_string (stream, "("); 7124 write_ascstring (stream, "(");
7115 if (backlist->nargs == MANY) 7125 if (backlist->nargs == MANY)
7116 { 7126 {
7117 int i; 7127 int i;
7118 Lisp_Object tail = Qnil; 7128 Lisp_Object tail = Qnil;
7119 struct gcpro ngcpro1; 7129 struct gcpro ngcpro1;
7121 NGCPRO1 (tail); 7131 NGCPRO1 (tail);
7122 for (tail = *backlist->args, i = 0; 7132 for (tail = *backlist->args, i = 0;
7123 !NILP (tail); 7133 !NILP (tail);
7124 tail = Fcdr (tail), i++) 7134 tail = Fcdr (tail), i++)
7125 { 7135 {
7126 if (i != 0) write_c_string (stream, " "); 7136 if (i != 0) write_ascstring (stream, " ");
7127 Fprin1 (Fcar (tail), stream); 7137 Fprin1 (Fcar (tail), stream);
7128 } 7138 }
7129 NUNGCPRO; 7139 NUNGCPRO;
7130 } 7140 }
7131 else 7141 else
7133 int i; 7143 int i;
7134 for (i = 0; i < backlist->nargs; i++) 7144 for (i = 0; i < backlist->nargs; i++)
7135 { 7145 {
7136 if (!i && EQ (tem, Qbyte_code)) 7146 if (!i && EQ (tem, Qbyte_code))
7137 { 7147 {
7138 write_c_string (stream, "\"...\""); 7148 write_ascstring (stream, "\"...\"");
7139 continue; 7149 continue;
7140 } 7150 }
7141 if (i != 0) write_c_string (stream, " "); 7151 if (i != 0) write_ascstring (stream, " ");
7142 Fprin1 (backlist->args[i], stream); 7152 Fprin1 (backlist->args[i], stream);
7143 } 7153 }
7144 } 7154 }
7145 write_c_string (stream, ")\n"); 7155 write_ascstring (stream, ")\n");
7146 } 7156 }
7147 backlist = backlist->next; 7157 backlist = backlist->next;
7148 } 7158 }
7149 } 7159 }
7150 Vprint_level = old_level; 7160 Vprint_level = old_level;
7232 An alternative approach is to just pass some non-string type of 7242 An alternative approach is to just pass some non-string type of
7233 Lisp_Object to warn_when_safe_lispobj(); `prin1-to-string' will 7243 Lisp_Object to warn_when_safe_lispobj(); `prin1-to-string' will
7234 automatically be called when it is safe to do so. */ 7244 automatically be called when it is safe to do so. */
7235 7245
7236 void 7246 void
7237 warn_when_safe (Lisp_Object class_, Lisp_Object level, const CIbyte *fmt, ...) 7247 warn_when_safe (Lisp_Object class_, Lisp_Object level, const Ascbyte *fmt, ...)
7238 { 7248 {
7239 Lisp_Object obj; 7249 Lisp_Object obj;
7240 va_list args; 7250 va_list args;
7241 7251
7242 if (warning_will_be_discarded (level)) 7252 if (warning_will_be_discarded (level))
7243 return; 7253 return;
7244 7254
7245 va_start (args, fmt); 7255 va_start (args, fmt);
7246 obj = emacs_vsprintf_string (CGETTEXT (fmt), args); 7256 obj = emacs_vsprintf_string (GETTEXT (fmt), args);
7247 va_end (args); 7257 va_end (args);
7248 7258
7249 warn_when_safe_lispobj (class_, level, obj); 7259 warn_when_safe_lispobj (class_, level, obj);
7250 } 7260 }
7251 7261