Mercurial > hg > xemacs-beta

comparison src/eval.c @ 272:c5d627a313b1 r21-0b34

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-0b34
author cvs
date Mon, 13 Aug 2007 10:28:48 +0200
parents 677f6a0ee643
children 90d73dddcdc4
comparison
equal deleted inserted replaced
271:c7b7086b0a39 272:c5d627a313b1
30 30
31 #ifndef standalone 31 #ifndef standalone
32 #include "commands.h" 32 #include "commands.h"
33 #endif 33 #endif
34 34
35 #include "symeval.h"
36 #include "backtrace.h" 35 #include "backtrace.h"
37 #include "bytecode.h" 36 #include "bytecode.h"
38 #include "buffer.h" 37 #include "buffer.h"
39 #include "console.h" 38 #include "console.h"
40 #include "opaque.h" 39 #include "opaque.h"
48 #define PUSH_BACKTRACE(bt) \ 47 #define PUSH_BACKTRACE(bt) \
49 do { (bt).next = backtrace_list; backtrace_list = &(bt); } while (0) 48 do { (bt).next = backtrace_list; backtrace_list = &(bt); } while (0)
50 49
51 #define POP_BACKTRACE(bt) \ 50 #define POP_BACKTRACE(bt) \
52 do { backtrace_list = (bt).next; } while (0) 51 do { backtrace_list = (bt).next; } while (0)
53
54 extern int profiling_active;
55 void profile_increase_call_count (Lisp_Object);
56 52
57 /* This is the list of current catches (and also condition-cases). 53 /* This is the list of current catches (and also condition-cases).
58 This is a stack: the most recent catch is at the head of the 54 This is a stack: the most recent catch is at the head of the
59 list. Catches are created by declaring a 'struct catchtag' 55 list. Catches are created by declaring a 'struct catchtag'
60 locally, filling the .TAG field in with the tag, and doing 56 locally, filling the .TAG field in with the tag, and doing
77 73
78 Lisp_Object Qautoload, Qmacro, Qexit; 74 Lisp_Object Qautoload, Qmacro, Qexit;
79 Lisp_Object Qinteractive, Qcommandp, Qdefun, Qprogn, Qvalues; 75 Lisp_Object Qinteractive, Qcommandp, Qdefun, Qprogn, Qvalues;
80 Lisp_Object Vquit_flag, Vinhibit_quit; 76 Lisp_Object Vquit_flag, Vinhibit_quit;
81 Lisp_Object Qand_rest, Qand_optional; 77 Lisp_Object Qand_rest, Qand_optional;
82 Lisp_Object Qdebug_on_error; 78 Lisp_Object Qdebug_on_error, Qstack_trace_on_error;
83 Lisp_Object Qstack_trace_on_error; 79 Lisp_Object Qdebug_on_signal, Qstack_trace_on_signal;
84 Lisp_Object Qdebug_on_signal;
85 Lisp_Object Qstack_trace_on_signal;
86 Lisp_Object Qdebugger; 80 Lisp_Object Qdebugger;
87 Lisp_Object Qinhibit_quit; 81 Lisp_Object Qinhibit_quit;
88 Lisp_Object Qrun_hooks; 82 Lisp_Object Qrun_hooks;
89
90 Lisp_Object Qsetq; 83 Lisp_Object Qsetq;
91
92 Lisp_Object Qdisplay_warning; 84 Lisp_Object Qdisplay_warning;
93 Lisp_Object Vpending_warnings, Vpending_warnings_tail; 85 Lisp_Object Vpending_warnings, Vpending_warnings_tail;
94 86
95 /* Records whether we want errors to occur. This will be a boolean, 87 /* Records whether we want errors to occur. This will be a boolean,
96 nil (errors OK) or t (no errors). If t, an error will cause a 88 nil (errors OK) or t (no errors). If t, an error will cause a
241 233
242 /**********************************************************************/ 234 /**********************************************************************/
243 /* The subr and compiled-function types */ 235 /* The subr and compiled-function types */
244 /**********************************************************************/ 236 /**********************************************************************/
245 237
246 static void print_subr (Lisp_Object, Lisp_Object, int);
247 DEFINE_LRECORD_IMPLEMENTATION ("subr", subr,
248 this_one_is_unmarkable, print_subr, 0, 0, 0,
249 struct Lisp_Subr);
250
251 static void 238 static void
252 print_subr (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 239 print_subr (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
253 { 240 {
254 struct Lisp_Subr *subr = XSUBR (obj); 241 struct Lisp_Subr *subr = XSUBR (obj);
255 242
265 write_c_string (subr_name (subr), printcharfun); 252 write_c_string (subr_name (subr), printcharfun);
266 write_c_string (((subr->prompt) ? " (interactive)>" : ">"), 253 write_c_string (((subr->prompt) ? " (interactive)>" : ">"),
267 printcharfun); 254 printcharfun);
268 } 255 }
269 256
257 DEFINE_LRECORD_IMPLEMENTATION ("subr", subr,
258 this_one_is_unmarkable, print_subr, 0, 0, 0,
259 struct Lisp_Subr);
270 260
271 static Lisp_Object mark_compiled_function (Lisp_Object,
272 void (*) (Lisp_Object));
273 extern void print_compiled_function (Lisp_Object, Lisp_Object, int);
274 static int compiled_function_equal (Lisp_Object, Lisp_Object, int);
275 static unsigned long compiled_function_hash (Lisp_Object obj, int depth);
276 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function,
277 mark_compiled_function,
278 print_compiled_function, 0,
279 compiled_function_equal,
280 compiled_function_hash,
281 struct Lisp_Compiled_Function);
282
283 static Lisp_Object 261 static Lisp_Object
284 mark_compiled_function (Lisp_Object obj, void (*markobj) (Lisp_Object)) 262 mark_compiled_function (Lisp_Object obj, void (*markobj) (Lisp_Object))
285 { 263 {
286 struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (obj); 264 struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (obj);
287 265
298 static int 276 static int
299 compiled_function_equal (Lisp_Object o1, Lisp_Object o2, int depth) 277 compiled_function_equal (Lisp_Object o1, Lisp_Object o2, int depth)
300 { 278 {
301 struct Lisp_Compiled_Function *b1 = XCOMPILED_FUNCTION (o1); 279 struct Lisp_Compiled_Function *b1 = XCOMPILED_FUNCTION (o1);
302 struct Lisp_Compiled_Function *b2 = XCOMPILED_FUNCTION (o2); 280 struct Lisp_Compiled_Function *b2 = XCOMPILED_FUNCTION (o2);
303 return (b1->flags.documentationp == b2->flags.documentationp 281 return
304 && b1->flags.interactivep == b2->flags.interactivep 282 (b1->flags.documentationp == b2->flags.documentationp &&
305 && b1->flags.domainp == b2->flags.domainp /* I18N3 */ 283 b1->flags.interactivep == b2->flags.interactivep &&
306 && internal_equal (b1->bytecodes, b2->bytecodes, depth + 1) 284 b1->flags.domainp == b2->flags.domainp && /* I18N3 */
307 && internal_equal (b1->constants, b2->constants, depth + 1) 285 internal_equal (b1->bytecodes, b2->bytecodes, depth + 1) &&
308 && internal_equal (b1->arglist, b2->arglist, depth + 1) 286 internal_equal (b1->constants, b2->constants, depth + 1) &&
309 && internal_equal (b1->doc_and_interactive, 287 internal_equal (b1->arglist, b2->arglist, depth + 1) &&
310 b2->doc_and_interactive, depth + 1)); 288 internal_equal (b1->doc_and_interactive,
289 b2->doc_and_interactive, depth + 1));
311 } 290 }
312 291
313 static unsigned long 292 static unsigned long
314 compiled_function_hash (Lisp_Object obj, int depth) 293 compiled_function_hash (Lisp_Object obj, int depth)
315 { 294 {
319 b->flags.domainp, 298 b->flags.domainp,
320 internal_hash (b->bytecodes, depth + 1), 299 internal_hash (b->bytecodes, depth + 1),
321 internal_hash (b->constants, depth + 1)); 300 internal_hash (b->constants, depth + 1));
322 } 301 }
323 302
303 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function,
304 mark_compiled_function,
305 print_compiled_function, 0,
306 compiled_function_equal,
307 compiled_function_hash,
308 struct Lisp_Compiled_Function);
324 309
325 /**********************************************************************/ 310 /**********************************************************************/
326 /* Entering the debugger */ 311 /* Entering the debugger */
327 /**********************************************************************/ 312 /**********************************************************************/
328 313
519 backtrace_259 (Lisp_Object stream) 504 backtrace_259 (Lisp_Object stream)
520 { 505 {
521 return Fbacktrace (stream, Qt); 506 return Fbacktrace (stream, Qt);
522 } 507 }
523 508
524 /* An error was signalled. Maybe call the debugger, if the `debug-on-error' 509 /* An error was signaled. Maybe call the debugger, if the `debug-on-error'
525 etc. variables call for this. CONDITIONS is the list of conditions 510 etc. variables call for this. CONDITIONS is the list of conditions
526 associated with the error being signalled. SIG is the actual error 511 associated with the error being signalled. SIG is the actual error
527 being signalled, and DATA is the associated data (these are exactly 512 being signalled, and DATA is the associated data (these are exactly
528 the same as the arguments to `signal'). ACTIVE_HANDLERS is the 513 the same as the arguments to `signal'). ACTIVE_HANDLERS is the
529 list of error handlers that are to be put in place while the debugger 514 list of error handlers that are to be put in place while the debugger
652 If all args return nil, return nil. 637 If all args return nil, return nil.
653 */ 638 */
654 (args)) 639 (args))
655 { 640 {
656 /* This function can GC */ 641 /* This function can GC */
657 Lisp_Object val = Qnil; 642 REGISTER Lisp_Object tail;
658 struct gcpro gcpro1; 643 struct gcpro gcpro1;
659 644
660 GCPRO1 (args); 645 GCPRO1 (args);
661 646
662 while (!NILP (args)) 647 LIST_LOOP (tail, args)
663 { 648 {
664 val = Feval (XCAR (args)); 649 Lisp_Object val = Feval (XCAR (tail));
665 if (!NILP (val)) 650 if (!NILP (val))
666 break; 651 {
667 args = XCDR (args); 652 UNGCPRO;
653 return val;
654 }
668 } 655 }
669 656
670 UNGCPRO; 657 UNGCPRO;
671 return val; 658 return Qnil;
672 } 659 }
673 660
674 DEFUN ("and", Fand, 0, UNEVALLED, 0, /* 661 DEFUN ("and", Fand, 0, UNEVALLED, 0, /*
675 Eval args until one of them yields nil, then return nil. 662 Eval args until one of them yields nil, then return nil.
676 The remaining args are not evalled at all. 663 The remaining args are not evalled at all.
677 If no arg yields nil, return the last arg's value. 664 If no arg yields nil, return the last arg's value.
678 */ 665 */
679 (args)) 666 (args))
680 { 667 {
681 /* This function can GC */ 668 /* This function can GC */
682 Lisp_Object val = Qt; 669 REGISTER Lisp_Object tail, val = Qt;
683 struct gcpro gcpro1; 670 struct gcpro gcpro1;
684 671
685 GCPRO1 (args); 672 GCPRO1 (args);
686 673
687 while (!NILP (args)) 674 LIST_LOOP (tail, args)
688 { 675 {
689 val = Feval (XCAR (args)); 676 val = Feval (XCAR (tail));
690 if (NILP (val)) 677 if (NILP (val))
691 break; 678 break;
692 args = XCDR (args);
693 } 679 }
694 680
695 UNGCPRO; 681 UNGCPRO;
696 return val; 682 return val;
697 } 683 }
698 684
699 DEFUN ("if", Fif, 2, UNEVALLED, 0, /* 685 DEFUN ("if", Fif, 2, UNEVALLED, 0, /*
700 (if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE... 686 \(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...
701 Returns the value of THEN or the value of the last of the ELSE's. 687 Returns the value of THEN or the value of the last of the ELSE's.
702 THEN must be one expression, but ELSE... can be zero or more expressions. 688 THEN must be one expression, but ELSE... can be zero or more expressions.
703 If COND yields nil, and there are no ELSE's, the value is nil. 689 If COND yields nil, and there are no ELSE's, the value is nil.
704 */ 690 */
705 (args)) 691 (args))
706 { 692 {
707 /* This function can GC */ 693 /* This function can GC */
708 Lisp_Object cond; 694 Lisp_Object val;
709 struct gcpro gcpro1; 695 struct gcpro gcpro1;
710 696
711 GCPRO1 (args); 697 GCPRO1 (args);
712 cond = Feval (XCAR (args)); 698
699 if (!NILP (Feval (XCAR (args))))
700 val = Feval (XCAR (XCDR ((args))));
701 else
702 val = Fprogn (XCDR (XCDR (args)));
703
713 UNGCPRO; 704 UNGCPRO;
714 705 return val;
715 args = XCDR (args);
716
717 if (!NILP (cond))
718 return Feval (XCAR (args));
719 return Fprogn (XCDR (args));
720 } 706 }
721 707
722 DEFUN ("cond", Fcond, 0, UNEVALLED, 0, /* 708 DEFUN ("cond", Fcond, 0, UNEVALLED, 0, /*
723 (cond CLAUSES...): try each clause until one succeeds. 709 (cond CLAUSES...): try each clause until one succeeds.
724 Each clause looks like (CONDITION BODY...). CONDITION is evaluated 710 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
730 CONDITION's value if non-nil is returned from the cond-form. 716 CONDITION's value if non-nil is returned from the cond-form.
731 */ 717 */
732 (args)) 718 (args))
733 { 719 {
734 /* This function can GC */ 720 /* This function can GC */
735 Lisp_Object val = Qnil; 721 REGISTER Lisp_Object tail;
736 struct gcpro gcpro1; 722 struct gcpro gcpro1;
737 723
738 GCPRO1 (args); 724 GCPRO1 (args);
739 while (!NILP (args)) 725
740 { 726 LIST_LOOP (tail, args)
741 Lisp_Object clause = XCAR (args); 727 {
728 Lisp_Object val;
729 Lisp_Object clause = XCAR (tail);
730 CHECK_CONS (clause);
742 val = Feval (XCAR (clause)); 731 val = Feval (XCAR (clause));
743 if (!NILP (val)) 732 if (!NILP (val))
744 { 733 {
745 if (!EQ (XCDR (clause), Qnil)) 734 Lisp_Object clause_tail = XCDR (clause);
746 val = Fprogn (XCDR (clause)); 735 if (!NILP (clause_tail))
747 break; 736 {
737 CHECK_TRUE_LIST (clause_tail);
738 val = Fprogn (clause_tail);
739 }
740 UNGCPRO;
741 return val;
748 } 742 }
749 args = XCDR (args);
750 } 743 }
751 UNGCPRO; 744 UNGCPRO;
752 745
753 return val; 746 return Qnil;
754 } 747 }
755 748
756 DEFUN ("progn", Fprogn, 0, UNEVALLED, 0, /* 749 DEFUN ("progn", Fprogn, 0, UNEVALLED, 0, /*
757 (progn BODY...): eval BODY forms sequentially and return value of last one. 750 \(progn BODY...): eval BODY forms sequentially and return value of last one.
758 */ 751 */
759 (args)) 752 (args))
760 { 753 {
761 /* This function can GC */ 754 /* This function can GC */
762 Lisp_Object val = Qnil; 755 REGISTER Lisp_Object tail, val = Qnil;
763 struct gcpro gcpro1; 756 struct gcpro gcpro1;
764 757
765 GCPRO1 (args); 758 GCPRO1 (args);
766 759
767 while (!NILP (args)) 760 LIST_LOOP (tail, args)
768 { 761 val = Feval (XCAR (tail));
769 val = Feval (XCAR (args));
770 args = XCDR (args);
771 }
772 762
773 UNGCPRO; 763 UNGCPRO;
774 return val; 764 return val;
775 } 765 }
776 766
777 DEFUN ("prog1", Fprog1, 1, UNEVALLED, 0, /* 767 DEFUN ("prog1", Fprog1, 1, UNEVALLED, 0, /*
778 (prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST. 768 \(prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST.
779 The value of FIRST is saved during the evaluation of the remaining args, 769 The value of FIRST is saved during the evaluation of the remaining args,
780 whose values are discarded. 770 whose values are discarded.
781 */ 771 */
782 (args)) 772 (args))
783 { 773 {
784 /* This function can GC */ 774 /* This function can GC */
775 REGISTER Lisp_Object tail = args;
785 Lisp_Object val = Qnil; 776 Lisp_Object val = Qnil;
786 struct gcpro gcpro1, gcpro2; 777 struct gcpro gcpro1, gcpro2;
787 778
788 GCPRO2 (args, val); 779 GCPRO2 (args, val);
789 780
790 val = Feval (XCAR (args)); 781 val = Feval (XCAR (tail));
791 args = XCDR (args); 782
792 783 LIST_LOOP (tail, XCDR (tail))
793 while (!NILP (args)) 784 Feval (XCAR (tail));
794 {
795 Feval (XCAR (args));
796 args = XCDR (args);
797 }
798 785
799 UNGCPRO; 786 UNGCPRO;
800 return val; 787 return val;
801 } 788 }
802 789
803 DEFUN ("prog2", Fprog2, 2, UNEVALLED, 0, /* 790 DEFUN ("prog2", Fprog2, 2, UNEVALLED, 0, /*
804 (prog2 X Y BODY...): eval X, Y and BODY sequentially; value from Y. 791 \(prog2 X Y BODY...): eval X, Y and BODY sequentially; value from Y.
805 The value of Y is saved during the evaluation of the remaining args, 792 The value of Y is saved during the evaluation of the remaining args,
806 whose values are discarded. 793 whose values are discarded.
807 */ 794 */
808 (args)) 795 (args))
809 { 796 {
810 /* This function can GC */ 797 /* This function can GC */
798 REGISTER Lisp_Object tail = args;
811 Lisp_Object val = Qnil; 799 Lisp_Object val = Qnil;
812 struct gcpro gcpro1, gcpro2; 800 struct gcpro gcpro1, gcpro2;
813 801
814 GCPRO2 (args, val); 802 GCPRO2 (args, val);
815 803
816 Feval (XCAR (args)); 804 Feval (XCAR (tail));
817 args = XCDR (args); 805 tail = XCDR (tail);
818 val = Feval (XCAR (args)); 806 val = Feval (XCAR (tail));
819 args = XCDR (args); 807
820 808 LIST_LOOP (tail, XCDR (tail))
821 while (!NILP (args)) 809 Feval (XCAR (tail));
822 {
823 Feval (XCAR (args));
824 args = XCDR (args);
825 }
826 810
827 UNGCPRO; 811 UNGCPRO;
828 return val; 812 return val;
829 } 813 }
830 814
831 DEFUN ("let*", FletX, 1, UNEVALLED, 0, /* 815 DEFUN ("let*", FletX, 1, UNEVALLED, 0, /*
832 (let* VARLIST BODY...): bind variables according to VARLIST then eval BODY. 816 \(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.
833 The value of the last form in BODY is returned. 817 The value of the last form in BODY is returned.
834 Each element of VARLIST is a symbol (which is bound to nil) 818 Each element of VARLIST is a symbol (which is bound to nil)
835 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM). 819 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
836 Each VALUEFORM can refer to the symbols already bound by this VARLIST. 820 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
837 */ 821 */
838 (args)) 822 (args))
839 { 823 {
840 /* This function can GC */ 824 /* This function can GC */
841 Lisp_Object varlist, val, elt; 825 Lisp_Object varlist = XCAR (args);
826 Lisp_Object tail;
842 int speccount = specpdl_depth_counter; 827 int speccount = specpdl_depth_counter;
843 struct gcpro gcpro1, gcpro2, gcpro3; 828 struct gcpro gcpro1;
844 829
845 GCPRO3 (args, elt, varlist); 830 GCPRO1 (args);
846 831
847 varlist = Fcar (args); 832 EXTERNAL_LIST_LOOP (tail, varlist)
848 while (!NILP (varlist)) 833 {
849 { 834 Lisp_Object elt = XCAR (tail);
850 QUIT; 835 QUIT;
851 elt = Fcar (varlist);
852 if (SYMBOLP (elt)) 836 if (SYMBOLP (elt))
853 specbind (elt, Qnil); 837 specbind (elt, Qnil);
854 else if (! NILP (Fcdr (Fcdr (elt))))
855 signal_simple_error ("`let' bindings can have only one value-form",
856 elt);
857 else 838 else
858 { 839 {
859 val = Feval (Fcar (Fcdr (elt))); 840 Lisp_Object sym, form;
860 specbind (Fcar (elt), val); 841 CHECK_CONS (elt);
842 sym = XCAR (elt);
843 elt = XCDR (elt);
844 if (NILP (elt))
845 form = Qnil;
846 else
847 {
848 CHECK_CONS (elt);
849 form = XCAR (elt);
850 elt = XCDR (elt);
851 if (!NILP (elt))
852 signal_simple_error
853 ("`let' bindings can have only one value-form",
854 XCAR (tail));
855 }
856 specbind (sym, Feval (form));
861 } 857 }
862 varlist = Fcdr (varlist);
863 } 858 }
864 UNGCPRO; 859 UNGCPRO;
865 val = Fprogn (Fcdr (args)); 860 return unbind_to (speccount, Fprogn (XCDR (args)));
866 return unbind_to (speccount, val);
867 } 861 }
868 862
869 DEFUN ("let", Flet, 1, UNEVALLED, 0, /* 863 DEFUN ("let", Flet, 1, UNEVALLED, 0, /*
870 (let VARLIST BODY...): bind variables according to VARLIST then eval BODY. 864 \(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.
871 The value of the last form in BODY is returned. 865 The value of the last form in BODY is returned.
872 Each element of VARLIST is a symbol (which is bound to nil) 866 Each element of VARLIST is a symbol (which is bound to nil)
873 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM). 867 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
874 All the VALUEFORMs are evalled before any symbols are bound. 868 All the VALUEFORMs are evalled before any symbols are bound.
875 */ 869 */
876 (args)) 870 (args))
877 { 871 {
878 /* This function can GC */ 872 /* This function can GC */
879 Lisp_Object *temps, tem; 873 Lisp_Object varlist = XCAR (args);
880 REGISTER Lisp_Object elt, varlist; 874 REGISTER Lisp_Object tail;
875 Lisp_Object *temps;
881 int speccount = specpdl_depth_counter; 876 int speccount = specpdl_depth_counter;
882 REGISTER int argnum; 877 REGISTER int argnum = 0;
883 struct gcpro gcpro1, gcpro2; 878 struct gcpro gcpro1, gcpro2;
884 879
885 varlist = Fcar (args); 880 /* Make space to hold the values to give the bound variables. */
886 881 {
887 /* Make space to hold the values to give the bound variables */ 882 int varcount = 0;
888 elt = Flength (varlist); 883 EXTERNAL_LIST_LOOP (tail, varlist)
889 temps = alloca_array (Lisp_Object, XINT (elt)); 884 varcount++;
885 temps = alloca_array (Lisp_Object, varcount);
886 }
890 887
891 /* Compute the values and store them in `temps' */ 888 /* Compute the values and store them in `temps' */
892 889
893 GCPRO2 (args, *temps); 890 GCPRO2 (args, *temps);
894 gcpro2.nvars = 0; 891 gcpro2.nvars = 0;
895 892
896 for (argnum = 0; !NILP (varlist); varlist = Fcdr (varlist)) 893 LIST_LOOP (tail, varlist)
897 { 894 {
895 Lisp_Object elt = XCAR (tail);
898 QUIT; 896 QUIT;
899 elt = Fcar (varlist);
900 if (SYMBOLP (elt)) 897 if (SYMBOLP (elt))
901 temps [argnum++] = Qnil; 898 temps[argnum++] = Qnil;
902 else if (! NILP (Fcdr (Fcdr (elt))))
903 signal_simple_error ("`let' bindings can have only one value-form",
904 elt);
905 else 899 else
906 temps [argnum++] = Feval (Fcar (Fcdr (elt))); 900 {
907 gcpro2.nvars = argnum; 901 CHECK_CONS (elt);
902 elt = XCDR (elt);
903 if (NILP (elt))
904 temps[argnum++] = Qnil;
905 else
906 {
907 CHECK_CONS (elt);
908 temps[argnum++] = Feval (XCAR (elt));
909 gcpro2.nvars = argnum;
910
911 if (!NILP (XCDR (elt)))
912 signal_simple_error
913 ("`let' bindings can have only one value-form",
914 XCAR (tail));
915 }
916 }
908 } 917 }
909 UNGCPRO; 918 UNGCPRO;
910 919
911 varlist = Fcar (args); 920 argnum = 0;
912 for (argnum = 0; !NILP (varlist); varlist = Fcdr (varlist)) 921 LIST_LOOP (tail, varlist)
913 { 922 {
914 elt = Fcar (varlist); 923 Lisp_Object elt = XCAR (tail);
915 tem = temps[argnum++]; 924 specbind (SYMBOLP (elt) ? elt : XCAR (elt), temps[argnum++]);
916 if (SYMBOLP (elt)) 925 }
917 specbind (elt, tem); 926
918 else 927 return unbind_to (speccount, Fprogn (XCDR (args)));
919 specbind (Fcar (elt), tem);
920 }
921
922 elt = Fprogn (Fcdr (args));
923 return unbind_to (speccount, elt);
924 } 928 }
925 929
926 DEFUN ("while", Fwhile, 1, UNEVALLED, 0, /* 930 DEFUN ("while", Fwhile, 1, UNEVALLED, 0, /*
927 (while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat. 931 \(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.
928 The order of execution is thus TEST, BODY, TEST, BODY and so on 932 The order of execution is thus TEST, BODY, TEST, BODY and so on
929 until TEST returns nil. 933 until TEST returns nil.
930 */ 934 */
931 (args)) 935 (args))
932 { 936 {
933 /* This function can GC */ 937 /* This function can GC */
934 Lisp_Object test, body, tem; 938 Lisp_Object tem;
939 Lisp_Object test = XCAR (args);
940 Lisp_Object body = XCDR (args);
935 struct gcpro gcpro1, gcpro2; 941 struct gcpro gcpro1, gcpro2;
936 942
937 GCPRO2 (test, body); 943 GCPRO2 (test, body);
938 944
939 test = Fcar (args);
940 body = Fcdr (args);
941 while (tem = Feval (test), !NILP (tem)) 945 while (tem = Feval (test), !NILP (tem))
942 { 946 {
943 QUIT; 947 QUIT;
944 Fprogn (body); 948 Fprogn (body);
945 } 949 }
947 UNGCPRO; 951 UNGCPRO;
948 return Qnil; 952 return Qnil;
949 } 953 }
950 954
951 DEFUN ("setq", Fsetq, 0, UNEVALLED, 0, /* 955 DEFUN ("setq", Fsetq, 0, UNEVALLED, 0, /*
952 (setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL. 956 \(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.
953 The symbols SYM are variables; they are literal (not evaluated). 957 The symbols SYM are variables; they are literal (not evaluated).
954 The values VAL are expressions; they are evaluated. 958 The values VAL are expressions; they are evaluated.
955 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'. 959 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
956 The second VAL is not computed until after the first SYM is set, and so on; 960 The second VAL is not computed until after the first SYM is set, and so on;
957 each VAL can use the new value of variables set earlier in the `setq'. 961 each VAL can use the new value of variables set earlier in the `setq'.
958 The return value of the `setq' form is the value of the last VAL. 962 The return value of the `setq' form is the value of the last VAL.
959 */ 963 */
960 (args)) 964 (args))
961 { 965 {
962 /* This function can GC */ 966 /* This function can GC */
963 REGISTER Lisp_Object args_left;
964 REGISTER Lisp_Object val, sym;
965 struct gcpro gcpro1; 967 struct gcpro gcpro1;
966 968 Lisp_Object val = Qnil;
967 if (NILP (args)) 969
968 return Qnil; 970 GCPRO1 (args);
969 971
970 { 972 {
971 REGISTER int i; 973 REGISTER int i = 0;
972 for (i = 0, val = args ; CONSP (val); val = XCDR (val)) 974 Lisp_Object args2;
975 for (args2 = args; !NILP (args2); args2 = XCDR (args2))
973 { 976 {
974 i++; 977 i++;
975 /* 978 /*
976 * uncomment the QUIT if there is some way a circular 979 * uncomment the QUIT if there is some way a circular
977 * arglist can get in here. I think Feval or Fapply would 980 * arglist can get in here. I think Feval or Fapply would
981 } 984 }
982 if (i & 1) /* Odd number of arguments? */ 985 if (i & 1) /* Odd number of arguments? */
983 Fsignal (Qwrong_number_of_arguments, list2 (Qsetq, make_int(i))); 986 Fsignal (Qwrong_number_of_arguments, list2 (Qsetq, make_int(i)));
984 } 987 }
985 988
986 args_left = args; 989 while (!NILP (args))
987 GCPRO1 (args); 990 {
988 991 Lisp_Object sym = XCAR (args);
989 do 992 val = Feval (XCAR (XCDR (args)));
990 {
991 val = Feval (XCAR (XCDR (args_left)));
992 sym = XCAR (args_left);
993 Fset (sym, val); 993 Fset (sym, val);
994 args_left = XCDR (XCDR (args_left)); 994 args = XCDR (XCDR (args));
995 } 995 }
996 while (CONSP (args_left));
997 996
998 UNGCPRO; 997 UNGCPRO;
999 return val; 998 return val;
1000 } 999 }
1001 1000
1002 DEFUN ("quote", Fquote, 1, UNEVALLED, 0, /* 1001 DEFUN ("quote", Fquote, 1, UNEVALLED, 0, /*
1003 Return the argument, without evaluating it. `(quote x)' yields `x'. 1002 Return the argument, without evaluating it. `(quote x)' yields `x'.
1004 */ 1003 */
1005 (args)) 1004 (args))
1006 { 1005 {
1007 return Fcar (args); 1006 return XCAR (args);
1008 } 1007 }
1009 1008
1010 DEFUN ("function", Ffunction, 1, UNEVALLED, 0, /* 1009 DEFUN ("function", Ffunction, 1, UNEVALLED, 0, /*
1011 Like `quote', but preferred for objects which are functions. 1010 Like `quote', but preferred for objects which are functions.
1012 In byte compilation, `function' causes its argument to be compiled. 1011 In byte compilation, `function' causes its argument to be compiled.
1013 `quote' cannot do that. 1012 `quote' cannot do that.
1014 */ 1013 */
1015 (args)) 1014 (args))
1016 { 1015 {
1017 return Fcar (args); 1016 return XCAR (args);
1018 } 1017 }
1019 1018
1020 1019
1021 /**********************************************************************/ 1020 /**********************************************************************/
1022 /* Defining functions/variables */ 1021 /* Defining functions/variables */
1023 /**********************************************************************/ 1022 /**********************************************************************/
1024 1023
1025 DEFUN ("defun", Fdefun, 2, UNEVALLED, 0, /* 1024 DEFUN ("defun", Fdefun, 2, UNEVALLED, 0, /*
1026 (defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function. 1025 \(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.
1027 The definition is (lambda ARGLIST [DOCSTRING] BODY...). 1026 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
1028 See also the function `interactive'. 1027 See also the function `interactive'.
1029 */ 1028 */
1030 (args)) 1029 (args))
1031 { 1030 {
1032 /* This function can GC */ 1031 /* This function can GC */
1033 Lisp_Object fn_name; 1032 Lisp_Object fn_name = XCAR (args);
1034 Lisp_Object defn; 1033 Lisp_Object defn = Fcons (Qlambda, XCDR (args));
1035 1034
1036 fn_name = Fcar (args);
1037 defn = Fcons (Qlambda, Fcdr (args));
1038 if (purify_flag) 1035 if (purify_flag)
1039 defn = Fpurecopy (defn); 1036 defn = Fpurecopy (defn);
1040 Ffset (fn_name, defn); 1037 Ffset (fn_name, defn);
1041 LOADHIST_ATTACH (fn_name); 1038 LOADHIST_ATTACH (fn_name);
1042 return fn_name; 1039 return fn_name;
1043 } 1040 }
1044 1041
1045 DEFUN ("defmacro", Fdefmacro, 2, UNEVALLED, 0, /* 1042 DEFUN ("defmacro", Fdefmacro, 2, UNEVALLED, 0, /*
1046 (defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro. 1043 \(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.
1047 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...). 1044 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).
1048 When the macro is called, as in (NAME ARGS...), 1045 When the macro is called, as in (NAME ARGS...),
1049 the function (lambda ARGLIST BODY...) is applied to 1046 the function (lambda ARGLIST BODY...) is applied to
1050 the list ARGS... as it appears in the expression, 1047 the list ARGS... as it appears in the expression,
1051 and the result should be a form to be evaluated instead of the original. 1048 and the result should be a form to be evaluated instead of the original.
1052 */ 1049 */
1053 (args)) 1050 (args))
1054 { 1051 {
1055 /* This function can GC */ 1052 /* This function can GC */
1056 Lisp_Object fn_name; 1053 Lisp_Object fn_name = XCAR (args);
1057 Lisp_Object defn; 1054 Lisp_Object defn = Fcons (Qmacro, Fcons (Qlambda, XCDR (args)));
1058 1055
1059 fn_name = Fcar (args);
1060 defn = Fcons (Qmacro, Fcons (Qlambda, Fcdr (args)));
1061 if (purify_flag) 1056 if (purify_flag)
1062 defn = Fpurecopy (defn); 1057 defn = Fpurecopy (defn);
1063 Ffset (fn_name, defn); 1058 Ffset (fn_name, defn);
1064 LOADHIST_ATTACH (fn_name); 1059 LOADHIST_ATTACH (fn_name);
1065 return fn_name; 1060 return fn_name;
1066 } 1061 }
1067 1062
1068 DEFUN ("defvar", Fdefvar, 1, UNEVALLED, 0, /* 1063 DEFUN ("defvar", Fdefvar, 1, UNEVALLED, 0, /*
1069 (defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable. 1064 \(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.
1070 You are not required to define a variable in order to use it, 1065 You are not required to define a variable in order to use it,
1071 but the definition can supply documentation and an initial value 1066 but the definition can supply documentation and an initial value
1072 in a way that tags can recognize. 1067 in a way that tags can recognize.
1073 1068
1074 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is 1069 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is
1085 In lisp-interaction-mode defvar is treated as defconst. 1080 In lisp-interaction-mode defvar is treated as defconst.
1086 */ 1081 */
1087 (args)) 1082 (args))
1088 { 1083 {
1089 /* This function can GC */ 1084 /* This function can GC */
1090 REGISTER Lisp_Object sym, tem, tail; 1085 Lisp_Object sym = XCAR (args);
1091 1086
1092 sym = Fcar (args); 1087 if (!NILP (args = XCDR (args)))
1093 tail = Fcdr (args); 1088 {
1094 if (!NILP (Fcdr (Fcdr (tail)))) 1089 Lisp_Object val = XCAR (args);
1095 error ("too many arguments"); 1090
1096 1091 if (NILP (Fdefault_boundp (sym)))
1097 if (!NILP (tail)) 1092 Fset_default (sym, Feval (val));
1098 { 1093
1099 tem = Fdefault_boundp (sym); 1094 if (!NILP (args = XCDR (args)))
1100 if (NILP (tem)) 1095 {
1101 Fset_default (sym, Feval (Fcar (Fcdr (args)))); 1096 Lisp_Object doc = XCAR (args);
1097 #if 0 /* FSFmacs */
1098 /* #### We should probably do this but it might be dangerous */
1099 if (purify_flag)
1100 doc = Fpurecopy (doc);
1101 Fput (sym, Qvariable_documentation, doc);
1102 #else
1103 pure_put (sym, Qvariable_documentation, doc);
1104 #endif
1105 if (!NILP (args = XCDR (args)))
1106 error ("too many arguments");
1107 }
1102 } 1108 }
1103 1109
1104 #ifdef I18N3 1110 #ifdef I18N3
1105 if (!NILP (Vfile_domain)) 1111 if (!NILP (Vfile_domain))
1106 pure_put (sym, Qvariable_domain, Vfile_domain); 1112 pure_put (sym, Qvariable_domain, Vfile_domain);
1107 #endif 1113 #endif
1108 1114
1109 tail = Fcdr (Fcdr (args));
1110 if (!NILP (Fcar (tail)))
1111 {
1112 tem = Fcar (tail);
1113 #if 0 /* FSFmacs */
1114 /* #### We should probably do this but it might be dangerous */
1115 if (purify_flag)
1116 tem = Fpurecopy (tem);
1117 Fput (sym, Qvariable_documentation, tem);
1118 #else
1119 pure_put (sym, Qvariable_documentation, tem);
1120 #endif
1121 }
1122
1123 LOADHIST_ATTACH (sym); 1115 LOADHIST_ATTACH (sym);
1124 return sym; 1116 return sym;
1125 } 1117 }
1126 1118
1127 DEFUN ("defconst", Fdefconst, 2, UNEVALLED, 0, /* 1119 DEFUN ("defconst", Fdefconst, 2, UNEVALLED, 0, /*
1128 (defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant 1120 \(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant
1129 variable. 1121 variable.
1130 The intent is that programs do not change this value, but users may. 1122 The intent is that programs do not change this value, but users may.
1131 Always sets the value of SYMBOL to the result of evalling INITVALUE. 1123 Always sets the value of SYMBOL to the result of evalling INITVALUE.
1132 If SYMBOL is buffer-local, its default value is what is set; 1124 If SYMBOL is buffer-local, its default value is what is set;
1133 buffer-local values are not affected. 1125 buffer-local values are not affected.
1142 it would override the user's choice. 1134 it would override the user's choice.
1143 */ 1135 */
1144 (args)) 1136 (args))
1145 { 1137 {
1146 /* This function can GC */ 1138 /* This function can GC */
1147 REGISTER Lisp_Object sym, tem; 1139 Lisp_Object sym = XCAR (args);
1148 1140 Lisp_Object val = XCAR (args = XCDR (args));
1149 sym = Fcar (args); 1141
1150 if (!NILP (Fcdr (Fcdr (Fcdr (args))))) 1142 Fset_default (sym, Feval (val));
1151 error ("too many arguments"); 1143
1152 1144 if (!NILP (args = XCDR (args)))
1153 Fset_default (sym, Feval (Fcar (Fcdr (args)))); 1145 {
1146 Lisp_Object doc = XCAR (args);
1147 #if 0 /* FSFmacs */
1148 /* #### We should probably do this but it might be dangerous */
1149 if (purify_flag)
1150 doc = Fpurecopy (doc);
1151 Fput (sym, Qvariable_documentation, doc);
1152 #else
1153 pure_put (sym, Qvariable_documentation, doc);
1154 #endif
1155 if (!NILP (args = XCDR (args)))
1156 error ("too many arguments");
1157 }
1154 1158
1155 #ifdef I18N3 1159 #ifdef I18N3
1156 if (!NILP (Vfile_domain)) 1160 if (!NILP (Vfile_domain))
1157 pure_put (sym, Qvariable_domain, Vfile_domain); 1161 pure_put (sym, Qvariable_domain, Vfile_domain);
1158 #endif
1159
1160 tem = Fcar (Fcdr (Fcdr (args)));
1161
1162 if (!NILP (tem))
1163 #if 0 /* FSFmacs */
1164 /* #### We should probably do this but it might be dangerous */
1165 {
1166 if (purify_flag)
1167 tem = Fpurecopy (tem);
1168 Fput (sym, Qvariable_documentation, tem);
1169 }
1170 #else
1171 pure_put (sym, Qvariable_documentation, tem);
1172 #endif 1162 #endif
1173 1163
1174 LOADHIST_ATTACH (sym); 1164 LOADHIST_ATTACH (sym);
1175 return sym; 1165 return sym;
1176 } 1166 }
1281 /**********************************************************************/ 1271 /**********************************************************************/
1282 /* Non-local exits */ 1272 /* Non-local exits */
1283 /**********************************************************************/ 1273 /**********************************************************************/
1284 1274
1285 DEFUN ("catch", Fcatch, 1, UNEVALLED, 0, /* 1275 DEFUN ("catch", Fcatch, 1, UNEVALLED, 0, /*
1286 (catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'. 1276 \(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.
1287 TAG is evalled to get the tag to use. Then the BODY is executed. 1277 TAG is evalled to get the tag to use. Then the BODY is executed.
1288 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'. 1278 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.
1289 If no throw happens, `catch' returns the value of the last BODY form. 1279 If no throw happens, `catch' returns the value of the last BODY form.
1290 If a throw happens, it specifies the value to return from `catch'. 1280 If a throw happens, it specifies the value to return from `catch'.
1291 */ 1281 */
1294 /* This function can GC */ 1284 /* This function can GC */
1295 Lisp_Object tag; 1285 Lisp_Object tag;
1296 struct gcpro gcpro1; 1286 struct gcpro gcpro1;
1297 1287
1298 GCPRO1 (args); 1288 GCPRO1 (args);
1299 tag = Feval (Fcar (args)); 1289 tag = Feval (XCAR (args));
1300 UNGCPRO; 1290 UNGCPRO;
1301 return internal_catch (tag, Fprogn, Fcdr (args), 0); 1291 return internal_catch (tag, Fprogn, XCDR (args), 0);
1302 } 1292 }
1303 1293
1304 /* Set up a catch, then call C function FUNC on argument ARG. 1294 /* Set up a catch, then call C function FUNC on argument ARG.
1305 FUNC should return a Lisp_Object. 1295 FUNC should return a Lisp_Object.
1306 This is how catches are done from within C code. */ 1296 This is how catches are done from within C code. */
1307 1297
1308 Lisp_Object 1298 Lisp_Object
1309 internal_catch (Lisp_Object tag, 1299 internal_catch (Lisp_Object tag,
1310 Lisp_Object (*func) (Lisp_Object arg), 1300 Lisp_Object (*func) (Lisp_Object arg),
1311 Lisp_Object arg, 1301 Lisp_Object arg,
1312 int *threw) 1302 int * volatile threw)
1313 { 1303 {
1314 /* This structure is made part of the chain `catchlist'. */ 1304 /* This structure is made part of the chain `catchlist'. */
1315 struct catchtag c; 1305 struct catchtag c;
1316 1306
1317 /* Fill in the components of c, and put it on the list. */ 1307 /* Fill in the components of c, and put it on the list. */
1482 back to the place that established the catch (in this case, 1472 back to the place that established the catch (in this case,
1483 condition_case_1). See below for more info. 1473 condition_case_1). See below for more info.
1484 */ 1474 */
1485 1475
1486 DEFUN ("throw", Fthrow, 2, 2, 0, /* 1476 DEFUN ("throw", Fthrow, 2, 2, 0, /*
1487 (throw TAG VALUE): throw to the catch for TAG and return VALUE from it. 1477 \(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.
1488 Both TAG and VALUE are evalled. 1478 Both TAG and VALUE are evalled.
1489 */ 1479 */
1490 (tag, val)) 1480 (tag, val))
1491 { 1481 {
1492 throw_or_bomb_out (tag, val, 0, Qnil, Qnil); /* Doesn't return */ 1482 throw_or_bomb_out (tag, val, 0, Qnil, Qnil); /* Doesn't return */
1504 { 1494 {
1505 /* This function can GC */ 1495 /* This function can GC */
1506 Lisp_Object val; 1496 Lisp_Object val;
1507 int speccount = specpdl_depth_counter; 1497 int speccount = specpdl_depth_counter;
1508 1498
1509 record_unwind_protect (Fprogn, Fcdr (args)); 1499 record_unwind_protect (Fprogn, XCDR (args));
1510 val = Feval (Fcar (args)); 1500 val = Feval (XCAR (args));
1511 return unbind_to (speccount, val); 1501 return unbind_to (speccount, val);
1512 } 1502 }
1513 1503
1514 1504
1515 /**********************************************************************/ 1505 /**********************************************************************/
1706 1696
1707 /* Here for bytecode to call non-consfully. This is exactly like 1697 /* Here for bytecode to call non-consfully. This is exactly like
1708 condition-case except that it takes three arguments rather 1698 condition-case except that it takes three arguments rather
1709 than a single list of arguments. */ 1699 than a single list of arguments. */
1710 Lisp_Object 1700 Lisp_Object
1711 Fcondition_case_3 (Lisp_Object bodyform, 1701 condition_case_3 (Lisp_Object bodyform, Lisp_Object var, Lisp_Object handlers)
1712 Lisp_Object var, Lisp_Object handlers)
1713 { 1702 {
1714 /* This function can GC */ 1703 /* This function can GC */
1715 Lisp_Object val; 1704 Lisp_Object val;
1716 1705
1717 CHECK_SYMBOL (var); 1706 CHECK_SYMBOL (var);
1741 1730
1742 A handler is applicable to an error if CONDITION-NAME is one of the 1731 A handler is applicable to an error if CONDITION-NAME is one of the
1743 error's condition names. If an error happens, the first applicable 1732 error's condition names. If an error happens, the first applicable
1744 handler is run. As a special case, a CONDITION-NAME of t matches 1733 handler is run. As a special case, a CONDITION-NAME of t matches
1745 all errors, even those without the `error' condition name on them 1734 all errors, even those without the `error' condition name on them
1746 (e.g. `quit'). 1735 \(e.g. `quit').
1747 1736
1748 The car of a handler may be a list of condition names 1737 The car of a handler may be a list of condition names
1749 instead of a single condition name. 1738 instead of a single condition name.
1750 1739
1751 When a handler handles an error, 1740 When a handler handles an error,
1767 rather than when the handler was set, use `call-with-condition-handler'. 1756 rather than when the handler was set, use `call-with-condition-handler'.
1768 */ 1757 */
1769 (args)) 1758 (args))
1770 { 1759 {
1771 /* This function can GC */ 1760 /* This function can GC */
1772 return Fcondition_case_3 (Fcar (Fcdr (args)), 1761 return condition_case_3 (XCAR (XCDR (args)),
1773 Fcar (args), 1762 XCAR (args),
1774 Fcdr (Fcdr (args))); 1763 XCDR (XCDR (args)));
1775 } 1764 }
1776 1765
1777 DEFUN ("call-with-condition-handler", Fcall_with_condition_handler, 2, MANY, 0, /* 1766 DEFUN ("call-with-condition-handler", Fcall_with_condition_handler, 2, MANY, 0, /*
1778 Regain control when an error is signalled, without popping the stack. 1767 Regain control when an error is signalled, without popping the stack.
1779 Usage looks like (call-with-condition-handler HANDLER FUNCTION &rest ARGS). 1768 Usage looks like (call-with-condition-handler HANDLER FUNCTION &rest ARGS).
1781 with the same environment (Lisp stack, bindings, catches, condition-cases) 1770 with the same environment (Lisp stack, bindings, catches, condition-cases)
1782 that was current when `signal' was called, rather than when the handler 1771 that was current when `signal' was called, rather than when the handler
1783 was established. 1772 was established.
1784 1773
1785 HANDLER should be a function of one argument, which is a cons of the args 1774 HANDLER should be a function of one argument, which is a cons of the args
1786 (SIG . DATA) that were passed to `signal'. It is invoked whenever 1775 \(SIG . DATA) that were passed to `signal'. It is invoked whenever
1787 `signal' is called (this differs from `condition-case', which allows 1776 `signal' is called (this differs from `condition-case', which allows
1788 you to specify which errors are trapped). If the handler function 1777 you to specify which errors are trapped). If the handler function
1789 returns, `signal' continues as if the handler were never invoked. 1778 returns, `signal' continues as if the handler were never invoked.
1790 (It continues to look for handlers established earlier than this one, 1779 \(It continues to look for handlers established earlier than this one,
1791 and invokes the standard error-handler if none is found.) 1780 and invokes the standard error-handler if none is found.)
1792 */ 1781 */
1793 (int nargs, Lisp_Object *args)) /* Note! Args side-effected! */ 1782 (int nargs, Lisp_Object *args)) /* Note! Args side-effected! */
1794 { 1783 {
1795 /* This function can GC */ 1784 /* This function can GC */
1796 int speccount = specpdl_depth_counter; 1785 int speccount = specpdl_depth_counter;
1797 Lisp_Object tem; 1786 Lisp_Object tem;
1798 1787
1852 error ("Returning a value from an error is no longer supported"); 1841 error ("Returning a value from an error is no longer supported");
1853 #endif 1842 #endif
1854 } 1843 }
1855 1844
1856 extern int in_display; 1845 extern int in_display;
1857 extern int gc_in_progress;
1858 1846
1859 1847
1860 /****************** the workhorse error-signaling function ******************/ 1848 /****************** the workhorse error-signaling function ******************/
1861 1849
1862 /* #### This function has not been synched with FSF. It diverges 1850 /* #### This function has not been synched with FSF. It diverges
2149 enabled error-checking. */ 2137 enabled error-checking. */
2150 2138
2151 if (ERRB_EQ (errb, ERROR_ME)) 2139 if (ERRB_EQ (errb, ERROR_ME))
2152 return primitive_funcall (fun, nargs, args); 2140 return primitive_funcall (fun, nargs, args);
2153 2141
2154 speccount = specpdl_depth (); 2142 speccount = specpdl_depth_counter;
2155 if (NILP (class) || NILP (Vcurrent_warning_class)) 2143 if (NILP (class) || NILP (Vcurrent_warning_class))
2156 { 2144 {
2157 /* If we're currently calling for no warnings, then make it so. 2145 /* If we're currently calling for no warnings, then make it so.
2158 If we're currently calling for warnings and we weren't 2146 If we're currently calling for warnings and we weren't
2159 previously, then set our warning class; otherwise, leave 2147 previously, then set our warning class; otherwise, leave
2185 free_opaque_ptr (opaque1); 2173 free_opaque_ptr (opaque1);
2186 free_opaque_ptr (opaque2); 2174 free_opaque_ptr (opaque2);
2187 UNGCPRO; 2175 UNGCPRO;
2188 /* Use the returned value except in non-local exit, when 2176 /* Use the returned value except in non-local exit, when
2189 RETVAL applies. */ 2177 RETVAL applies. */
2190 if (!threw) 2178 /* Some perverse compilers require the perverse cast below. */
2191 retval = the_retval; 2179 return unbind_to (speccount,
2192 return unbind_to (speccount, retval); 2180 threw ? *((Lisp_Object*) &(retval)) : the_retval);
2193 } 2181 }
2194 } 2182 }
2195 2183
2196 /* Signal a non-continuable error or display a warning or do nothing, 2184 /* Signal a non-continuable error or display a warning or do nothing,
2197 according to ERRB. CLASS is the class of warning and should 2185 according to ERRB. CLASS is the class of warning and should
2497 /**********************************************************************/ 2485 /**********************************************************************/
2498 /* User commands */ 2486 /* User commands */
2499 /**********************************************************************/ 2487 /**********************************************************************/
2500 2488
2501 DEFUN ("commandp", Fcommandp, 1, 1, 0, /* 2489 DEFUN ("commandp", Fcommandp, 1, 1, 0, /*
2502 T if FUNCTION makes provisions for interactive calling. 2490 Return t if FUNCTION makes provisions for interactive calling.
2503 This means it contains a description for how to read arguments to give it. 2491 This means it contains a description for how to read arguments to give it.
2504 The value is nil for an invalid function or a symbol with no function 2492 The value is nil for an invalid function or a symbol with no function
2505 definition. 2493 definition.
2506 2494
2507 Interactively callable functions include 2495 Interactively callable functions include
2516 2504
2517 Also, a symbol satisfies `commandp' if its function definition does so. 2505 Also, a symbol satisfies `commandp' if its function definition does so.
2518 */ 2506 */
2519 (function)) 2507 (function))
2520 { 2508 {
2521 REGISTER Lisp_Object fun; 2509 Lisp_Object fun = indirect_function (function, 0);
2522 REGISTER Lisp_Object funcar; 2510
2523
2524 fun = function;
2525
2526 fun = indirect_function (fun, 0);
2527 if (UNBOUNDP (fun)) 2511 if (UNBOUNDP (fun))
2528 return Qnil; 2512 return Qnil;
2529 2513
2530 /* Emacs primitives are interactive if their DEFUN specifies an 2514 /* Emacs primitives are interactive if their DEFUN specifies an
2531 interactive spec. */ 2515 interactive spec. */
2540 return Qt; 2524 return Qt;
2541 2525
2542 /* Lists may represent commands. */ 2526 /* Lists may represent commands. */
2543 if (!CONSP (fun)) 2527 if (!CONSP (fun))
2544 return Qnil; 2528 return Qnil;
2545 funcar = Fcar (fun); 2529 {
2546 if (!SYMBOLP (funcar)) 2530 Lisp_Object funcar = XCAR (fun);
2547 return Fsignal (Qinvalid_function, list1 (fun)); 2531 if (!SYMBOLP (funcar))
2548 if (EQ (funcar, Qlambda)) 2532 return Fsignal (Qinvalid_function, list1 (fun));
2549 return Fassq (Qinteractive, Fcdr (Fcdr (fun))); 2533 if (EQ (funcar, Qlambda))
2550 if (EQ (funcar, Qautoload)) 2534 return Fassq (Qinteractive, Fcdr (Fcdr (fun)));
2551 return Fcar (Fcdr (Fcdr (Fcdr (fun)))); 2535 if (EQ (funcar, Qautoload))
2552 else 2536 return Fcar (Fcdr (Fcdr (Fcdr (fun))));
2553 return Qnil; 2537 else
2538 return Qnil;
2539 }
2554 } 2540 }
2555 2541
2556 DEFUN ("command-execute", Fcommand_execute, 1, 3, 0, /* 2542 DEFUN ("command-execute", Fcommand_execute, 1, 3, 0, /*
2557 Execute CMD as an editor command. 2543 Execute CMD as an editor command.
2558 CMD must be an object that satisfies the `commandp' predicate. 2544 CMD must be an object that satisfies the `commandp' predicate.
2592 #endif 2578 #endif
2593 backtrace.function = &Qcall_interactively; 2579 backtrace.function = &Qcall_interactively;
2594 backtrace.args = &cmd; 2580 backtrace.args = &cmd;
2595 backtrace.nargs = 1; 2581 backtrace.nargs = 1;
2596 backtrace.evalargs = 0; 2582 backtrace.evalargs = 0;
2597 backtrace.pdlcount = specpdl_depth (); 2583 backtrace.pdlcount = specpdl_depth_counter;
2598 backtrace.debug_on_exit = 0; 2584 backtrace.debug_on_exit = 0;
2599 PUSH_BACKTRACE (backtrace); 2585 PUSH_BACKTRACE (backtrace);
2600 2586
2601 final = Fcall_interactively (cmd, record, keys); 2587 final = Fcall_interactively (cmd, record, keys);
2602 2588
2824 2810
2825 static Lisp_Object funcall_lambda (Lisp_Object fun, 2811 static Lisp_Object funcall_lambda (Lisp_Object fun,
2826 int nargs, Lisp_Object args[]); 2812 int nargs, Lisp_Object args[]);
2827 static Lisp_Object apply_lambda (Lisp_Object fun, 2813 static Lisp_Object apply_lambda (Lisp_Object fun,
2828 int nargs, Lisp_Object args); 2814 int nargs, Lisp_Object args);
2829 #if 0 /* #### Not called anymore */
2830 static Lisp_Object funcall_subr (struct Lisp_Subr *sub, Lisp_Object args[]);
2831 #endif
2832
2833 static int in_warnings; 2815 static int in_warnings;
2834 2816
2835 static Lisp_Object 2817 static Lisp_Object
2836 in_warnings_restore (Lisp_Object minimus) 2818 in_warnings_restore (Lisp_Object minimus)
2837 { 2819 {
2838 in_warnings = 0; 2820 in_warnings = 0;
2839 return Qnil; 2821 return Qnil;
2840 } 2822 }
2841 2823
2842 #define inline_funcall_subr(rv, subr, av) \ 2824 #define AV_0(av)
2843 do { \ 2825 #define AV_1(av) av[0]
2844 switch (subr->max_args) { \ 2826 #define AV_2(av) AV_1(av), av[1]
2845 case 0: rv = (subr_function(subr))(); \ 2827 #define AV_3(av) AV_2(av), av[2]
2846 break; \ 2828 #define AV_4(av) AV_3(av), av[3]
2847 case 1: rv = (subr_function(subr))(av[0]); \ 2829 #define AV_5(av) AV_4(av), av[4]
2848 break; \ 2830 #define AV_6(av) AV_5(av), av[5]
2849 case 2: rv = (subr_function(subr))(av[0], av[1]); \ 2831 #define AV_7(av) AV_6(av), av[6]
2850 break; \ 2832 #define AV_8(av) AV_7(av), av[7]
2851 case 3: rv = (subr_function(subr))(av[0], av[1], av[2]); \ 2833
2852 break; \ 2834 #define PRIMITIVE_FUNCALL(fn, av, ac) \
2853 case 4: rv = (subr_function(subr))(av[0], av[1], av[2], av[3]); \ 2835 (((Lisp_Object (*)(EXFUN_##ac)) (fn)) (AV_##ac (av)))
2854 break; \ 2836
2855 case 5: rv = (subr_function(subr))(av[0], av[1], av[2], av[3], av[4]); \ 2837 /* If subr's take more than 8 arguments, more cases need to be added
2856 break; \ 2838 to this switch. (But don't do it - if you really need a SUBR with
2857 case 6: rv = (subr_function(subr))(av[0], av[1], av[2], av[3], av[4], \ 2839 more than 8 arguments, use max_args == MANY.
2858 av[5]); \ 2840 See the DEFUN macro in lisp.h) */
2859 break; \ 2841 #define inline_funcall_fn(rv, fn, av, ac) do { \
2860 case 7: rv = (subr_function(subr))(av[0], av[1], av[2], av[3], av[4], \ 2842 switch (ac) { \
2861 av[5], av[6]); \ 2843 case 0: rv = PRIMITIVE_FUNCALL(fn, av, 0); break; \
2862 break; \ 2844 case 1: rv = PRIMITIVE_FUNCALL(fn, av, 1); break; \
2863 case 8: rv = (subr_function(subr))(av[0], av[1], av[2], av[3], av[4], \ 2845 case 2: rv = PRIMITIVE_FUNCALL(fn, av, 2); break; \
2864 av[5], av[6], av[7]); \ 2846 case 3: rv = PRIMITIVE_FUNCALL(fn, av, 3); break; \
2865 break; \ 2847 case 4: rv = PRIMITIVE_FUNCALL(fn, av, 4); break; \
2866 case 9: rv = (subr_function(subr))(av[0], av[1], av[2], av[3], av[4], \ 2848 case 5: rv = PRIMITIVE_FUNCALL(fn, av, 5); break; \
2867 av[5], av[6], av[7], av[8]); \ 2849 case 6: rv = PRIMITIVE_FUNCALL(fn, av, 6); break; \
2868 break; \ 2850 case 7: rv = PRIMITIVE_FUNCALL(fn, av, 7); break; \
2869 case 10: rv = (subr_function(subr))(av[0], av[1], av[2], av[3], av[4], \ 2851 case 8: rv = PRIMITIVE_FUNCALL(fn, av, 8); break; \
2870 av[5], av[6], av[7], av[8], av[9]); \ 2852 default: abort(); rv = Qnil; break; \
2871 break; \ 2853 } \
2872 case 11: rv = (subr_function(subr))(av[0], av[1], av[2], av[3], av[4], \ 2854 } while (0)
2873 av[5], av[6], av[7], av[8], av[9], \ 2855
2874 av[10]); \ 2856 #define inline_funcall_subr(rv, subr, av) do { \
2875 break; \ 2857 void (*fn)() = (void (*)()) (subr_function(subr)); \
2876 case 12: rv = (subr_function(subr))(av[0], av[1], av[2], av[3], av[4], \ 2858 inline_funcall_fn (rv, fn, av, subr->max_args); \
2877 av[5], av[6], av[7], av[8], av[9], \ 2859 } while (0)
2878 av[10], av[11]); \ 2860
2879 break; \ 2861 static Lisp_Object
2880 } \ 2862 primitive_funcall (lisp_fn_t fn, int nargs, Lisp_Object args[])
2881 } while (0) 2863 {
2864 Lisp_Object rv;
2865 inline_funcall_fn (rv, fn, args, nargs);
2866 return rv;
2867 }
2882 2868
2883 DEFUN ("eval", Feval, 1, 1, 0, /* 2869 DEFUN ("eval", Feval, 1, 1, 0, /*
2884 Evaluate FORM and return its value. 2870 Evaluate FORM and return its value.
2885 */ 2871 */
2886 (form)) 2872 (form))
2892 2878
2893 /* I think this is a pretty safe place to call Lisp code, don't you? */ 2879 /* I think this is a pretty safe place to call Lisp code, don't you? */
2894 while (!in_warnings && !NILP (Vpending_warnings)) 2880 while (!in_warnings && !NILP (Vpending_warnings))
2895 { 2881 {
2896 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; 2882 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
2897 int speccount = specpdl_depth (); 2883 int speccount = specpdl_depth_counter;
2898 Lisp_Object this_warning_cons, this_warning, class, level, messij; 2884 Lisp_Object this_warning_cons, this_warning, class, level, messij;
2899 2885
2900 record_unwind_protect (in_warnings_restore, Qnil); 2886 record_unwind_protect (in_warnings_restore, Qnil);
2901 in_warnings = 1; 2887 in_warnings = 1;
2902 this_warning_cons = Vpending_warnings; 2888 this_warning_cons = Vpending_warnings;
2920 call3 (Qdisplay_warning, class, messij, level); 2906 call3 (Qdisplay_warning, class, messij, level);
2921 UNGCPRO; 2907 UNGCPRO;
2922 unbind_to (speccount, Qnil); 2908 unbind_to (speccount, Qnil);
2923 } 2909 }
2924 2910
2911 if (SYMBOLP (form))
2912 return Fsymbol_value (form);
2913
2925 if (!CONSP (form)) 2914 if (!CONSP (form))
2926 { 2915 return form;
2927 if (!SYMBOLP (form))
2928 return form;
2929
2930 val = Fsymbol_value (form);
2931
2932 return val;
2933 }
2934 2916
2935 QUIT; 2917 QUIT;
2936 if ((consing_since_gc > gc_cons_threshold) || always_gc) 2918 if ((consing_since_gc > gc_cons_threshold) || always_gc)
2937 { 2919 {
2938 struct gcpro gcpro1; 2920 struct gcpro gcpro1;
3013 } 2995 }
3014 2996
3015 if (max_args == UNEVALLED) 2997 if (max_args == UNEVALLED)
3016 { 2998 {
3017 backtrace.evalargs = 0; 2999 backtrace.evalargs = 0;
3018 val = ((subr_function (subr)) (args_left)); 3000 val = ((Lisp_Object (*) (Lisp_Object)) (subr_function (subr))) (args_left);
3019 } 3001 }
3020 3002
3021 else if (max_args == MANY) 3003 else if (max_args == MANY)
3022 { 3004 {
3023 /* Pass a vector of evaluated arguments */ 3005 /* Pass a vector of evaluated arguments */
3079 3061
3080 backtrace.args = argvals; 3062 backtrace.args = argvals;
3081 backtrace.nargs = nargs; 3063 backtrace.nargs = nargs;
3082 3064
3083 /* val = funcall_subr (subr, argvals); */ 3065 /* val = funcall_subr (subr, argvals); */
3084 inline_funcall_subr(val, subr, argvals); 3066 inline_funcall_subr (val, subr, argvals);
3085 } 3067 }
3086 } 3068 }
3087 else if (COMPILED_FUNCTIONP (fun)) 3069 else if (COMPILED_FUNCTIONP (fun))
3088 val = apply_lambda (fun, nargs, original_args); 3070 val = apply_lambda (fun, nargs, original_args);
3089 else 3071 else
3209 argvals[i] = args[i + 1]; 3191 argvals[i] = args[i + 1];
3210 for (i = nargs; i < max_args; i++) 3192 for (i = nargs; i < max_args; i++)
3211 argvals[i] = Qnil; 3193 argvals[i] = Qnil;
3212 3194
3213 /* val = funcall_subr (subr, argvals); */ 3195 /* val = funcall_subr (subr, argvals); */
3214 inline_funcall_subr(val, subr, argvals); 3196 inline_funcall_subr (val, subr, argvals);
3215 } 3197 }
3216 else 3198 else
3217 /* val = funcall_subr (subr, args + 1); */ 3199 /* val = funcall_subr (subr, args + 1); */
3218 inline_funcall_subr(val, subr, (&args[1])); 3200 inline_funcall_subr (val, subr, (&args[1]));
3219 } 3201 }
3220 else if (COMPILED_FUNCTIONP (fun)) 3202 else if (COMPILED_FUNCTIONP (fun))
3221 val = funcall_lambda (fun, nargs, args + 1); 3203 val = funcall_lambda (fun, nargs, args + 1);
3222 else if (!CONSP (fun)) 3204 else if (!CONSP (fun))
3223 { 3205 {
3283 return Fsignal (Qinvalid_function, list1 (function)); 3265 return Fsignal (Qinvalid_function, list1 (function));
3284 } 3266 }
3285 3267
3286 if (CONSP (function)) 3268 if (CONSP (function))
3287 { 3269 {
3288 Lisp_Object funcar = Fcar (function); 3270 Lisp_Object funcar = XCAR (function);
3289 3271
3290 if (!SYMBOLP (funcar)) 3272 if (!SYMBOLP (funcar))
3291 goto invalid_function; 3273 goto invalid_function;
3292 if (EQ (funcar, Qmacro)) 3274 if (EQ (funcar, Qmacro))
3293 { 3275 {
3294 function = Fcdr (function); 3276 function = XCDR (function);
3295 goto retry; 3277 goto retry;
3296 } 3278 }
3297 if (EQ (funcar, Qautoload)) 3279 if (EQ (funcar, Qautoload))
3298 { 3280 {
3299 do_autoload (function, orig_function); 3281 do_autoload (function, orig_function);
3300 goto retry; 3282 goto retry;
3301 } 3283 }
3302 if (EQ (funcar, Qlambda)) 3284 if (EQ (funcar, Qlambda))
3303 arglist = Fcar (Fcdr (function)); 3285 arglist = Fcar (XCDR (function));
3304 else 3286 else
3305 goto invalid_function; 3287 goto invalid_function;
3306 } 3288 }
3307 else 3289 else
3308 arglist = XCOMPILED_FUNCTION (function)->arglist; 3290 arglist = XCOMPILED_FUNCTION (function)->arglist;
3346 return Fsignal (Qinvalid_function, list1 (function)); 3328 return Fsignal (Qinvalid_function, list1 (function));
3347 } 3329 }
3348 3330
3349 if (CONSP (function)) 3331 if (CONSP (function))
3350 { 3332 {
3351 Lisp_Object funcar = Fcar (function); 3333 Lisp_Object funcar = XCAR (function);
3352 3334
3353 if (!SYMBOLP (funcar)) 3335 if (!SYMBOLP (funcar))
3354 goto invalid_function; 3336 goto invalid_function;
3355 if (EQ (funcar, Qmacro)) 3337 if (EQ (funcar, Qmacro))
3356 { 3338 {
3357 function = Fcdr (function); 3339 function = XCDR (function);
3358 goto retry; 3340 goto retry;
3359 } 3341 }
3360 if (EQ (funcar, Qautoload)) 3342 if (EQ (funcar, Qautoload))
3361 { 3343 {
3362 do_autoload (function, orig_function); 3344 do_autoload (function, orig_function);
3363 goto retry; 3345 goto retry;
3364 } 3346 }
3365 if (EQ (funcar, Qlambda)) 3347 if (EQ (funcar, Qlambda))
3366 arglist = Fcar (Fcdr (function)); 3348 arglist = Fcar (XCDR (function));
3367 else 3349 else
3368 goto invalid_function; 3350 goto invalid_function;
3369 } 3351 }
3370 else 3352 else
3371 arglist = XCOMPILED_FUNCTION (function)->arglist; 3353 arglist = XCOMPILED_FUNCTION (function)->arglist;
3484 RETURN_UNGCPRO (Ffuncall (funcall_nargs, funcall_args)); 3466 RETURN_UNGCPRO (Ffuncall (funcall_nargs, funcall_args));
3485 } 3467 }
3486 } 3468 }
3487 3469
3488 3470
3489 /* Define proper types and argument lists simultaneously */
3490 #define PRIMITIVE_FUNCALL(n) ((Lisp_Object (*) (PRIMITIVE_FUNCALL_##n)
3491 #define PRIMITIVE_FUNCALL_0 void)) (fn)) (
3492 #define PRIMITIVE_FUNCALL_1 Lisp_Object)) (fn)) (args[0]
3493 #define PRIMITIVE_FUNCALL_2 Lisp_Object, PRIMITIVE_FUNCALL_1, args[1]
3494 #define PRIMITIVE_FUNCALL_3 Lisp_Object, PRIMITIVE_FUNCALL_2, args[2]
3495 #define PRIMITIVE_FUNCALL_4 Lisp_Object, PRIMITIVE_FUNCALL_3, args[3]
3496 #define PRIMITIVE_FUNCALL_5 Lisp_Object, PRIMITIVE_FUNCALL_4, args[4]
3497 #define PRIMITIVE_FUNCALL_6 Lisp_Object, PRIMITIVE_FUNCALL_5, args[5]
3498 #define PRIMITIVE_FUNCALL_7 Lisp_Object, PRIMITIVE_FUNCALL_6, args[6]
3499 #define PRIMITIVE_FUNCALL_8 Lisp_Object, PRIMITIVE_FUNCALL_7, args[7]
3500 #define PRIMITIVE_FUNCALL_9 Lisp_Object, PRIMITIVE_FUNCALL_8, args[8]
3501 #define PRIMITIVE_FUNCALL_10 Lisp_Object, PRIMITIVE_FUNCALL_9, args[9]
3502 #define PRIMITIVE_FUNCALL_11 Lisp_Object, PRIMITIVE_FUNCALL_10, args[10]
3503 #define PRIMITIVE_FUNCALL_12 Lisp_Object, PRIMITIVE_FUNCALL_11, args[11]
3504
3505 static Lisp_Object
3506 primitive_funcall (lisp_fn_t fn, int nargs, Lisp_Object args[])
3507 {
3508 switch (nargs)
3509 {
3510 case 0: return PRIMITIVE_FUNCALL(0);
3511 case 1: return PRIMITIVE_FUNCALL(1);
3512 case 2: return PRIMITIVE_FUNCALL(2);
3513 case 3: return PRIMITIVE_FUNCALL(3);
3514 case 4: return PRIMITIVE_FUNCALL(4);
3515 case 5: return PRIMITIVE_FUNCALL(5);
3516 case 6: return PRIMITIVE_FUNCALL(6);
3517 case 7: return PRIMITIVE_FUNCALL(7);
3518 case 8: return PRIMITIVE_FUNCALL(8);
3519 case 9: return PRIMITIVE_FUNCALL(9);
3520 case 10: return PRIMITIVE_FUNCALL(10);
3521 case 11: return PRIMITIVE_FUNCALL(11);
3522 case 12: return PRIMITIVE_FUNCALL(12);
3523 }
3524
3525 /* Someone has created a subr that takes more arguments than is
3526 supported by this code. We need to either rewrite the subr to
3527 use a different argument protocol, or add more cases to this
3528 switch. */
3529 abort ();
3530 return Qnil; /* suppress compiler warning */
3531 }
3532
3533 #if 0 /* #### Not called anymore */
3534 static Lisp_Object
3535 funcall_subr (struct Lisp_Subr *subr, Lisp_Object args[])
3536 {
3537 return primitive_funcall (subr_function (subr), subr->max_args, args);
3538 }
3539 #endif
3540
3541 /* FSFmacs has an extra arg EVAL_FLAG. If false, some of 3471 /* FSFmacs has an extra arg EVAL_FLAG. If false, some of
3542 the statements below are not done. But it's always true 3472 the statements below are not done. But it's always true
3543 in all the calls to apply_lambda(). */ 3473 in all the calls to apply_lambda(). */
3544 3474
3545 static Lisp_Object 3475 static Lisp_Object
3577 if (backtrace_list->debug_on_exit) 3507 if (backtrace_list->debug_on_exit)
3578 tem = do_debug_on_exit (tem); 3508 tem = do_debug_on_exit (tem);
3579 /* Don't do it again when we return to eval. */ 3509 /* Don't do it again when we return to eval. */
3580 backtrace_list->debug_on_exit = 0; 3510 backtrace_list->debug_on_exit = 0;
3581 return tem; 3511 return tem;
3512 }
3513
3514 DEFUN ("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /*
3515 If byte-compiled OBJECT is lazy-loaded, fetch it now.
3516 */
3517 (object))
3518 {
3519 if (COMPILED_FUNCTIONP (object)
3520 && CONSP (XCOMPILED_FUNCTION (object)->bytecodes))
3521 {
3522 Lisp_Object tem =
3523 read_doc_string (XCOMPILED_FUNCTION (object)->bytecodes);
3524 if (!CONSP (tem))
3525 signal_simple_error ("invalid lazy-loaded byte code", tem);
3526 /* v18 or v19 bytecode file. Need to Ebolify. */
3527 if (XCOMPILED_FUNCTION (object)->flags.ebolified
3528 && VECTORP (XCDR (tem)))
3529 ebolify_bytecode_constants (XCDR (tem));
3530 /* VERY IMPORTANT to purecopy here!!!!!
3531 See load_force_doc_string_unwind. */
3532 XCOMPILED_FUNCTION (object)->bytecodes = Fpurecopy (XCAR (tem));
3533 XCOMPILED_FUNCTION (object)->constants = Fpurecopy (XCDR (tem));
3534 }
3535 return object;
3582 } 3536 }
3583 3537
3584 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR 3538 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
3585 and return the result of evaluation. 3539 and return the result of evaluation.
3586 FUN must be either a lambda-expression or a compiled-code object. */ 3540 FUN must be either a lambda-expression or a compiled-code object. */
3647 b->constants, 3601 b->constants,
3648 make_int (b->maxdepth)); 3602 make_int (b->maxdepth));
3649 } 3603 }
3650 return unbind_to (speccount, val); 3604 return unbind_to (speccount, val);
3651 } 3605 }
3652
3653 DEFUN ("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /*
3654 If byte-compiled OBJECT is lazy-loaded, fetch it now.
3655 */
3656 (object))
3657 {
3658 Lisp_Object tem;
3659
3660 if (COMPILED_FUNCTIONP (object)
3661 && CONSP (XCOMPILED_FUNCTION (object)->bytecodes))
3662 {
3663 tem = read_doc_string (XCOMPILED_FUNCTION (object)->bytecodes);
3664 if (!CONSP (tem))
3665 signal_simple_error ("invalid lazy-loaded byte code", tem);
3666 /* v18 or v19 bytecode file. Need to Ebolify. */
3667 if (XCOMPILED_FUNCTION (object)->flags.ebolified
3668 && VECTORP (XCDR (tem)))
3669 ebolify_bytecode_constants (XCDR (tem));
3670 /* VERY IMPORTANT to purecopy here!!!!!
3671 See load_force_doc_string_unwind. */
3672 XCOMPILED_FUNCTION (object)->bytecodes = Fpurecopy (XCAR (tem));
3673 XCOMPILED_FUNCTION (object)->constants = Fpurecopy (XCDR (tem));
3674 }
3675 return object;
3676 }
3677
3678 3606
3679 /**********************************************************************/ 3607 /**********************************************************************/
3680 /* Run hook variables in various ways. */ 3608 /* Run hook variables in various ways. */
3681 /**********************************************************************/ 3609 /**********************************************************************/
3682 3610
4125 } 4053 }
4126 4054
4127 Lisp_Object 4055 Lisp_Object
4128 call0_in_buffer (struct buffer *buf, Lisp_Object fn) 4056 call0_in_buffer (struct buffer *buf, Lisp_Object fn)
4129 { 4057 {
4130 int speccount = specpdl_depth (); 4058 if (current_buffer == buf)
4131 Lisp_Object val; 4059 return call0 (fn);
4132 4060 else
4133 if (current_buffer != buf) 4061 {
4134 { 4062 Lisp_Object val;
4063 int speccount = specpdl_depth_counter;
4135 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); 4064 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4136 set_buffer_internal (buf); 4065 set_buffer_internal (buf);
4137 } 4066 val = call0 (fn);
4138 val = call0 (fn); 4067 unbind_to (speccount, Qnil);
4139 unbind_to (speccount, Qnil); 4068 return val;
4140 return val; 4069 }
4141 } 4070 }
4142 4071
4143 Lisp_Object 4072 Lisp_Object
4144 call1_in_buffer (struct buffer *buf, Lisp_Object fn, 4073 call1_in_buffer (struct buffer *buf, Lisp_Object fn,
4145 Lisp_Object arg0) 4074 Lisp_Object arg0)
4146 { 4075 {
4147 int speccount = specpdl_depth (); 4076 if (current_buffer == buf)
4148 Lisp_Object val; 4077 return call1 (fn, arg0);
4149 4078 else
4150 if (current_buffer != buf) 4079 {
4151 { 4080 Lisp_Object val;
4081 int speccount = specpdl_depth_counter;
4152 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); 4082 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4153 set_buffer_internal (buf); 4083 set_buffer_internal (buf);
4154 } 4084 val = call1 (fn, arg0);
4155 val = call1 (fn, arg0); 4085 unbind_to (speccount, Qnil);
4156 unbind_to (speccount, Qnil); 4086 return val;
4157 return val; 4087 }
4158 } 4088 }
4159 4089
4160 Lisp_Object 4090 Lisp_Object
4161 call2_in_buffer (struct buffer *buf, Lisp_Object fn, 4091 call2_in_buffer (struct buffer *buf, Lisp_Object fn,
4162 Lisp_Object arg0, Lisp_Object arg1) 4092 Lisp_Object arg0, Lisp_Object arg1)
4163 { 4093 {
4164 int speccount = specpdl_depth (); 4094 if (current_buffer == buf)
4165 Lisp_Object val; 4095 return call2 (fn, arg0, arg1);
4166 4096 else
4167 if (current_buffer != buf) 4097 {
4168 { 4098 Lisp_Object val;
4099 int speccount = specpdl_depth_counter;
4169 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); 4100 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4170 set_buffer_internal (buf); 4101 set_buffer_internal (buf);
4171 } 4102 val = call2 (fn, arg0, arg1);
4172 val = call2 (fn, arg0, arg1); 4103 unbind_to (speccount, Qnil);
4173 unbind_to (speccount, Qnil); 4104 return val;
4174 return val; 4105 }
4175 } 4106 }
4176 4107
4177 Lisp_Object 4108 Lisp_Object
4178 call3_in_buffer (struct buffer *buf, Lisp_Object fn, 4109 call3_in_buffer (struct buffer *buf, Lisp_Object fn,
4179 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2) 4110 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2)
4180 { 4111 {
4181 int speccount = specpdl_depth (); 4112 if (current_buffer == buf)
4182 Lisp_Object val; 4113 return call3 (fn, arg0, arg1, arg2);
4183 4114 else
4184 if (current_buffer != buf) 4115 {
4185 { 4116 Lisp_Object val;
4117 int speccount = specpdl_depth_counter;
4186 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); 4118 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4187 set_buffer_internal (buf); 4119 set_buffer_internal (buf);
4188 } 4120 val = call3 (fn, arg0, arg1, arg2);
4189 val = call3 (fn, arg0, arg1, arg2); 4121 unbind_to (speccount, Qnil);
4190 unbind_to (speccount, Qnil); 4122 return val;
4191 return val; 4123 }
4192 } 4124 }
4193 4125
4194 Lisp_Object 4126 Lisp_Object
4195 call4_in_buffer (struct buffer *buf, Lisp_Object fn, 4127 call4_in_buffer (struct buffer *buf, Lisp_Object fn,
4196 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, 4128 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4197 Lisp_Object arg3) 4129 Lisp_Object arg3)
4198 { 4130 {
4199 int speccount = specpdl_depth (); 4131 if (current_buffer == buf)
4200 Lisp_Object val; 4132 return call4 (fn, arg0, arg1, arg2, arg3);
4201 4133 else
4202 if (current_buffer != buf) 4134 {
4203 { 4135 Lisp_Object val;
4136 int speccount = specpdl_depth_counter;
4204 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); 4137 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4205 set_buffer_internal (buf); 4138 set_buffer_internal (buf);
4206 } 4139 val = call4 (fn, arg0, arg1, arg2, arg3);
4207 val = call4 (fn, arg0, arg1, arg2, arg3); 4140 unbind_to (speccount, Qnil);
4208 unbind_to (speccount, Qnil); 4141 return val;
4209 return val; 4142 }
4210 } 4143 }
4211 4144
4212 Lisp_Object 4145 Lisp_Object
4213 call5_in_buffer (struct buffer *buf, Lisp_Object fn, 4146 eval_in_buffer (struct buffer *buf, Lisp_Object form)
4214 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, 4147 {
4215 Lisp_Object arg3, Lisp_Object arg4) 4148 if (current_buffer == buf)
4216 { 4149 return Feval (form);
4217 int speccount = specpdl_depth (); 4150 else
4218 Lisp_Object val; 4151 {
4219 4152 Lisp_Object val;
4220 if (current_buffer != buf) 4153 int speccount = specpdl_depth_counter;
4221 {
4222 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); 4154 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4223 set_buffer_internal (buf); 4155 set_buffer_internal (buf);
4224 } 4156 val = Feval (form);
4225 val = call5 (fn, arg0, arg1, arg2, arg3, arg4); 4157 unbind_to (speccount, Qnil);
4226 unbind_to (speccount, Qnil); 4158 return val;
4227 return val; 4159 }
4228 }
4229
4230 Lisp_Object
4231 call6_in_buffer (struct buffer *buf, Lisp_Object fn,
4232 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4233 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5)
4234 {
4235 int speccount = specpdl_depth ();
4236 Lisp_Object val;
4237
4238 if (current_buffer != buf)
4239 {
4240 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4241 set_buffer_internal (buf);
4242 }
4243 val = call6 (fn, arg0, arg1, arg2, arg3, arg4, arg5);
4244 unbind_to (speccount, Qnil);
4245 return val;
4246 }
4247
4248 Lisp_Object
4249 eval_in_buffer (struct buffer *buf, Lisp_Object form)
4250 {
4251 int speccount = specpdl_depth ();
4252 Lisp_Object val;
4253
4254 if (current_buffer != buf)
4255 {
4256 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4257 set_buffer_internal (buf);
4258 }
4259 val = Feval (form);
4260 unbind_to (speccount, Qnil);
4261 return val;
4262 } 4160 }
4263 4161
4264 4162
4265 /***** Error-catching front-ends to eval, funcall, apply */ 4163 /***** Error-catching front-ends to eval, funcall, apply */
4266 4164
4373 4271
4374 Lisp_Object 4272 Lisp_Object
4375 eval_in_buffer_trapping_errors (CONST char *warning_string, 4273 eval_in_buffer_trapping_errors (CONST char *warning_string,
4376 struct buffer *buf, Lisp_Object form) 4274 struct buffer *buf, Lisp_Object form)
4377 { 4275 {
4378 int speccount = specpdl_depth (); 4276 int speccount = specpdl_depth_counter;
4379 Lisp_Object tem; 4277 Lisp_Object tem;
4380 Lisp_Object buffer = Qnil; 4278 Lisp_Object buffer;
4381 Lisp_Object cons; 4279 Lisp_Object cons;
4382 Lisp_Object opaque; 4280 Lisp_Object opaque;
4383 struct gcpro gcpro1, gcpro2; 4281 struct gcpro gcpro1, gcpro2;
4384 4282
4385 XSETBUFFER (buffer, buf); 4283 XSETBUFFER (buffer, buf);
4412 } 4310 }
4413 4311
4414 Lisp_Object 4312 Lisp_Object
4415 run_hook_trapping_errors (CONST char *warning_string, Lisp_Object hook_symbol) 4313 run_hook_trapping_errors (CONST char *warning_string, Lisp_Object hook_symbol)
4416 { 4314 {
4417 int speccount = specpdl_depth (); 4315 int speccount;
4418 Lisp_Object tem; 4316 Lisp_Object tem;
4419 Lisp_Object opaque; 4317 Lisp_Object opaque;
4420 struct gcpro gcpro1; 4318 struct gcpro gcpro1;
4421 4319
4422 if (!initialized || preparing_for_armageddon) 4320 if (!initialized || preparing_for_armageddon)
4423 return Qnil; 4321 return Qnil;
4424 tem = find_symbol_value (hook_symbol); 4322 tem = find_symbol_value (hook_symbol);
4425 if (NILP (tem) || UNBOUNDP (tem)) 4323 if (NILP (tem) || UNBOUNDP (tem))
4426 return Qnil; 4324 return Qnil;
4427 4325
4326 speccount = specpdl_depth_counter;
4428 specbind (Qinhibit_quit, Qt); 4327 specbind (Qinhibit_quit, Qt);
4429 4328
4430 opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil); 4329 opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil);
4431 GCPRO1 (opaque); 4330 GCPRO1 (opaque);
4432 /* Qerror not Qt, so you can get a backtrace */ 4331 /* Qerror not Qt, so you can get a backtrace */
4446 Lisp_Object 4345 Lisp_Object
4447 safe_run_hook_trapping_errors (CONST char *warning_string, 4346 safe_run_hook_trapping_errors (CONST char *warning_string,
4448 Lisp_Object hook_symbol, 4347 Lisp_Object hook_symbol,
4449 int allow_quit) 4348 int allow_quit)
4450 { 4349 {
4451 int speccount = specpdl_depth (); 4350 int speccount = specpdl_depth_counter;
4452 Lisp_Object tem; 4351 Lisp_Object tem;
4453 Lisp_Object cons = Qnil; 4352 Lisp_Object cons = Qnil;
4454 struct gcpro gcpro1; 4353 struct gcpro gcpro1;
4455 4354
4456 if (!initialized || preparing_for_armageddon) 4355 if (!initialized || preparing_for_armageddon)
4490 } 4389 }
4491 4390
4492 Lisp_Object 4391 Lisp_Object
4493 call0_trapping_errors (CONST char *warning_string, Lisp_Object function) 4392 call0_trapping_errors (CONST char *warning_string, Lisp_Object function)
4494 { 4393 {
4495 int speccount = specpdl_depth (); 4394 int speccount;
4496 Lisp_Object tem; 4395 Lisp_Object tem;
4497 Lisp_Object opaque = Qnil; 4396 Lisp_Object opaque = Qnil;
4498 struct gcpro gcpro1, gcpro2; 4397 struct gcpro gcpro1, gcpro2;
4499 4398
4500 if (SYMBOLP (function)) 4399 if (SYMBOLP (function))
4503 if (NILP (tem) || UNBOUNDP (tem)) 4402 if (NILP (tem) || UNBOUNDP (tem))
4504 return Qnil; 4403 return Qnil;
4505 } 4404 }
4506 4405
4507 GCPRO2 (opaque, function); 4406 GCPRO2 (opaque, function);
4407 speccount = specpdl_depth_counter;
4508 specbind (Qinhibit_quit, Qt); 4408 specbind (Qinhibit_quit, Qt);
4509 /* gc_currently_forbidden = 1; Currently no reason to do this; */ 4409 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4510 4410
4511 opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil); 4411 opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil);
4512 /* Qerror not Qt, so you can get a backtrace */ 4412 /* Qerror not Qt, so you can get a backtrace */
4537 4437
4538 Lisp_Object 4438 Lisp_Object
4539 call1_trapping_errors (CONST char *warning_string, Lisp_Object function, 4439 call1_trapping_errors (CONST char *warning_string, Lisp_Object function,
4540 Lisp_Object object) 4440 Lisp_Object object)
4541 { 4441 {
4542 int speccount = specpdl_depth (); 4442 int speccount = specpdl_depth_counter;
4543 Lisp_Object tem; 4443 Lisp_Object tem;
4544 Lisp_Object cons = Qnil; 4444 Lisp_Object cons = Qnil;
4545 Lisp_Object opaque = Qnil; 4445 Lisp_Object opaque = Qnil;
4546 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; 4446 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
4547 4447
4574 4474
4575 Lisp_Object 4475 Lisp_Object
4576 call2_trapping_errors (CONST char *warning_string, Lisp_Object function, 4476 call2_trapping_errors (CONST char *warning_string, Lisp_Object function,
4577 Lisp_Object object1, Lisp_Object object2) 4477 Lisp_Object object1, Lisp_Object object2)
4578 { 4478 {
4579 int speccount = specpdl_depth (); 4479 int speccount = specpdl_depth_counter;
4580 Lisp_Object tem; 4480 Lisp_Object tem;
4581 Lisp_Object cons = Qnil; 4481 Lisp_Object cons = Qnil;
4582 Lisp_Object opaque = Qnil; 4482 Lisp_Object opaque = Qnil;
4583 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; 4483 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
4584 4484
4708 UNGCPRO; 4608 UNGCPRO;
4709 } 4609 }
4710 return symbol; 4610 return symbol;
4711 } 4611 }
4712 4612
4713
4714 /* Don't want to include buffer.h just for this */
4715 extern struct buffer *current_buffer;
4716 4613
4717 void 4614 void
4718 specbind (Lisp_Object symbol, Lisp_Object value) 4615 specbind (Lisp_Object symbol, Lisp_Object value)
4719 { 4616 {
4720 int buffer_local; 4617 int buffer_local;