annotate src/eval.c @ 814:a634e3b7acc8

[xemacs-hg @ 2002-04-14 12:41:59 by ben] latest changes TODO.ben-mule-21-5: Update. make-docfile.c: Add basic support for handling ISO 2022 doc strings -- we parse the basic charset designation sequences so we know whether we're in ASCII and have to pay attention to end quotes and such. Reformat code according to coding standards. abbrev.el: Add `global-abbrev-mode', which turns on or off abbrev-mode in all buffers. Added `defining-abbrev-turns-on-abbrev-mode' -- if non-nil, defining an abbrev through an interactive function will automatically turn on abbrev-mode, either globally or locally depending on the command. This is the "what you'd expect" behavior. indent.el: general function for indenting a balanced expression in a mode-correct way. Works similar to indent-region in that a mode can specify a specific command to do the whole operation; if not, figure out the region using forward-sexp and indent each line using indent-according-to-mode. keydefs.el: Removed. Modify M-C-backslash to do indent-region-or-balanced-expression. Make S-Tab just insert a TAB char, like it's meant to do. make-docfile.el: Now that we're using the call-process-in-lisp, we need to load an extra file win32-native.el because we're running a bare temacs. menubar-items.el: Totally redo the Cmds menu so that most used commands appear directly on the menu and less used commands appear in submenus. The old way may have been very pretty, but rather impractical. process.el: Under Windows, don't ever use old-call-process-internal, even in batch mode. We can do processes in batch mode. subr.el: Someone recoded truncate-string-to-width, saying "the FSF version is too complicated and does lots of hard-to-understand stuff" but the resulting recoded version was *totally* wrong! it misunderstood the basic point of this function, which is work in *columns* not chars. i dumped ours and copied the version from FSF 21.1. Also added truncate-string-with-continuation-dots, since this idiom is used often. config.inc.samp, xemacs.mak: Separate out debug and optimize flags. Remove all vestiges of USE_MINIMAL_TAGBITS, USE_INDEXED_LRECORD_IMPLEMENTATION, and GUNG_HO, since those ifdefs have long been removed. Make error-checking support actually work. Some rearrangement of config.inc.samp to make it more logical. Remove callproc.c and ntproc.c from xemacs.mak, no longer used. Make pdump the default. lisp.h: Add support for strong type-checking of Bytecount, Bytebpos, Charcount, Charbpos, and others, by making them classes, overloading the operators to provide integer-like operation and carefully controlling what operations are allowed. Not currently enabled in C++ builds because there are still a number of compile errors, and it won't really work till we merge in my "8-bit-Mule" workspace, in which I make use of the new types Charxpos, Bytexpos, Memxpos, representing a "position" either in a buffer or a string. (This is especially important in the extent code.) abbrev.c, alloc.c, eval.c, buffer.c, buffer.h, editfns.c, fns.c, text.h: Warning fixes, some of them related to new C++ strict type checking of Bytecount, Charbpos, etc. dired.c: Caught an actual error due to strong type checking -- char len being passed when should be byte len. alloc.c, backtrace.h, bytecode.c, bytecode.h, eval.c, sysdep.c: Further optimize Ffuncall: -- process arg list at compiled-function creation time, converting into an array for extra-quick access at funcall time. -- rewrite funcall_compiled_function to use it, and inline this function. -- change the order of check for magic stuff in SPECBIND_FAST_UNSAFE to be faster. -- move the check for need to garbage collect into the allocation code, so only a single flag needs to be checked in funcall. buffer.c, symbols.c: add debug funs to check on mule optimization info in buffers and strings. eval.c, emacs.c, text.c, regex.c, scrollbar-msw.c, search.c: Fix evil crashes due to eistrings not properly reinitialized under pdump. Redo a bit some of the init routines; convert some complex_vars_of() into simple vars_of(), because they didn't need complex processing. callproc.c, emacs.c, event-stream.c, nt.c, process.c, process.h, sysdep.c, sysdep.h, syssignal.h, syswindows.h, ntproc.c: Delete. Hallelujah, praise the Lord, there is no god but Allah!!! fix so that processes can be invoked in bare temacs -- thereby eliminating any need for callproc.c. (currently only eliminated under NT.) remove all crufty and unnecessary old process code in ntproc.c and elsewhere. move non-callproc-specific stuff (mostly environment) into process.c, so callproc.c can be left out under NT. console-tty.c, doc.c, file-coding.c, file-coding.h, lstream.c, lstream.h: fix doc string handling so it works with Japanese, etc docs. change handling of "character mode" so callers don't have to manually set it (quite error-prone). event-msw.c: spacing fixes. lread.c: eliminate unused crufty vintage-19 "FSF defun hack" code. lrecord.h: improve pdump description docs. buffer.c, ntheap.c, unexnt.c, win32.c, emacs.c: Mule-ize some unexec and startup code. It was pseudo-Mule-ized before by simply always calling the ...A versions of functions, but that won't cut it -- eventually we want to be able to run properly even if XEmacs has been installed in a Japanese directory. (The current problem is the timing of the loading of the Unicode tables; this will eventually be fixed.) Go through and fix various other places where the code was not Mule-clean. Provide a function mswindows_get_module_file_name() to get our own name without resort to PATH_MAX and such. Add a big comment in main() about the problem with Unicode table load timing that I just alluded to. emacs.c: When error-checking is enabled (interpreted as "user is developing XEmacs"), don't ask user to "pause to read messages" when a fatal error has occurred, because it will wedge if we are in an inner modal loop (typically when a menu is popped up) and make us unable to get a useful stack trace in the debugger. text.c: Correct update_entirely_ascii_p_flag to actually work. lisp.h, symsinit.h: declarations for above changes.
author ben
date Sun, 14 Apr 2002 12:43:31 +0000
parents 19dfb459d51a
children 6728e641994e
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1 /* Evaluator for XEmacs Lisp interpreter.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2 Copyright (C) 1985-1987, 1992-1994 Free Software Foundation, Inc.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3 Copyright (C) 1995 Sun Microsystems, Inc.
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
4 Copyright (C) 2000, 2001, 2002 Ben Wing.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6 This file is part of XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
8 XEmacs is free software; you can redistribute it and/or modify it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
9 under the terms of the GNU General Public License as published by the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
10 Free Software Foundation; either version 2, or (at your option) any
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
11 later version.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
12
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
16 for more details.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
17
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
18 You should have received a copy of the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
19 along with XEmacs; see the file COPYING. If not, write to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
21 Boston, MA 02111-1307, USA. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
22
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
23 /* Synched up with: FSF 19.30 (except for Fsignal), Mule 2.0. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
24
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
25 #include <config.h>
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
26 #include "lisp.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
27
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
28 #include "commands.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
29 #include "backtrace.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
30 #include "bytecode.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
31 #include "buffer.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
32 #include "console.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
33 #include "opaque.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
34
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
35 struct backtrace *backtrace_list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
36
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
37 /* Note: you must always fill in all of the fields in a backtrace structure
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
38 before pushing them on the backtrace_list. The profiling code depends
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
39 on this. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
40
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
41 #define PUSH_BACKTRACE(bt) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
42 (bt).next = backtrace_list; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
43 backtrace_list = &(bt); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
44 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
45
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
46 #define POP_BACKTRACE(bt) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
47 backtrace_list = (bt).next; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
48 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
49
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
50 /* Macros for calling subrs with an argument list whose length is only
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
51 known at runtime. See EXFUN and DEFUN for similar hackery. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
52
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
53 #define AV_0(av)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
54 #define AV_1(av) av[0]
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
55 #define AV_2(av) AV_1(av), av[1]
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
56 #define AV_3(av) AV_2(av), av[2]
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
57 #define AV_4(av) AV_3(av), av[3]
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
58 #define AV_5(av) AV_4(av), av[4]
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
59 #define AV_6(av) AV_5(av), av[5]
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
60 #define AV_7(av) AV_6(av), av[6]
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
61 #define AV_8(av) AV_7(av), av[7]
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
62
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
63 #define PRIMITIVE_FUNCALL_1(fn, av, ac) \
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
64 (((Lisp_Object (*)(EXFUN_##ac)) (fn)) (AV_##ac (av)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
65
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
66 /* If subrs take more than 8 arguments, more cases need to be added
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
67 to this switch. (But wait - don't do it - if you really need
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
68 a SUBR with more than 8 arguments, use max_args == MANY.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
69 See the DEFUN macro in lisp.h) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
70 #define PRIMITIVE_FUNCALL(rv, fn, av, ac) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
71 void (*PF_fn)(void) = (void (*)(void)) fn; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
72 Lisp_Object *PF_av = (av); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
73 switch (ac) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
74 { \
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
75 default:rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 0); break; \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
76 case 1: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 1); break; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
77 case 2: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 2); break; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
78 case 3: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 3); break; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
79 case 4: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 4); break; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
80 case 5: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 5); break; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
81 case 6: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 6); break; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
82 case 7: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 7); break; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
83 case 8: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 8); break; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
84 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
85 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
86
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
87 #define FUNCALL_SUBR(rv, subr, av, ac) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
88 PRIMITIVE_FUNCALL (rv, subr_function (subr), av, ac);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
89
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
90
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
91 /* This is the list of current catches (and also condition-cases).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
92 This is a stack: the most recent catch is at the head of the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
93 list. Catches are created by declaring a 'struct catchtag'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
94 locally, filling the .TAG field in with the tag, and doing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
95 a setjmp() on .JMP. Fthrow() will store the value passed
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
96 to it in .VAL and longjmp() back to .JMP, back to the function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
97 that established the catch. This will always be either
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
98 internal_catch() (catches established internally or through
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
99 `catch') or condition_case_1 (condition-cases established
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
100 internally or through `condition-case').
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
101
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
102 The catchtag also records the current position in the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
103 call stack (stored in BACKTRACE_LIST), the current position
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
104 in the specpdl stack (used for variable bindings and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
105 unwind-protects), the value of LISP_EVAL_DEPTH, and the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
106 current position in the GCPRO stack. All of these are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
107 restored by Fthrow().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
108 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
109
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
110 struct catchtag *catchlist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
111
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
112 Lisp_Object Qautoload, Qmacro, Qexit;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
113 Lisp_Object Qinteractive, Qcommandp, Qdefun, Qprogn, Qvalues;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
114 Lisp_Object Vquit_flag, Vinhibit_quit;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
115 Lisp_Object Qand_rest, Qand_optional;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
116 Lisp_Object Qdebug_on_error, Qstack_trace_on_error;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
117 Lisp_Object Qdebug_on_signal, Qstack_trace_on_signal;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
118 Lisp_Object Qdebugger;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
119 Lisp_Object Qinhibit_quit;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
120 Lisp_Object Qrun_hooks;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
121 Lisp_Object Qsetq;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
122 Lisp_Object Qdisplay_warning;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
123 Lisp_Object Vpending_warnings, Vpending_warnings_tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
124 Lisp_Object Qif;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
125
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
126 /* Records whether we want errors to occur. This will be a boolean,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
127 nil (errors OK) or t (no errors). If t, an error will cause a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
128 throw to Qunbound_suspended_errors_tag.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
129
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
130 See call_with_suspended_errors(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
131 Lisp_Object Vcurrent_error_state;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
132
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
133 /* Current warning class when warnings occur, or nil for no warnings.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
134 Only meaningful when Vcurrent_error_state is non-nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
135 See call_with_suspended_errors(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
136 Lisp_Object Vcurrent_warning_class;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
137
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
138 /* Current warning level when warnings occur, or nil for no warnings.
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
139 Only meaningful when Vcurrent_error_state is non-nil.
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
140 See call_with_suspended_errors(). */
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
141 Lisp_Object Vcurrent_warning_level;
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
142
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
143 /* Minimum level at which warnings are logged. Below this, they're ignored
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
144 entirely -- not even generated. */
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
145 Lisp_Object Vlog_warning_minimum_level;
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
146
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
147 /* Special catch tag used in call_with_suspended_errors(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
148 Lisp_Object Qunbound_suspended_errors_tag;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
149
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
150 /* Non-nil means record all fset's and provide's, to be undone
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
151 if the file being autoloaded is not fully loaded.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
152 They are recorded by being consed onto the front of Vautoload_queue:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
153 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
154 Lisp_Object Vautoload_queue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
155
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
156 /* Current number of specbindings allocated in specpdl. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
157 int specpdl_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
158
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
159 /* Pointer to beginning of specpdl. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
160 struct specbinding *specpdl;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
161
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
162 /* Pointer to first unused element in specpdl. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
163 struct specbinding *specpdl_ptr;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
164
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
165 /* specpdl_ptr - specpdl */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
166 int specpdl_depth_counter;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
167
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
168 /* Maximum size allowed for specpdl allocation */
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
169 Fixnum max_specpdl_size;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
170
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
171 /* Depth in Lisp evaluations and function calls. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
172 static int lisp_eval_depth;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
173
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
174 /* Maximum allowed depth in Lisp evaluations and function calls. */
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
175 Fixnum max_lisp_eval_depth;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
176
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
177 /* Nonzero means enter debugger before next function call */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
178 static int debug_on_next_call;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
179
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
180 /* List of conditions (non-nil atom means all) which cause a backtrace
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
181 if an error is handled by the command loop's error handler. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
182 Lisp_Object Vstack_trace_on_error;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
183
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
184 /* List of conditions (non-nil atom means all) which enter the debugger
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
185 if an error is handled by the command loop's error handler. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
186 Lisp_Object Vdebug_on_error;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
187
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
188 /* List of conditions and regexps specifying error messages which
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
189 do not enter the debugger even if Vdebug_on_error says they should. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
190 Lisp_Object Vdebug_ignored_errors;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
191
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
192 /* List of conditions (non-nil atom means all) which cause a backtrace
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
193 if any error is signalled. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
194 Lisp_Object Vstack_trace_on_signal;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
195
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
196 /* List of conditions (non-nil atom means all) which enter the debugger
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
197 if any error is signalled. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
198 Lisp_Object Vdebug_on_signal;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
199
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
200 /* Nonzero means enter debugger if a quit signal
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
201 is handled by the command loop's error handler.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
202
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
203 From lisp, this is a boolean variable and may have the values 0 and 1.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
204 But, eval.c temporarily uses the second bit of this variable to indicate
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
205 that a critical_quit is in progress. The second bit is reset immediately
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
206 after it is processed in signal_call_debugger(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
207 int debug_on_quit;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
208
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
209 #if 0 /* FSFmacs */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
210 /* entering_debugger is basically equivalent */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
211 /* The value of num_nonmacro_input_chars as of the last time we
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
212 started to enter the debugger. If we decide to enter the debugger
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
213 again when this is still equal to num_nonmacro_input_chars, then we
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
214 know that the debugger itself has an error, and we should just
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
215 signal the error instead of entering an infinite loop of debugger
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
216 invocations. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
217 int when_entered_debugger;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
218 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
219
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
220 /* Nonzero means we are trying to enter the debugger.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
221 This is to prevent recursive attempts.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
222 Cleared by the debugger calling Fbacktrace */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
223 static int entering_debugger;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
224
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
225 /* Function to call to invoke the debugger */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
226 Lisp_Object Vdebugger;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
227
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
228 /* Chain of condition handlers currently in effect.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
229 The elements of this chain are contained in the stack frames
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
230 of Fcondition_case and internal_condition_case.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
231 When an error is signaled (by calling Fsignal, below),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
232 this chain is searched for an element that applies.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
233
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
234 Each element of this list is one of the following:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
235
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
236 A list of a handler function and possibly args to pass to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
237 the function. This is a handler established with
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
238 `call-with-condition-handler' (q.v.).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
239
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
240 A list whose car is Qunbound and whose cdr is Qt.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
241 This is a special condition-case handler established
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
242 by C code with condition_case_1(). All errors are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
243 trapped; the debugger is not invoked even if
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
244 `debug-on-error' was set.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
245
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
246 A list whose car is Qunbound and whose cdr is Qerror.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
247 This is a special condition-case handler established
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
248 by C code with condition_case_1(). It is like Qt
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
249 except that the debugger is invoked normally if it is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
250 called for.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
251
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
252 A list whose car is Qunbound and whose cdr is a list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
253 of lists (CONDITION-NAME BODY ...) exactly as in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
254 `condition-case'. This is a normal `condition-case'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
255 handler.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
256
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
257 Note that in all cases *except* the first, there is a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
258 corresponding catch, whose TAG is the value of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
259 Vcondition_handlers just after the handler data just
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
260 described is pushed onto it. The reason is that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
261 `condition-case' handlers need to throw back to the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
262 place where the handler was installed before invoking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
263 it, while `call-with-condition-handler' handlers are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
264 invoked in the environment that `signal' was invoked
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
265 in.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
266 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
267 static Lisp_Object Vcondition_handlers;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
268
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
269
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
270 #define DEFEND_AGAINST_THROW_RECURSION
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
271
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
272 #ifdef DEFEND_AGAINST_THROW_RECURSION
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
273 /* Used for error catching purposes by throw_or_bomb_out */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
274 static int throw_level;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
275 #endif
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
276
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
277 #ifdef ERROR_CHECK_STRUCTURES
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
278 static void check_error_state_sanity (void);
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
279 #define CHECK_ERROR_STATE_SANITY() check_error_state_sanity ()
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
280 #else
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
281 #define CHECK_ERROR_STATE_SANITY()
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
282 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
283
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
284
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
285 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
286 /* The subr object type */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
287 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
288
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
289 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
290 print_subr (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
291 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
292 Lisp_Subr *subr = XSUBR (obj);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
293 const CIntbyte *header =
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
294 (subr->max_args == UNEVALLED) ? "#<special-form " : "#<subr ";
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
295 const CIntbyte *name = subr_name (subr);
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
296 const CIntbyte *trailer = subr->prompt ? " (interactive)>" : ">";
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
297
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
298 if (print_readably)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
299 printing_unreadable_object ("%s%s%s", header, name, trailer);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
300
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
301 write_c_string (header, printcharfun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
302 write_c_string (name, printcharfun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
303 write_c_string (trailer, printcharfun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
304 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
305
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
306 static const struct lrecord_description subr_description[] = {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
307 { XD_DOC_STRING, offsetof (Lisp_Subr, doc) },
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
308 { XD_END }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
309 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
310
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
311 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("subr", subr,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
312 0, print_subr, 0, 0, 0,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
313 subr_description,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
314 Lisp_Subr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
315
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
316 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
317 /* Entering the debugger */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
318 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
319
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
320 /* unwind-protect used by call_debugger() to restore the value of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
321 entering_debugger. (We cannot use specbind() because the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
322 variable is not Lisp-accessible.) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
323
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
324 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
325 restore_entering_debugger (Lisp_Object arg)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
326 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
327 entering_debugger = ! NILP (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
328 return arg;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
329 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
330
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
331 /* Actually call the debugger. ARG is a list of args that will be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
332 passed to the debugger function, as follows;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
333
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
334 If due to frame exit, args are `exit' and the value being returned;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
335 this function's value will be returned instead of that.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
336 If due to error, args are `error' and a list of the args to `signal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
337 If due to `apply' or `funcall' entry, one arg, `lambda'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
338 If due to `eval' entry, one arg, t.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
339
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
340 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
341
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
342 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
343 call_debugger_259 (Lisp_Object arg)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
344 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
345 return apply1 (Vdebugger, arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
346 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
347
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
348 /* Call the debugger, doing some encapsulation. We make sure we have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
349 some room on the eval and specpdl stacks, and bind entering_debugger
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
350 to 1 during this call. This is used to trap errors that may occur
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
351 when entering the debugger (e.g. the value of `debugger' is invalid),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
352 so that the debugger will not be recursively entered if debug-on-error
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
353 is set. (Otherwise, XEmacs would infinitely recurse, attempting to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
354 enter the debugger.) entering_debugger gets reset to 0 as soon
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
355 as a backtrace is displayed, so that further errors can indeed be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
356 handled normally.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
357
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
358 We also establish a catch for 'debugger. If the debugger function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
359 throws to this instead of returning a value, it means that the user
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
360 pressed 'c' (pretend like the debugger was never entered). The
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
361 function then returns Qunbound. (If the user pressed 'r', for
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
362 return a value, then the debugger function returns normally with
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
363 this value.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
364
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
365 The difference between 'c' and 'r' is as follows:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
366
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
367 debug-on-call:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
368 No difference. The call proceeds as normal.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
369 debug-on-exit:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
370 With 'r', the specified value is returned as the function's
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
371 return value. With 'c', the value that would normally be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
372 returned is returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
373 signal:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
374 With 'r', the specified value is returned as the return
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
375 value of `signal'. (This is the only time that `signal'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
376 can return, instead of making a non-local exit.) With `c',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
377 `signal' will continue looking for handlers as if the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
378 debugger was never entered, and will probably end up
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
379 throwing to a handler or to top-level.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
380 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
381
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
382 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
383 call_debugger (Lisp_Object arg)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
384 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
385 int threw;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
386 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
387 int speccount;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
388
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
389 if (lisp_eval_depth + 20 > max_lisp_eval_depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
390 max_lisp_eval_depth = lisp_eval_depth + 20;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
391 if (specpdl_size + 40 > max_specpdl_size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
392 max_specpdl_size = specpdl_size + 40;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
393 debug_on_next_call = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
394
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
395 speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
396 record_unwind_protect (restore_entering_debugger,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
397 (entering_debugger ? Qt : Qnil));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
398 entering_debugger = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
399 val = internal_catch (Qdebugger, call_debugger_259, arg, &threw);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
400
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
401 return unbind_to_1 (speccount, ((threw)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
402 ? Qunbound /* Not returning a value */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
403 : val));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
404 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
405
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
406 /* Called when debug-on-exit behavior is called for. Enter the debugger
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
407 with the appropriate args for this. VAL is the exit value that is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
408 about to be returned. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
409
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
410 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
411 do_debug_on_exit (Lisp_Object val)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
412 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
413 /* This is falsified by call_debugger */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
414 Lisp_Object v = call_debugger (list2 (Qexit, val));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
415
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
416 return !UNBOUNDP (v) ? v : val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
417 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
418
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
419 /* Called when debug-on-call behavior is called for. Enter the debugger
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
420 with the appropriate args for this. VAL is either t for a call
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
421 through `eval' or 'lambda for a call through `funcall'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
422
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
423 #### The differentiation here between EVAL and FUNCALL is bogus.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
424 FUNCALL can be defined as
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
425
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
426 (defmacro func (fun &rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
427 (cons (eval fun) args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
429 and should be treated as such.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
430 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
431
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
432 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
433 do_debug_on_call (Lisp_Object code)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
434 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
435 debug_on_next_call = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
436 backtrace_list->debug_on_exit = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
437 call_debugger (list1 (code));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
438 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
439
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
440 /* LIST is the value of one of the variables `debug-on-error',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
441 `debug-on-signal', `stack-trace-on-error', or `stack-trace-on-signal',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
442 and CONDITIONS is the list of error conditions associated with
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
443 the error being signalled. This returns non-nil if LIST
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
444 matches CONDITIONS. (A nil value for LIST does not match
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
445 CONDITIONS. A non-list value for LIST does match CONDITIONS.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
446 A list matches CONDITIONS when one of the symbols in LIST is the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
447 same as one of the symbols in CONDITIONS.) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
448
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
449 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
450 wants_debugger (Lisp_Object list, Lisp_Object conditions)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
451 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
452 if (NILP (list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
453 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
454 if (! CONSP (list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
455 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
456
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
457 while (CONSP (conditions))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
458 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
459 Lisp_Object this, tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
460 this = XCAR (conditions);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
461 for (tail = list; CONSP (tail); tail = XCDR (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
462 if (EQ (XCAR (tail), this))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
463 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
464 conditions = XCDR (conditions);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
465 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
466 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
467 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
468
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
469
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
470 /* Return 1 if an error with condition-symbols CONDITIONS,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
471 and described by SIGNAL-DATA, should skip the debugger
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
472 according to debugger-ignore-errors. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
473
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
474 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
475 skip_debugger (Lisp_Object conditions, Lisp_Object data)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
476 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
477 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
478 Lisp_Object tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
479 int first_string = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
480 Lisp_Object error_message = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
481
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
482 for (tail = Vdebug_ignored_errors; CONSP (tail); tail = XCDR (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
483 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
484 if (STRINGP (XCAR (tail)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
485 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
486 if (first_string)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
487 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
488 error_message = Ferror_message_string (data);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
489 first_string = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
490 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
491 if (fast_lisp_string_match (XCAR (tail), error_message) >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
492 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
493 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
494 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
495 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
496 Lisp_Object contail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
497
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
498 for (contail = conditions; CONSP (contail); contail = XCDR (contail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
499 if (EQ (XCAR (tail), XCAR (contail)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
500 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
501 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
502 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
503
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
504 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
505 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
506
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
507 /* Actually generate a backtrace on STREAM. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
508
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
509 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
510 backtrace_259 (Lisp_Object stream)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
511 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
512 return Fbacktrace (stream, Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
513 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
514
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
515 /* An error was signaled. Maybe call the debugger, if the `debug-on-error'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
516 etc. variables call for this. CONDITIONS is the list of conditions
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
517 associated with the error being signalled. SIG is the actual error
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
518 being signalled, and DATA is the associated data (these are exactly
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
519 the same as the arguments to `signal'). ACTIVE_HANDLERS is the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
520 list of error handlers that are to be put in place while the debugger
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
521 is called. This is generally the remaining handlers that are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
522 outside of the innermost handler trapping this error. This way,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
523 if the same error occurs inside of the debugger, you usually don't get
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
524 the debugger entered recursively.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
525
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
526 This function returns Qunbound if it didn't call the debugger or if
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
527 the user asked (through 'c') that XEmacs should pretend like the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
528 debugger was never entered. Otherwise, it returns the value
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
529 that the user specified with `r'. (Note that much of the time,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
530 the user will abort with C-], and we will never have a chance to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
531 return anything at all.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
532
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
533 SIGNAL_VARS_ONLY means we should only look at debug-on-signal
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
534 and stack-trace-on-signal to control whether we do anything.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
535 This is so that debug-on-error doesn't make handled errors
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
536 cause the debugger to get invoked.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
537
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
538 STACK_TRACE_DISPLAYED and DEBUGGER_ENTERED are used so that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
539 those functions aren't done more than once in a single `signal'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
540 session. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
541
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
542 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
543 signal_call_debugger (Lisp_Object conditions,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
544 Lisp_Object sig, Lisp_Object data,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
545 Lisp_Object active_handlers,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
546 int signal_vars_only,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
547 int *stack_trace_displayed,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
548 int *debugger_entered)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
549 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
550 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
551 Lisp_Object val = Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
552 Lisp_Object all_handlers = Vcondition_handlers;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
553 Lisp_Object temp_data = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
554 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
555 struct gcpro gcpro1, gcpro2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
556 GCPRO2 (all_handlers, temp_data);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
557
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
558 Vcondition_handlers = active_handlers;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
559
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
560 temp_data = Fcons (sig, data); /* needed for skip_debugger */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
561
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
562 if (!entering_debugger && !*stack_trace_displayed && !signal_vars_only
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
563 && wants_debugger (Vstack_trace_on_error, conditions)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
564 && !skip_debugger (conditions, temp_data))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
565 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
566 specbind (Qdebug_on_error, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
567 specbind (Qstack_trace_on_error, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
568 specbind (Qdebug_on_signal, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
569 specbind (Qstack_trace_on_signal, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
570
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
571 if (!noninteractive)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
572 internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
573 backtrace_259,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
574 Qnil,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
575 Qnil);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
576 else /* in batch mode, we want this going to stderr. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
577 backtrace_259 (Qnil);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
578 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
579 *stack_trace_displayed = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
580 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
581
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
582 if (!entering_debugger && !*debugger_entered && !signal_vars_only
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
583 && (EQ (sig, Qquit)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
584 ? debug_on_quit
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
585 : wants_debugger (Vdebug_on_error, conditions))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
586 && !skip_debugger (conditions, temp_data))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
587 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
588 debug_on_quit &= ~2; /* reset critical bit */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
589 specbind (Qdebug_on_error, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
590 specbind (Qstack_trace_on_error, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
591 specbind (Qdebug_on_signal, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
592 specbind (Qstack_trace_on_signal, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
593
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
594 val = call_debugger (list2 (Qerror, (Fcons (sig, data))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
595 *debugger_entered = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
596 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
597
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
598 if (!entering_debugger && !*stack_trace_displayed
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
599 && wants_debugger (Vstack_trace_on_signal, conditions))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
600 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
601 specbind (Qdebug_on_error, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
602 specbind (Qstack_trace_on_error, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
603 specbind (Qdebug_on_signal, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
604 specbind (Qstack_trace_on_signal, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
605
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
606 if (!noninteractive)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
607 internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
608 backtrace_259,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
609 Qnil,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
610 Qnil);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
611 else /* in batch mode, we want this going to stderr. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
612 backtrace_259 (Qnil);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
613 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
614 *stack_trace_displayed = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
615 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
616
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
617 if (!entering_debugger && !*debugger_entered
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
618 && (EQ (sig, Qquit)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
619 ? debug_on_quit
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
620 : wants_debugger (Vdebug_on_signal, conditions)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
621 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
622 debug_on_quit &= ~2; /* reset critical bit */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
623 specbind (Qdebug_on_error, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
624 specbind (Qstack_trace_on_error, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
625 specbind (Qdebug_on_signal, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
626 specbind (Qstack_trace_on_signal, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
627
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
628 val = call_debugger (list2 (Qerror, (Fcons (sig, data))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
629 *debugger_entered = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
630 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
631
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
632 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
633 Vcondition_handlers = all_handlers;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
634 return unbind_to_1 (speccount, val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
635 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
636
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
637
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
638 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
639 /* The basic special forms */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
640 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
641
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
642 /* Except for Fprogn(), the basic special forms below are only called
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
643 from interpreted code. The byte compiler turns them into bytecodes. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
644
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
645 DEFUN ("or", For, 0, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
646 Eval args until one of them yields non-nil, then return that value.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
647 The remaining args are not evalled at all.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
648 If all args return nil, return nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
649 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
650 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
651 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
652 /* This function can GC */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
653 REGISTER Lisp_Object val;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
654
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
655 LIST_LOOP_2 (arg, args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
656 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
657 if (!NILP (val = Feval (arg)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
658 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
659 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
660
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
661 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
662 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
663
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
664 DEFUN ("and", Fand, 0, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
665 Eval args until one of them yields nil, then return nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
666 The remaining args are not evalled at all.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
667 If no arg yields nil, return the last arg's value.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
668 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
669 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
670 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
671 /* This function can GC */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
672 REGISTER Lisp_Object val = Qt;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
673
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
674 LIST_LOOP_2 (arg, args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
675 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
676 if (NILP (val = Feval (arg)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
677 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
678 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
679
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
680 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
681 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
682
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
683 DEFUN ("if", Fif, 2, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
684 \(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
685 Returns the value of THEN or the value of the last of the ELSE's.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
686 THEN must be one expression, but ELSE... can be zero or more expressions.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
687 If COND yields nil, and there are no ELSE's, the value is nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
688 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
689 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
690 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
691 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
692 Lisp_Object condition = XCAR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
693 Lisp_Object then_form = XCAR (XCDR (args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
694 Lisp_Object else_forms = XCDR (XCDR (args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
695
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
696 if (!NILP (Feval (condition)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
697 return Feval (then_form);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
698 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
699 return Fprogn (else_forms);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
700 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
701
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
702 /* Macros `when' and `unless' are trivially defined in Lisp,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
703 but it helps for bootstrapping to have them ALWAYS defined. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
704
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
705 DEFUN ("when", Fwhen, 1, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
706 \(when COND BODY...): if COND yields non-nil, do BODY, else return nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
707 BODY can be zero or more expressions. If BODY is nil, return nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
708 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
709 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
710 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
711 Lisp_Object cond = args[0];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
712 Lisp_Object body;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
713
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
714 switch (nargs)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
715 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
716 case 1: body = Qnil; break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
717 case 2: body = args[1]; break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
718 default: body = Fcons (Qprogn, Flist (nargs-1, args+1)); break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
719 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
720
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
721 return list3 (Qif, cond, body);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
722 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
723
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
724 DEFUN ("unless", Funless, 1, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
725 \(unless COND BODY...): if COND yields nil, do BODY, else return nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
726 BODY can be zero or more expressions. If BODY is nil, return nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
727 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
728 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
729 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
730 Lisp_Object cond = args[0];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
731 Lisp_Object body = Flist (nargs-1, args+1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
732 return Fcons (Qif, Fcons (cond, Fcons (Qnil, body)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
733 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
734
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
735 DEFUN ("cond", Fcond, 0, UNEVALLED, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
736 \(cond CLAUSES...): try each clause until one succeeds.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
737 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
738 and, if the value is non-nil, this clause succeeds:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
739 then the expressions in BODY are evaluated and the last one's
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
740 value is the value of the cond-form.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
741 If no clause succeeds, cond returns nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
742 If a clause has one element, as in (CONDITION),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
743 CONDITION's value if non-nil is returned from the cond-form.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
744 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
745 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
746 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
747 /* This function can GC */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
748 REGISTER Lisp_Object val;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
749
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
750 LIST_LOOP_2 (clause, args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
751 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
752 CHECK_CONS (clause);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
753 if (!NILP (val = Feval (XCAR (clause))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
754 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
755 if (!NILP (clause = XCDR (clause)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
756 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
757 CHECK_TRUE_LIST (clause);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
758 val = Fprogn (clause);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
759 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
760 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
761 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
762 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
763
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
764 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
765 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
766
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
767 DEFUN ("progn", Fprogn, 0, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
768 \(progn BODY...): eval BODY forms sequentially and return value of last one.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
769 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
770 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
771 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
772 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
773 /* Caller must provide a true list in ARGS */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
774 REGISTER Lisp_Object val = Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
775 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
776
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
777 GCPRO1 (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
778
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
779 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
780 LIST_LOOP_2 (form, args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
781 val = Feval (form);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
782 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
783
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
784 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
785 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
786 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
787
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
788 /* Fprog1() is the canonical example of a function that must GCPRO a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
789 Lisp_Object across calls to Feval(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
790
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
791 DEFUN ("prog1", Fprog1, 1, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
792 Similar to `progn', but the value of the first form is returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
793 \(prog1 FIRST BODY...): All the arguments are evaluated sequentially.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
794 The value of FIRST is saved during evaluation of the remaining args,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
795 whose values are discarded.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
796 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
797 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
798 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
799 /* This function can GC */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
800 REGISTER Lisp_Object val;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
801 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
802
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
803 val = Feval (XCAR (args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
804
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
805 GCPRO1 (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
806
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
807 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
808 LIST_LOOP_2 (form, XCDR (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
809 Feval (form);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
810 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
811
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
812 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
813 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
814 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
815
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
816 DEFUN ("prog2", Fprog2, 2, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
817 Similar to `progn', but the value of the second form is returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
818 \(prog2 FIRST SECOND BODY...): All the arguments are evaluated sequentially.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
819 The value of SECOND is saved during evaluation of the remaining args,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
820 whose values are discarded.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
821 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
822 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
823 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
824 /* This function can GC */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
825 REGISTER Lisp_Object val;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
826 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
827
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
828 Feval (XCAR (args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
829 args = XCDR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
830 val = Feval (XCAR (args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
831 args = XCDR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
832
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
833 GCPRO1 (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
834
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
835 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
836 LIST_LOOP_2 (form, args)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
837 Feval (form);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
838 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
839
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
840 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
841 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
842 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
843
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
844 DEFUN ("let*", FletX, 1, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
845 \(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
846 The value of the last form in BODY is returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
847 Each element of VARLIST is a symbol (which is bound to nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
848 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
849 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
850 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
851 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
852 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
853 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
854 Lisp_Object varlist = XCAR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
855 Lisp_Object body = XCDR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
856 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
857
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
858 EXTERNAL_LIST_LOOP_3 (var, varlist, tail)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
859 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
860 Lisp_Object symbol, value, tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
861 if (SYMBOLP (var))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
862 symbol = var, value = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
863 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
864 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
865 CHECK_CONS (var);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
866 symbol = XCAR (var);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
867 tem = XCDR (var);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
868 if (NILP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
869 value = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
870 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
871 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
872 CHECK_CONS (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
873 value = Feval (XCAR (tem));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
874 if (!NILP (XCDR (tem)))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
875 sferror
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
876 ("`let' bindings can have only one value-form", var);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
877 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
878 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
879 specbind (symbol, value);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
880 }
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
881 return unbind_to_1 (speccount, Fprogn (body));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
882 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
883
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
884 DEFUN ("let", Flet, 1, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
885 \(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
886 The value of the last form in BODY is returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
887 Each element of VARLIST is a symbol (which is bound to nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
888 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
889 All the VALUEFORMs are evalled before any symbols are bound.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
890 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
891 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
892 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
893 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
894 Lisp_Object varlist = XCAR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
895 Lisp_Object body = XCDR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
896 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
897 Lisp_Object *temps;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
898 int idx;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
899 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
900
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
901 /* Make space to hold the values to give the bound variables. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
902 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
903 int varcount;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
904 GET_EXTERNAL_LIST_LENGTH (varlist, varcount);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
905 temps = alloca_array (Lisp_Object, varcount);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
906 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
907
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
908 /* Compute the values and store them in `temps' */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
909 GCPRO1 (*temps);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
910 gcpro1.nvars = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
911
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
912 idx = 0;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
913 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
914 LIST_LOOP_2 (var, varlist)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
915 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
916 Lisp_Object *value = &temps[idx++];
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
917 if (SYMBOLP (var))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
918 *value = Qnil;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
919 else
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
920 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
921 Lisp_Object tem;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
922 CHECK_CONS (var);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
923 tem = XCDR (var);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
924 if (NILP (tem))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
925 *value = Qnil;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
926 else
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
927 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
928 CHECK_CONS (tem);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
929 *value = Feval (XCAR (tem));
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
930 gcpro1.nvars = idx;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
931
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
932 if (!NILP (XCDR (tem)))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
933 sferror
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
934 ("`let' bindings can have only one value-form", var);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
935 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
936 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
937 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
938 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
939
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
940 idx = 0;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
941 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
942 LIST_LOOP_2 (var, varlist)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
943 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
944 specbind (SYMBOLP (var) ? var : XCAR (var), temps[idx++]);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
945 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
946 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
947
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
948 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
949
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
950 return unbind_to_1 (speccount, Fprogn (body));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
951 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
952
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
953 DEFUN ("while", Fwhile, 1, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
954 \(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
955 The order of execution is thus TEST, BODY, TEST, BODY and so on
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
956 until TEST returns nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
957 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
958 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
959 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
960 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
961 Lisp_Object test = XCAR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
962 Lisp_Object body = XCDR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
963
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
964 while (!NILP (Feval (test)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
965 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
966 QUIT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
967 Fprogn (body);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
968 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
969
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
970 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
971 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
972
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
973 DEFUN ("setq", Fsetq, 0, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
974 \(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
975 The symbols SYM are variables; they are literal (not evaluated).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
976 The values VAL are expressions; they are evaluated.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
977 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
978 The second VAL is not computed until after the first SYM is set, and so on;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
979 each VAL can use the new value of variables set earlier in the `setq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
980 The return value of the `setq' form is the value of the last VAL.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
981 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
982 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
983 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
984 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
985 Lisp_Object symbol, tail, val = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
986 int nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
987 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
988
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
989 GET_LIST_LENGTH (args, nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
990
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
991 if (nargs & 1) /* Odd number of arguments? */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
992 Fsignal (Qwrong_number_of_arguments, list2 (Qsetq, make_int (nargs)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
993
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
994 GCPRO1 (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
995
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
996 PROPERTY_LIST_LOOP (tail, symbol, val, args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
997 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
998 val = Feval (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
999 Fset (symbol, val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1000 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1001
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1002 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1003 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1004 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1005
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1006 DEFUN ("quote", Fquote, 1, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1007 Return the argument, without evaluating it. `(quote x)' yields `x'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1008 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1009 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1010 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1011 return XCAR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1012 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1013
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1014 DEFUN ("function", Ffunction, 1, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1015 Like `quote', but preferred for objects which are functions.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1016 In byte compilation, `function' causes its argument to be compiled.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1017 `quote' cannot do that.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1018 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1019 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1020 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1021 return XCAR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1022 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1023
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1024
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1025 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1026 /* Defining functions/variables */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1027 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1028 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1029 define_function (Lisp_Object name, Lisp_Object defn)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1030 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1031 Ffset (name, defn);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1032 LOADHIST_ATTACH (name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1033 return name;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1034 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1035
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1036 DEFUN ("defun", Fdefun, 2, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1037 \(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1038 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1039 See also the function `interactive'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1040 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1041 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1042 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1043 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1044 return define_function (XCAR (args),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1045 Fcons (Qlambda, XCDR (args)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1046 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1047
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1048 DEFUN ("defmacro", Fdefmacro, 2, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1049 \(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1050 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1051 When the macro is called, as in (NAME ARGS...),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1052 the function (lambda ARGLIST BODY...) is applied to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1053 the list ARGS... as it appears in the expression,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1054 and the result should be a form to be evaluated instead of the original.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1055 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1056 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1057 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1058 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1059 return define_function (XCAR (args),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1060 Fcons (Qmacro, Fcons (Qlambda, XCDR (args))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1061 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1062
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1063 DEFUN ("defvar", Fdefvar, 1, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1064 \(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1065 You are not required to define a variable in order to use it,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1066 but the definition can supply documentation and an initial value
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1067 in a way that tags can recognize.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1068
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1069 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1070 void. (However, when you evaluate a defvar interactively, it acts like a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1071 defconst: SYMBOL's value is always set regardless of whether it's currently
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1072 void.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1073 If SYMBOL is buffer-local, its default value is what is set;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1074 buffer-local values are not affected.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1075 INITVALUE and DOCSTRING are optional.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1076 If DOCSTRING starts with *, this variable is identified as a user option.
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1077 This means that M-x set-variable recognizes it.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1078 If INITVALUE is missing, SYMBOL's value is not set.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1079
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1080 In lisp-interaction-mode defvar is treated as defconst.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1081 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1082 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1083 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1084 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1085 Lisp_Object sym = XCAR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1086
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1087 if (!NILP (args = XCDR (args)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1088 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1089 Lisp_Object val = XCAR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1090
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1091 if (NILP (Fdefault_boundp (sym)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1092 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1093 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1094 GCPRO1 (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1095 val = Feval (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1096 Fset_default (sym, val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1097 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1098 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1099
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1100 if (!NILP (args = XCDR (args)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1101 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1102 Lisp_Object doc = XCAR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1103 Fput (sym, Qvariable_documentation, doc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1104 if (!NILP (args = XCDR (args)))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
1105 signal_error (Qwrong_number_of_arguments, "too many arguments", Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1106 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1107 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1108
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1109 #ifdef I18N3
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1110 if (!NILP (Vfile_domain))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1111 Fput (sym, Qvariable_domain, Vfile_domain);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1112 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1113
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1114 LOADHIST_ATTACH (sym);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1115 return sym;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1116 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1117
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1118 DEFUN ("defconst", Fdefconst, 2, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1119 \(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1120 variable.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1121 The intent is that programs do not change this value, but users may.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1122 Always sets the value of SYMBOL to the result of evalling INITVALUE.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1123 If SYMBOL is buffer-local, its default value is what is set;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1124 buffer-local values are not affected.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1125 DOCSTRING is optional.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1126 If DOCSTRING starts with *, this variable is identified as a user option.
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1127 This means that M-x set-variable recognizes it.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1128
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1129 Note: do not use `defconst' for user options in libraries that are not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1130 normally loaded, since it is useful for users to be able to specify
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1131 their own values for such variables before loading the library.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1132 Since `defconst' unconditionally assigns the variable,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1133 it would override the user's choice.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1134 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1135 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1136 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1137 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1138 Lisp_Object sym = XCAR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1139 Lisp_Object val = Feval (XCAR (args = XCDR (args)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1140 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1141
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1142 GCPRO1 (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1143
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1144 Fset_default (sym, val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1145
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1146 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1147
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1148 if (!NILP (args = XCDR (args)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1149 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1150 Lisp_Object doc = XCAR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1151 Fput (sym, Qvariable_documentation, doc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1152 if (!NILP (args = XCDR (args)))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
1153 signal_error (Qwrong_number_of_arguments, "too many arguments", Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1154 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1155
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1156 #ifdef I18N3
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1157 if (!NILP (Vfile_domain))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1158 Fput (sym, Qvariable_domain, Vfile_domain);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1159 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1160
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1161 LOADHIST_ATTACH (sym);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1162 return sym;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1163 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1164
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1165 DEFUN ("user-variable-p", Fuser_variable_p, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1166 Return t if VARIABLE is intended to be set and modified by users.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1167 \(The alternative is a variable used internally in a Lisp program.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1168 Determined by whether the first character of the documentation
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1169 for the variable is `*'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1170 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1171 (variable))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1172 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1173 Lisp_Object documentation = Fget (variable, Qvariable_documentation, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1174
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1175 return
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1176 ((INTP (documentation) && XINT (documentation) < 0) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1177
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1178 (STRINGP (documentation) &&
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
1179 (XSTRING_BYTE (documentation, 0) == '*')) ||
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1180
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1181 /* If (STRING . INTEGER), a negative integer means a user variable. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1182 (CONSP (documentation)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1183 && STRINGP (XCAR (documentation))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1184 && INTP (XCDR (documentation))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1185 && XINT (XCDR (documentation)) < 0)) ?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1186 Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1187 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1188
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1189 DEFUN ("macroexpand-internal", Fmacroexpand_internal, 1, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1190 Return result of expanding macros at top level of FORM.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1191 If FORM is not a macro call, it is returned unchanged.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1192 Otherwise, the macro is expanded and the expansion is considered
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1193 in place of FORM. When a non-macro-call results, it is returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1194
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1195 The second optional arg ENVIRONMENT specifies an environment of macro
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1196 definitions to shadow the loaded ones for use in file byte-compilation.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1197 */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1198 (form, environment))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1199 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1200 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1201 /* With cleanups from Hallvard Furuseth. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1202 REGISTER Lisp_Object expander, sym, def, tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1203
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1204 while (1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1205 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1206 /* Come back here each time we expand a macro call,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1207 in case it expands into another macro call. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1208 if (!CONSP (form))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1209 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1210 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1211 def = sym = XCAR (form);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1212 tem = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1213 /* Trace symbols aliases to other symbols
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1214 until we get a symbol that is not an alias. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1215 while (SYMBOLP (def))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1216 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1217 QUIT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1218 sym = def;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1219 tem = Fassq (sym, environment);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1220 if (NILP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1221 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1222 def = XSYMBOL (sym)->function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1223 if (!UNBOUNDP (def))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1224 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1225 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1226 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1227 }
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1228 /* Right now TEM is the result from SYM in ENVIRONMENT,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1229 and if TEM is nil then DEF is SYM's function definition. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1230 if (NILP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1231 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1232 /* SYM is not mentioned in ENVIRONMENT.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1233 Look at its function definition. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1234 if (UNBOUNDP (def)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1235 || !CONSP (def))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1236 /* Not defined or definition not suitable */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1237 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1238 if (EQ (XCAR (def), Qautoload))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1239 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1240 /* Autoloading function: will it be a macro when loaded? */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1241 tem = Felt (def, make_int (4));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1242 if (EQ (tem, Qt) || EQ (tem, Qmacro))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1243 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1244 /* Yes, load it and try again. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1245 do_autoload (def, sym);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1246 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1247 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1248 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1249 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1250 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1251 else if (!EQ (XCAR (def), Qmacro))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1252 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1253 else expander = XCDR (def);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1254 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1255 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1256 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1257 expander = XCDR (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1258 if (NILP (expander))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1259 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1260 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1261 form = apply1 (expander, XCDR (form));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1262 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1263 return form;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1264 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1265
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1266
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1267 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1268 /* Non-local exits */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1269 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1270
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1271 DEFUN ("catch", Fcatch, 1, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1272 \(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1273 TAG is evalled to get the tag to use. Then the BODY is executed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1274 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1275 If no throw happens, `catch' returns the value of the last BODY form.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1276 If a throw happens, it specifies the value to return from `catch'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1277 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1278 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1279 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1280 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1281 Lisp_Object tag = Feval (XCAR (args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1282 Lisp_Object body = XCDR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1283 return internal_catch (tag, Fprogn, body, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1284 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1285
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1286 /* Set up a catch, then call C function FUNC on argument ARG.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1287 FUNC should return a Lisp_Object.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1288 This is how catches are done from within C code. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1289
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1290 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1291 internal_catch (Lisp_Object tag,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1292 Lisp_Object (*func) (Lisp_Object arg),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1293 Lisp_Object arg,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1294 int * volatile threw)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1295 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1296 /* This structure is made part of the chain `catchlist'. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1297 struct catchtag c;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1298
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1299 /* Fill in the components of c, and put it on the list. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1300 c.next = catchlist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1301 c.tag = tag;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1302 c.val = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1303 c.backlist = backtrace_list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1304 #if 0 /* FSFmacs */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1305 /* #### */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1306 c.handlerlist = handlerlist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1307 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1308 c.lisp_eval_depth = lisp_eval_depth;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1309 c.pdlcount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1310 #if 0 /* FSFmacs */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1311 c.poll_suppress_count = async_timer_suppress_count;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1312 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1313 c.gcpro = gcprolist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1314 catchlist = &c;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1315
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1316 /* Call FUNC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1317 if (SETJMP (c.jmp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1318 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1319 /* Throw works by a longjmp that comes right here. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1320 if (threw) *threw = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1321 return c.val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1322 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1323 c.val = (*func) (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1324 if (threw) *threw = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1325 catchlist = c.next;
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
1326 CHECK_ERROR_STATE_SANITY ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1327 return c.val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1328 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1329
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1330
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1331 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1332 jump to that CATCH, returning VALUE as the value of that catch.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1333
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1334 This is the guts Fthrow and Fsignal; they differ only in the way
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1335 they choose the catch tag to throw to. A catch tag for a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1336 condition-case form has a TAG of Qnil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1337
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1338 Before each catch is discarded, unbind all special bindings and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1339 execute all unwind-protect clauses made above that catch. Unwind
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1340 the handler stack as we go, so that the proper handlers are in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1341 effect for each unwind-protect clause we run. At the end, restore
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1342 some static info saved in CATCH, and longjmp to the location
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1343 specified in the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1344
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1345 This is used for correct unwinding in Fthrow and Fsignal. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1346
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1347 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1348 unwind_to_catch (struct catchtag *c, Lisp_Object val)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1349 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1350 REGISTER int last_time;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1351
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1352 /* Unwind the specbind, catch, and handler stacks back to CATCH
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1353 Before each catch is discarded, unbind all special bindings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1354 and execute all unwind-protect clauses made above that catch.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1355 At the end, restore some static info saved in CATCH,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1356 and longjmp to the location specified.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1357 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1358
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1359 /* Save the value somewhere it will be GC'ed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1360 (Can't overwrite tag slot because an unwind-protect may
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1361 want to throw to this same tag, which isn't yet invalid.) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1362 c->val = val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1363
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1364 #if 0 /* FSFmacs */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1365 /* Restore the polling-suppression count. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1366 set_poll_suppress_count (catch->poll_suppress_count);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1367 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1368
617
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1369 #if 1
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1370 do
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1371 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1372 last_time = catchlist == c;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1373
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1374 /* Unwind the specpdl stack, and then restore the proper set of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1375 handlers. */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
1376 unbind_to (catchlist->pdlcount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1377 catchlist = catchlist->next;
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
1378 CHECK_ERROR_STATE_SANITY ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1379 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1380 while (! last_time);
617
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1381 #else
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1382 /* Former XEmacs code. This is definitely not as correct because
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1383 there may be a number of catches we're unwinding, and a number
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1384 of unwind-protects in the process. By not undoing the catches till
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1385 the end, there may be invalid catches still current. (This would
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1386 be a particular problem with code like this:
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1387
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1388 (catch 'foo
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1389 (call-some-code-which-does...
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1390 (catch 'bar
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1391 (unwind-protect
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1392 (call-some-code-which-does...
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1393 (catch 'bar
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1394 (call-some-code-which-does...
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1395 (throw 'foo nil))))
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1396 (throw 'bar nil)))))
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1397
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1398 This would try to throw to the inner (catch 'bar)!
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1399
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1400 --ben
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1401 */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1402 /* Unwind the specpdl stack */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
1403 unbind_to (c->pdlcount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1404 catchlist = c->next;
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
1405 CHECK_ERROR_STATE_SANITY ();
617
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1406 #endif /* Former code */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1407
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1408 gcprolist = c->gcpro;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1409 backtrace_list = c->backlist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1410 lisp_eval_depth = c->lisp_eval_depth;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1411
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1412 #ifdef DEFEND_AGAINST_THROW_RECURSION
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1413 throw_level = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1414 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1415 LONGJMP (c->jmp, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1416 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1417
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1418 static DOESNT_RETURN
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1419 throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1420 Lisp_Object sig, Lisp_Object data)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1421 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1422 #ifdef DEFEND_AGAINST_THROW_RECURSION
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1423 /* die if we recurse more than is reasonable */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1424 if (++throw_level > 20)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
1425 abort ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1426 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1427
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1428 /* If bomb_out_p is t, this is being called from Fsignal as a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1429 "last resort" when there is no handler for this error and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1430 the debugger couldn't be invoked, so we are throwing to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1431 'top-level. If this tag doesn't exist (happens during the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1432 initialization stages) we would get in an infinite recursive
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1433 Fsignal/Fthrow loop, so instead we bomb out to the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1434 really-early-error-handler.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1435
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1436 Note that in fact the only time that the "last resort"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1437 occurs is when there's no catch for 'top-level -- the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1438 'top-level catch and the catch-all error handler are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1439 established at the same time, in initial_command_loop/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1440 top_level_1.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1441
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1442 #### Fix this horrifitude!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1443 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1444
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1445 while (1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1446 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1447 REGISTER struct catchtag *c;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1448
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1449 #if 0 /* FSFmacs */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1450 if (!NILP (tag)) /* #### */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1451 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1452 for (c = catchlist; c; c = c->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1453 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1454 if (EQ (c->tag, tag))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1455 unwind_to_catch (c, val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1456 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1457 if (!bomb_out_p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1458 tag = Fsignal (Qno_catch, list2 (tag, val));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1459 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1460 call1 (Qreally_early_error_handler, Fcons (sig, data));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1461 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1462
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1463 /* can't happen. who cares? - (Sun's compiler does) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1464 /* throw_level--; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1465 /* getting tired of compilation warnings */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1466 /* return Qnil; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1467 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1468
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1469 /* See above, where CATCHLIST is defined, for a description of how
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1470 Fthrow() works.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1471
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1472 Fthrow() is also called by Fsignal(), to do a non-local jump
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1473 back to the appropriate condition-case handler after (maybe)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1474 the debugger is entered. In that case, TAG is the value
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1475 of Vcondition_handlers that was in place just after the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1476 condition-case handler was set up. The car of this will be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1477 some data referring to the handler: Its car will be Qunbound
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1478 (thus, this tag can never be generated by Lisp code), and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1479 its CDR will be the HANDLERS argument to condition_case_1()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1480 (either Qerror, Qt, or a list of handlers as in `condition-case').
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1481 This works fine because Fthrow() does not care what TAG was
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1482 passed to it: it just looks up the catch list for something
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1483 that is EQ() to TAG. When it finds it, it will longjmp()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1484 back to the place that established the catch (in this case,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1485 condition_case_1). See below for more info.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1486 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1487
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1488 DEFUN ("throw", Fthrow, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1489 Throw to the catch for TAG and return VALUE from it.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1490 Both TAG and VALUE are evalled.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1491 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1492 (tag, value))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1493 {
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1494 throw_or_bomb_out (tag, value, 0, Qnil, Qnil); /* Doesn't return */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1495 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1496 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1497
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1498 DEFUN ("unwind-protect", Funwind_protect, 1, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1499 Do BODYFORM, protecting with UNWINDFORMS.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1500 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1501 If BODYFORM completes normally, its value is returned
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1502 after executing the UNWINDFORMS.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1503 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1504 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1505 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1506 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1507 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1508 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1509
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1510 record_unwind_protect (Fprogn, XCDR (args));
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
1511 return unbind_to_1 (speccount, Feval (XCAR (args)));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1512 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1513
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1514
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1515 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1516 /* Signalling and trapping errors */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1517 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1518
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1519 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1520 condition_bind_unwind (Lisp_Object loser)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1521 {
617
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1522 /* There is no problem freeing stuff here like there is in
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1523 condition_case_unwind(), because there are no outside pointers
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1524 (like the tag below in the catchlist) pointing to the objects. */
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1525 Lisp_Cons *victim;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1526 /* ((handler-fun . handler-args) ... other handlers) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1527 Lisp_Object tem = XCAR (loser);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1528
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1529 while (CONSP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1530 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1531 victim = XCONS (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1532 tem = victim->cdr;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1533 free_cons (victim);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1534 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1535 victim = XCONS (loser);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1536
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1537 if (EQ (loser, Vcondition_handlers)) /* may have been rebound to some tail */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1538 Vcondition_handlers = victim->cdr;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1539
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1540 free_cons (victim);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1541 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1542 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1543
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1544 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1545 condition_case_unwind (Lisp_Object loser)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1546 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1547 /* ((<unbound> . clauses) ... other handlers */
617
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1548 /* NO! Doing this now leaves the tag deleted in a still-active
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1549 catch. With the recent changes to unwind_to_catch(), the
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1550 evil situation might not happen any more; it certainly could
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1551 happen before because it did. But it's very precarious to rely
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1552 on something like this. #### Instead we should rewrite, adopting
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1553 the FSF's mechanism with a struct handler instead of
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1554 Vcondition_handlers; then we have NO Lisp-object structures used
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1555 to hold all of the values, and there's no possibility either of
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1556 crashes from freeing objects too quickly, or objects not getting
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1557 freed and hanging around till the next GC.
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1558
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1559 In practice, the extra consing here should not matter because
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1560 it only happens when we throw past the condition-case, which almost
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1561 always is the result of an error. Most of the time, there will be
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1562 no error, and we will free the objects below in the main function.
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1563
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1564 --ben
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1565
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1566 DO NOT DO: free_cons (XCAR (loser));
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1567 */
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1568
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1569 if (EQ (loser, Vcondition_handlers)) /* may have been rebound to some tail */
617
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1570 Vcondition_handlers = XCDR (loser);
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1571
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1572 /* DO NOT DO: free_cons (loser); */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1573 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1574 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1575
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1576 /* Split out from condition_case_3 so that primitive C callers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1577 don't have to cons up a lisp handler form to be evaluated. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1578
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1579 /* Call a function BFUN of one argument BARG, trapping errors as
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1580 specified by HANDLERS. If no error occurs that is indicated by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1581 HANDLERS as something to be caught, the return value of this
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1582 function is the return value from BFUN. If such an error does
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1583 occur, HFUN is called, and its return value becomes the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1584 return value of condition_case_1(). The second argument passed
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1585 to HFUN will always be HARG. The first argument depends on
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1586 HANDLERS:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1587
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1588 If HANDLERS is Qt, all errors (this includes QUIT, but not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1589 non-local exits with `throw') cause HFUN to be invoked, and VAL
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1590 (the first argument to HFUN) is a cons (SIG . DATA) of the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1591 arguments passed to `signal'. The debugger is not invoked even if
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1592 `debug-on-error' was set.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1593
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1594 A HANDLERS value of Qerror is the same as Qt except that the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1595 debugger is invoked if `debug-on-error' was set.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1596
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1597 Otherwise, HANDLERS should be a list of lists (CONDITION-NAME BODY ...)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1598 exactly as in `condition-case', and errors will be trapped
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1599 as indicated in HANDLERS. VAL (the first argument to HFUN) will
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1600 be a cons whose car is the cons (SIG . DATA) and whose CDR is the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1601 list (BODY ...) from the appropriate slot in HANDLERS.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1602
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1603 This function pushes HANDLERS onto the front of Vcondition_handlers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1604 (actually with a Qunbound marker as well -- see Fthrow() above
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1605 for why), establishes a catch whose tag is this new value of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1606 Vcondition_handlers, and calls BFUN. When Fsignal() is called,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1607 it calls Fthrow(), setting TAG to this same new value of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1608 Vcondition_handlers and setting VAL to the same thing that will
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1609 be passed to HFUN, as above. Fthrow() longjmp()s back to the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1610 jump point we just established, and we in turn just call the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1611 HFUN and return its value.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1612
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1613 For a real condition-case, HFUN will always be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1614 run_condition_case_handlers() and HARG is the argument VAR
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1615 to condition-case. That function just binds VAR to the cons
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1616 (SIG . DATA) that is the CAR of VAL, and calls the handler
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1617 (BODY ...) that is the CDR of VAL. Note that before calling
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1618 Fthrow(), Fsignal() restored Vcondition_handlers to the value
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1619 it had *before* condition_case_1() was called. This maintains
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1620 consistency (so that the state of things at exit of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1621 condition_case_1() is the same as at entry), and implies
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1622 that the handler can signal the same error again (possibly
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1623 after processing of its own), without getting in an infinite
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1624 loop. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1625
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1626 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1627 condition_case_1 (Lisp_Object handlers,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1628 Lisp_Object (*bfun) (Lisp_Object barg),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1629 Lisp_Object barg,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1630 Lisp_Object (*hfun) (Lisp_Object val, Lisp_Object harg),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1631 Lisp_Object harg)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1632 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1633 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1634 struct catchtag c;
617
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1635 struct gcpro gcpro1, gcpro2, gcpro3;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1636
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1637 #if 0 /* FSFmacs */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1638 c.tag = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1639 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1640 /* Do consing now so out-of-memory error happens up front */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1641 /* (unbound . stuff) is a special condition-case kludge marker
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1642 which is known specially by Fsignal.
617
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1643 [[ This is an abomination, but to fix it would require either
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1644 making condition_case cons (a union of the conditions of the clauses)
617
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1645 or changing the byte-compiler output (no thanks).]]
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1646
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1647 The above comment is clearly wrong. FSF does not do it this way
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1648 and did not change the byte-compiler output. Instead they use a
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1649 `struct handler' to hold the various values (in place of our
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1650 Vcondition_handlers) and chain them together, with pointers from
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1651 the `struct catchtag' to the `struct handler'. We should perhaps
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1652 consider moving to something similar, but not before I merge my
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1653 stderr-proc workspace, which contains changes to these
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1654 functions. --ben */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1655 c.tag = noseeum_cons (noseeum_cons (Qunbound, handlers),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1656 Vcondition_handlers);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1657 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1658 c.val = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1659 c.backlist = backtrace_list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1660 #if 0 /* FSFmacs */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1661 /* #### */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1662 c.handlerlist = handlerlist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1663 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1664 c.lisp_eval_depth = lisp_eval_depth;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1665 c.pdlcount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1666 #if 0 /* FSFmacs */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1667 c.poll_suppress_count = async_timer_suppress_count;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1668 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1669 c.gcpro = gcprolist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1670 /* #### FSFmacs does the following statement *after* the setjmp(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1671 c.next = catchlist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1672
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1673 if (SETJMP (c.jmp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1674 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1675 /* throw does ungcpro, etc */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1676 return (*hfun) (c.val, harg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1677 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1678
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1679 record_unwind_protect (condition_case_unwind, c.tag);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1680
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1681 catchlist = &c;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1682 #if 0 /* FSFmacs */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1683 h.handler = handlers;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1684 h.var = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1685 h.next = handlerlist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1686 h.tag = &c;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1687 handlerlist = &h;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1688 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1689 Vcondition_handlers = c.tag;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1690 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1691 GCPRO1 (harg); /* Somebody has to gc-protect */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1692 c.val = ((*bfun) (barg));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1693 UNGCPRO;
617
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1694
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1695 /* Once we change `catchlist' below, the stuff in c will not be GCPRO'd. */
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1696 GCPRO3 (harg, c.val, c.tag);
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1697
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1698 catchlist = c.next;
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
1699 CHECK_ERROR_STATE_SANITY ();
617
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1700 /* Note: The unbind also resets Vcondition_handlers. Maybe we should
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1701 delete this here. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1702 Vcondition_handlers = XCDR (c.tag);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
1703 unbind_to (speccount);
617
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1704
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1705 UNGCPRO;
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1706 /* free the conses *after* the unbind, because the unbind will run
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1707 condition_case_unwind above. */
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1708 free_cons (XCONS (XCAR (c.tag)));
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1709 free_cons (XCONS (c.tag));
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1710 return c.val;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1711 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1712
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1713 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1714 run_condition_case_handlers (Lisp_Object val, Lisp_Object var)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1715 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1716 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1717 #if 0 /* FSFmacs */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1718 if (!NILP (h.var))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1719 specbind (h.var, c.val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1720 val = Fprogn (Fcdr (h.chosen_clause));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1721
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1722 /* Note that this just undoes the binding of h.var; whoever
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1723 longjmp()ed to us unwound the stack to c.pdlcount before
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1724 throwing. */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
1725 unbind_to (c.pdlcount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1726 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1727 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1728 int speccount;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1729
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1730 CHECK_TRUE_LIST (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1731 if (NILP (var))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1732 return Fprogn (Fcdr (val)); /* tail call */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1733
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1734 speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1735 specbind (var, Fcar (val));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1736 val = Fprogn (Fcdr (val));
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
1737 return unbind_to_1 (speccount, val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1738 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1739 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1740
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1741 /* Here for bytecode to call non-consfully. This is exactly like
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1742 condition-case except that it takes three arguments rather
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1743 than a single list of arguments. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1744 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1745 condition_case_3 (Lisp_Object bodyform, Lisp_Object var, Lisp_Object handlers)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1746 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1747 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1748 EXTERNAL_LIST_LOOP_2 (handler, handlers)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1749 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1750 if (NILP (handler))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1751 ;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1752 else if (CONSP (handler))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1753 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1754 Lisp_Object conditions = XCAR (handler);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1755 /* CONDITIONS must a condition name or a list of condition names */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1756 if (SYMBOLP (conditions))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1757 ;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1758 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1759 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1760 EXTERNAL_LIST_LOOP_2 (condition, conditions)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1761 if (!SYMBOLP (condition))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1762 goto invalid_condition_handler;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1763 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1764 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1765 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1766 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1767 invalid_condition_handler:
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
1768 sferror ("Invalid condition handler", handler);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1769 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1770 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1771
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1772 CHECK_SYMBOL (var);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1773
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1774 return condition_case_1 (handlers,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1775 Feval, bodyform,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1776 run_condition_case_handlers,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1777 var);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1778 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1779
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1780 DEFUN ("condition-case", Fcondition_case, 2, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1781 Regain control when an error is signalled.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1782 Usage looks like (condition-case VAR BODYFORM HANDLERS...).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1783 Executes BODYFORM and returns its value if no error happens.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1784 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1785 where the BODY is made of Lisp expressions.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1786
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
1787 A typical usage of `condition-case' looks like this:
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
1788
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
1789 (condition-case nil
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
1790 ;; you need a progn here if you want more than one statement ...
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
1791 (progn
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
1792 (do-something)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
1793 (do-something-else))
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
1794 (error
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
1795 (issue-warning-or)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
1796 ;; but strangely, you don't need one here.
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
1797 (return-a-value-etc)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
1798 ))
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
1799
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1800 A handler is applicable to an error if CONDITION-NAME is one of the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1801 error's condition names. If an error happens, the first applicable
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1802 handler is run. As a special case, a CONDITION-NAME of t matches
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1803 all errors, even those without the `error' condition name on them
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1804 \(e.g. `quit').
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1805
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1806 The car of a handler may be a list of condition names
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1807 instead of a single condition name.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1808
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1809 When a handler handles an error,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1810 control returns to the condition-case and the handler BODY... is executed
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1811 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1812 VAR may be nil; then you do not get access to the signal information.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1813
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1814 The value of the last BODY form is returned from the condition-case.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1815 See also the function `signal' for more info.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1816
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1817 Note that at the time the condition handler is invoked, the Lisp stack
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1818 and the current catches, condition-cases, and bindings have all been
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1819 popped back to the state they were in just before the call to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1820 `condition-case'. This means that resignalling the error from
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1821 within the handler will not result in an infinite loop.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1822
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1823 If you want to establish an error handler that is called with the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1824 Lisp stack, bindings, etc. as they were when `signal' was called,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1825 rather than when the handler was set, use `call-with-condition-handler'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1826 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1827 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1828 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1829 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1830 Lisp_Object var = XCAR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1831 Lisp_Object bodyform = XCAR (XCDR (args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1832 Lisp_Object handlers = XCDR (XCDR (args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1833 return condition_case_3 (bodyform, var, handlers);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1834 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1835
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1836 DEFUN ("call-with-condition-handler", Fcall_with_condition_handler, 2, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1837 Regain control when an error is signalled, without popping the stack.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1838 Usage looks like (call-with-condition-handler HANDLER FUNCTION &rest ARGS).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1839 This function is similar to `condition-case', but the handler is invoked
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1840 with the same environment (Lisp stack, bindings, catches, condition-cases)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1841 that was current when `signal' was called, rather than when the handler
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1842 was established.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1843
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1844 HANDLER should be a function of one argument, which is a cons of the args
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1845 \(SIG . DATA) that were passed to `signal'. It is invoked whenever
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1846 `signal' is called (this differs from `condition-case', which allows
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1847 you to specify which errors are trapped). If the handler function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1848 returns, `signal' continues as if the handler were never invoked.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1849 \(It continues to look for handlers established earlier than this one,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1850 and invokes the standard error-handler if none is found.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1851 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1852 (int nargs, Lisp_Object *args)) /* Note! Args side-effected! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1853 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1854 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1855 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1856 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1857
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1858 /* #### If there were a way to check that args[0] were a function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1859 which accepted one arg, that should be done here ... */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1860
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1861 /* (handler-fun . handler-args) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1862 tem = noseeum_cons (list1 (args[0]), Vcondition_handlers);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1863 record_unwind_protect (condition_bind_unwind, tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1864 Vcondition_handlers = tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1865
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1866 /* Caller should have GC-protected args */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
1867 return unbind_to_1 (speccount, Ffuncall (nargs - 1, args + 1));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1868 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1869
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1870 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1871 condition_type_p (Lisp_Object type, Lisp_Object conditions)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1872 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1873 if (EQ (type, Qt))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1874 /* (condition-case c # (t c)) catches -all- signals
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1875 * Use with caution! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1876 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1877
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1878 if (SYMBOLP (type))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1879 return !NILP (Fmemq (type, conditions));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1880
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1881 for (; CONSP (type); type = XCDR (type))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1882 if (!NILP (Fmemq (XCAR (type), conditions)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1883 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1884
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1885 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1886 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1887
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1888 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1889 return_from_signal (Lisp_Object value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1890 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1891 #if 1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1892 /* Most callers are not prepared to handle gc if this
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1893 returns. So, since this feature is not very useful,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1894 take it out. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1895 /* Have called debugger; return value to signaller */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1896 return value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1897 #else /* But the reality is that that stinks, because: */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1898 /* GACK!!! Really want some way for debug-on-quit errors
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1899 to be continuable!! */
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
1900 signal_error (Qunimplemented,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
1901 "Returning a value from an error is no longer supported",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
1902 Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1903 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1904 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1905
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1906 extern int in_display;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1907
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1908
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1909 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1910 /* the workhorse error-signaling function */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1911 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1912
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1913 /* #### This function has not been synched with FSF. It diverges
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1914 significantly. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1915
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1916 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1917 signal_1 (Lisp_Object sig, Lisp_Object data)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1918 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1919 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1920 struct gcpro gcpro1, gcpro2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1921 Lisp_Object conditions;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1922 Lisp_Object handlers;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1923 /* signal_call_debugger() could get called more than once
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1924 (once when a call-with-condition-handler is about to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1925 be dealt with, and another when a condition-case handler
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1926 is about to be invoked). So make sure the debugger and/or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1927 stack trace aren't done more than once. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1928 int stack_trace_displayed = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1929 int debugger_entered = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1930 GCPRO2 (conditions, handlers);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1931
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1932 if (!initialized)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1933 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1934 /* who knows how much has been initialized? Safest bet is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1935 just to bomb out immediately. */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
1936 stderr_out ("Error before initialization is complete!\n");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1937 abort ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1938 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1939
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1940 if (gc_in_progress || in_display)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1941 /* This is one of many reasons why you can't run lisp code from redisplay.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1942 There is no sensible way to handle errors there. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1943 abort ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1944
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1945 conditions = Fget (sig, Qerror_conditions, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1946
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1947 for (handlers = Vcondition_handlers;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1948 CONSP (handlers);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1949 handlers = XCDR (handlers))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1950 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1951 Lisp_Object handler_fun = XCAR (XCAR (handlers));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1952 Lisp_Object handler_data = XCDR (XCAR (handlers));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1953 Lisp_Object outer_handlers = XCDR (handlers);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1954
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1955 if (!UNBOUNDP (handler_fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1956 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1957 /* call-with-condition-handler */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1958 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1959 Lisp_Object all_handlers = Vcondition_handlers;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1960 struct gcpro ngcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1961 NGCPRO1 (all_handlers);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1962 Vcondition_handlers = outer_handlers;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1963
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1964 tem = signal_call_debugger (conditions, sig, data,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1965 outer_handlers, 1,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1966 &stack_trace_displayed,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1967 &debugger_entered);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1968 if (!UNBOUNDP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1969 RETURN_NUNGCPRO (return_from_signal (tem));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1970
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1971 tem = Fcons (sig, data);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1972 if (NILP (handler_data))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1973 tem = call1 (handler_fun, tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1974 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1975 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1976 /* (This code won't be used (for now?).) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1977 struct gcpro nngcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1978 Lisp_Object args[3];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1979 NNGCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1980 nngcpro1.nvars = 3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1981 args[0] = handler_fun;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1982 args[1] = tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1983 args[2] = handler_data;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1984 nngcpro1.var = args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1985 tem = Fapply (3, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1986 NNUNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1987 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1988 NUNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1989 #if 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1990 if (!EQ (tem, Qsignal))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1991 return return_from_signal (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1992 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1993 /* If handler didn't throw, try another handler */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1994 Vcondition_handlers = all_handlers;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1995 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1996
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1997 /* It's a condition-case handler */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1998
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1999 /* t is used by handlers for all conditions, set up by C code.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2000 * debugger is not called even if debug_on_error */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2001 else if (EQ (handler_data, Qt))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2002 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2003 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2004 return Fthrow (handlers, Fcons (sig, data));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2005 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2006 /* `error' is used similarly to the way `t' is used, but in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2007 addition it invokes the debugger if debug_on_error.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2008 This is normally used for the outer command-loop error
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2009 handler. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2010 else if (EQ (handler_data, Qerror))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2011 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2012 Lisp_Object tem = signal_call_debugger (conditions, sig, data,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2013 outer_handlers, 0,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2014 &stack_trace_displayed,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2015 &debugger_entered);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2016
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2017 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2018 if (!UNBOUNDP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2019 return return_from_signal (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2020
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2021 tem = Fcons (sig, data);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2022 return Fthrow (handlers, tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2023 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2024 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2025 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2026 /* handler established by real (Lisp) condition-case */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2027 Lisp_Object h;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2028
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2029 for (h = handler_data; CONSP (h); h = Fcdr (h))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2030 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2031 Lisp_Object clause = Fcar (h);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2032 Lisp_Object tem = Fcar (clause);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2033
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2034 if (condition_type_p (tem, conditions))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2035 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2036 tem = signal_call_debugger (conditions, sig, data,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2037 outer_handlers, 1,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2038 &stack_trace_displayed,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2039 &debugger_entered);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2040 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2041 if (!UNBOUNDP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2042 return return_from_signal (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2043
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2044 /* Doesn't return */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2045 tem = Fcons (Fcons (sig, data), Fcdr (clause));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2046 return Fthrow (handlers, tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2047 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2048 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2049 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2050 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2051
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2052 /* If no handler is present now, try to run the debugger,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2053 and if that fails, throw to top level.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2054
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2055 #### The only time that no handler is present is during
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2056 temacs or perhaps very early in XEmacs. In both cases,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2057 there is no 'top-level catch. (That's why the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2058 "bomb-out" hack was added.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2059
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2060 #### Fix this horrifitude!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2061 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2062 signal_call_debugger (conditions, sig, data, Qnil, 0,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2063 &stack_trace_displayed,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2064 &debugger_entered);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2065 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2066 throw_or_bomb_out (Qtop_level, Qt, 1, sig, data); /* Doesn't return */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2067 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2068 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2069
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2070
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2071 /****************** Error functions class 1 ******************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2072
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2073 /* Class 1: General functions that signal an error.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2074 These functions take an error type and a list of associated error
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2075 data. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2076
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2077 /* The simplest external error function: it would be called
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2078 signal_continuable_error_1() in the terminology below, but it's
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2079 Lisp-callable. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2080
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2081 DEFUN ("signal", Fsignal, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2082 Signal a continuable error. Args are ERROR-SYMBOL, and associated DATA.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2083 An error symbol is a symbol defined using `define-error'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2084 DATA should be a list. Its elements are printed as part of the error message.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2085 If the signal is handled, DATA is made available to the handler.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2086 See also the function `signal-error', and the functions to handle errors:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2087 `condition-case' and `call-with-condition-handler'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2088
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2089 Note that this function can return, if the debugger is invoked and the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2090 user invokes the "return from signal" option.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2091 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2092 (error_symbol, data))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2093 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2094 /* Fsignal() is one of these functions that's called all the time
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2095 with newly-created Lisp objects. We allow this; but we must GC-
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2096 protect the objects because all sorts of weird stuff could
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2097 happen. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2098
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2099 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2100
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2101 GCPRO1 (data);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2102 if (!NILP (Vcurrent_error_state))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2103 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2104 if (!NILP (Vcurrent_warning_class) && !NILP (Vcurrent_warning_level))
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2105 warn_when_safe_lispobj (Vcurrent_warning_class, Vcurrent_warning_level,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2106 Fcons (error_symbol, data));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2107 Fthrow (Qunbound_suspended_errors_tag, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2108 abort (); /* Better not get here! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2109 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2110 RETURN_UNGCPRO (signal_1 (error_symbol, data));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2111 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2112
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2113 /* Signal a non-continuable error. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2114
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2115 DOESNT_RETURN
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2116 signal_error_1 (Lisp_Object sig, Lisp_Object data)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2117 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2118 for (;;)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2119 Fsignal (sig, data);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2120 }
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
2121 #ifdef ERROR_CHECK_STRUCTURES
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
2122 static void
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2123 check_error_state_sanity (void)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2124 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2125 struct catchtag *c;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2126 int found_error_tag = 0;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2127
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2128 for (c = catchlist; c; c = c->next)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2129 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2130 if (EQ (c->tag, Qunbound_suspended_errors_tag))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2131 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2132 found_error_tag = 1;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2133 break;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2134 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2135 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2136
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2137 assert (found_error_tag || NILP (Vcurrent_error_state));
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2138 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2139 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2140
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2141 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2142 restore_current_warning_class (Lisp_Object warning_class)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2143 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2144 Vcurrent_warning_class = warning_class;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2145 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2146 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2147
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2148 static Lisp_Object
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2149 restore_current_warning_level (Lisp_Object warning_level)
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2150 {
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2151 Vcurrent_warning_level = warning_level;
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2152 return Qnil;
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2153 }
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2154
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2155 static Lisp_Object
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2156 restore_current_error_state (Lisp_Object error_state)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2157 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2158 Vcurrent_error_state = error_state;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2159 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2160 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2161
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2162 static Lisp_Object
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2163 call_with_suspended_errors_1 (Lisp_Object opaque_arg)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2164 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2165 Lisp_Object val;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2166 Lisp_Object *kludgy_args = (Lisp_Object *) get_opaque_ptr (opaque_arg);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2167 int speccount = specpdl_depth ();
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2168
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2169 if (NILP (Vcurrent_error_state))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2170 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2171 record_unwind_protect (restore_current_error_state,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2172 Vcurrent_error_state);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2173 Vcurrent_error_state = Qt;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2174 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2175 PRIMITIVE_FUNCALL (val, get_opaque_ptr (kludgy_args[0]),
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2176 kludgy_args + 2, XINT (kludgy_args[1]));
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
2177 return unbind_to_1 (speccount, val);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2178 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2179
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2180 /* Many functions would like to do one of three things if an error
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2181 occurs:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2182
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2183 (1) signal the error, as usual.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2184 (2) silently fail and return some error value.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2185 (3) do as (2) but issue a warning in the process.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2186
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
2187 Currently there's lots of stuff that passes an Error_Behavior
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2188 value and calls maybe_signal_error() and other such functions.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2189 This approach is inherently error-prone and broken. A much
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2190 more robust and easier approach is to use call_with_suspended_errors().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2191 Wrap this around any function in which you might want errors
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2192 to not be errors.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2193 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2194
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2195 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2196 call_with_suspended_errors (lisp_fn_t fun, volatile Lisp_Object retval,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
2197 Lisp_Object class, Error_Behavior errb,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2198 int nargs, ...)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2199 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2200 va_list vargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2201 int speccount;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2202 Lisp_Object kludgy_args[22];
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2203 Lisp_Object *args = kludgy_args + 2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2204 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2205
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2206 assert (SYMBOLP (class)); /* sanity-check */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2207 assert (!NILP (class));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2208 assert (nargs >= 0 && nargs < 20);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2209
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2210 va_start (vargs, nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2211 for (i = 0; i < nargs; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2212 args[i] = va_arg (vargs, Lisp_Object);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2213 va_end (vargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2214
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2215 /* ERROR_ME means don't trap errors. (However, if errors are
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2216 already trapped, we leave them trapped.)
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2217
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2218 Otherwise, we trap errors, and display as warnings if ERROR_ME_WARN.
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2219
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2220 If ERROR_ME_NOT, we silently fail.
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2221
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2222 If ERROR_ME_DEBUG_WARN, we display a warning, but at warning level to
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2223 `debug'. Normally these disappear, but can be seen if we changed
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2224 log-warning-minimum-level.
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2225 */
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2226
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2227 /* If error-checking is not disabled, just call the function.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2228 It's important not to override disabled error-checking with
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2229 enabled error-checking. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2230
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2231 if (ERRB_EQ (errb, ERROR_ME))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2232 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2233 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2234 PRIMITIVE_FUNCALL (val, fun, args, nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2235 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2236 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2237
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2238 speccount = specpdl_depth ();
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2239 if (NILP (Vcurrent_warning_class))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2240 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2241 /* Don't change the existing class.
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2242 #### Should we be consing the two together? */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2243 record_unwind_protect (restore_current_warning_class,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2244 Vcurrent_warning_class);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2245 Vcurrent_warning_class = class;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2246 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2247
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2248 record_unwind_protect (restore_current_warning_level,
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2249 Vcurrent_warning_level);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2250 Vcurrent_warning_level =
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2251 (ERRB_EQ (errb, ERROR_ME_NOT) ? Qnil :
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2252 ERRB_EQ (errb, ERROR_ME_DEBUG_WARN) ? Qdebug :
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2253 Qwarning);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2254
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2255
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2256 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2257 int threw;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2258 Lisp_Object the_retval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2259 Lisp_Object opaque1 = make_opaque_ptr (kludgy_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2260 Lisp_Object opaque2 = make_opaque_ptr ((void *) fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2261 struct gcpro gcpro1, gcpro2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2262
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2263 GCPRO2 (opaque1, opaque2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2264 kludgy_args[0] = opaque2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2265 kludgy_args[1] = make_int (nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2266 the_retval = internal_catch (Qunbound_suspended_errors_tag,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2267 call_with_suspended_errors_1,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2268 opaque1, &threw);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2269 free_opaque_ptr (opaque1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2270 free_opaque_ptr (opaque2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2271 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2272 /* Use the returned value except in non-local exit, when
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2273 RETVAL applies. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2274 /* Some perverse compilers require the perverse cast below. */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
2275 return unbind_to_1 (speccount,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2276 threw ? *((Lisp_Object*) &(retval)) : the_retval);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2277 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2278 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2279
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2280 /* Signal a non-continuable error or display a warning or do nothing,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2281 according to ERRB. CLASS is the class of warning and should
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2282 refer to what sort of operation is being done (e.g. Qtoolbar,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2283 Qresource, etc.). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2284
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2285 void
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2286 maybe_signal_error_1 (Lisp_Object sig, Lisp_Object data, Lisp_Object class,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
2287 Error_Behavior errb)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2288 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2289 if (ERRB_EQ (errb, ERROR_ME_NOT))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2290 return;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2291 else if (ERRB_EQ (errb, ERROR_ME_DEBUG_WARN))
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2292 warn_when_safe_lispobj (class, Qdebug, Fcons (sig, data));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2293 else if (ERRB_EQ (errb, ERROR_ME_WARN))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2294 warn_when_safe_lispobj (class, Qwarning, Fcons (sig, data));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2295 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2296 for (;;)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2297 Fsignal (sig, data);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2298 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2299
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2300 /* Signal a continuable error or display a warning or do nothing,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2301 according to ERRB. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2302
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2303 Lisp_Object
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2304 maybe_signal_continuable_error_1 (Lisp_Object sig, Lisp_Object data,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
2305 Lisp_Object class, Error_Behavior errb)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2306 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2307 if (ERRB_EQ (errb, ERROR_ME_NOT))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2308 return Qnil;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2309 else if (ERRB_EQ (errb, ERROR_ME_DEBUG_WARN))
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2310 {
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2311 warn_when_safe_lispobj (class, Qdebug, Fcons (sig, data));
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2312 return Qnil;
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2313 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2314 else if (ERRB_EQ (errb, ERROR_ME_WARN))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2315 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2316 warn_when_safe_lispobj (class, Qwarning, Fcons (sig, data));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2317 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2318 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2319 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2320 return Fsignal (sig, data);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2321 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2322
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2323
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2324 /****************** Error functions class 2 ******************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2325
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2326 /* Class 2: Signal an error with a string and an associated object.
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2327 Normally these functions are used to attach one associated object,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2328 but to attach no objects, specify Qunbound for FROB, and for more
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2329 than one object, make a list of the objects with Qunbound as the
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2330 first element. (If you have specifically two objects to attach,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2331 consider using the function in class 3 below.) These functions
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2332 signal an error of a specified type, whose data is one or more
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2333 objects (usually two), a string the related Lisp object(s)
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2334 specified as FROB. */
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2335
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2336 /* Out of REASON and FROB, return a list of elements suitable for passing
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2337 to signal_error_1(). */
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2338
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2339 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2340 build_error_data (const CIntbyte *reason, Lisp_Object frob)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2341 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2342 if (EQ (frob, Qunbound))
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2343 frob = Qnil;
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2344 else if (CONSP (frob) && EQ (XCAR (frob), Qunbound))
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2345 frob = XCDR (frob);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2346 else
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2347 frob = list1 (frob);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2348 if (!reason)
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2349 return frob;
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2350 else
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
2351 return Fcons (build_msg_string (reason), frob);
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2352 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2353
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2354 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2355 signal_error (Lisp_Object type, const CIntbyte *reason, Lisp_Object frob)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2356 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2357 signal_error_1 (type, build_error_data (reason, frob));
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2358 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2359
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2360 void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2361 maybe_signal_error (Lisp_Object type, const CIntbyte *reason,
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2362 Lisp_Object frob, Lisp_Object class,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
2363 Error_Behavior errb)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2364 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2365 /* Optimization: */
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2366 if (ERRB_EQ (errb, ERROR_ME_NOT))
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2367 return;
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2368 maybe_signal_error_1 (type, build_error_data (reason, frob), class, errb);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2369 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2370
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2371 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2372 signal_continuable_error (Lisp_Object type, const CIntbyte *reason,
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2373 Lisp_Object frob)
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2374 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2375 return Fsignal (type, build_error_data (reason, frob));
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2376 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2377
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2378 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2379 maybe_signal_continuable_error (Lisp_Object type, const CIntbyte *reason,
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2380 Lisp_Object frob, Lisp_Object class,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
2381 Error_Behavior errb)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2382 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2383 /* Optimization: */
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2384 if (ERRB_EQ (errb, ERROR_ME_NOT))
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2385 return Qnil;
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2386 return maybe_signal_continuable_error_1 (type,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2387 build_error_data (reason, frob),
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2388 class, errb);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2389 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2390
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2391
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2392 /****************** Error functions class 3 ******************/
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2393
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2394 /* Class 3: Signal an error with a string and two associated objects.
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2395 These functions signal an error of a specified type, whose data
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2396 is three objects, a string and two related Lisp objects.
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2397 (The equivalent could be accomplished using the class 2 functions,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2398 but these are more convenient in this particular case.) */
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2399
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2400 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2401 signal_error_2 (Lisp_Object type, const CIntbyte *reason,
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2402 Lisp_Object frob0, Lisp_Object frob1)
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2403 {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
2404 signal_error_1 (type, list3 (build_msg_string (reason), frob0,
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2405 frob1));
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2406 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2407
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2408 void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2409 maybe_signal_error_2 (Lisp_Object type, const CIntbyte *reason,
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2410 Lisp_Object frob0, Lisp_Object frob1,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
2411 Lisp_Object class, Error_Behavior errb)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2412 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2413 /* Optimization: */
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2414 if (ERRB_EQ (errb, ERROR_ME_NOT))
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2415 return;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
2416 maybe_signal_error_1 (type, list3 (build_msg_string (reason), frob0,
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2417 frob1), class, errb);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2418 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2419
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2420 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2421 signal_continuable_error_2 (Lisp_Object type, const CIntbyte *reason,
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2422 Lisp_Object frob0, Lisp_Object frob1)
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2423 {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
2424 return Fsignal (type, list3 (build_msg_string (reason), frob0,
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2425 frob1));
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2426 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2427
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2428 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2429 maybe_signal_continuable_error_2 (Lisp_Object type, const CIntbyte *reason,
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2430 Lisp_Object frob0, Lisp_Object frob1,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
2431 Lisp_Object class, Error_Behavior errb)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2432 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2433 /* Optimization: */
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2434 if (ERRB_EQ (errb, ERROR_ME_NOT))
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2435 return Qnil;
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2436 return maybe_signal_continuable_error_1
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
2437 (type, list3 (build_msg_string (reason), frob0, frob1),
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2438 class, errb);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2439 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2440
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2441
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2442 /****************** Error functions class 4 ******************/
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2443
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2444 /* Class 4: Printf-like functions that signal an error.
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2445 These functions signal an error of a specified type, whose data
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2446 is a single string, created using the arguments. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2447
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2448 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2449 signal_ferror (Lisp_Object type, const CIntbyte *fmt, ...)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2450 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2451 Lisp_Object obj;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2452 va_list args;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2453
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2454 va_start (args, fmt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
2455 obj = emacs_vsprintf_string (CGETTEXT (fmt), args);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2456 va_end (args);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2457
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2458 /* Fsignal GC-protects its args */
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2459 signal_error (type, 0, obj);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2460 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2461
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2462 void
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
2463 maybe_signal_ferror (Lisp_Object type, Lisp_Object class, Error_Behavior errb,
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2464 const CIntbyte *fmt, ...)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2465 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2466 Lisp_Object obj;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2467 va_list args;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2468
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2469 /* Optimization: */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2470 if (ERRB_EQ (errb, ERROR_ME_NOT))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2471 return;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2472
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2473 va_start (args, fmt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
2474 obj = emacs_vsprintf_string (CGETTEXT (fmt), args);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2475 va_end (args);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2476
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2477 /* Fsignal GC-protects its args */
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2478 maybe_signal_error (type, 0, obj, class, errb);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2479 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2480
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2481 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2482 signal_continuable_ferror (Lisp_Object type, const CIntbyte *fmt, ...)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2483 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2484 Lisp_Object obj;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2485 va_list args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2486
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2487 va_start (args, fmt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
2488 obj = emacs_vsprintf_string (CGETTEXT (fmt), args);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2489 va_end (args);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2490
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2491 /* Fsignal GC-protects its args */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2492 return Fsignal (type, list1 (obj));
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2493 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2494
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2495 Lisp_Object
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2496 maybe_signal_continuable_ferror (Lisp_Object type, Lisp_Object class,
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2497 Error_Behavior errb, const CIntbyte *fmt, ...)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2498 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2499 Lisp_Object obj;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2500 va_list args;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2501
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2502 /* Optimization: */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2503 if (ERRB_EQ (errb, ERROR_ME_NOT))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2504 return Qnil;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2505
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2506 va_start (args, fmt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
2507 obj = emacs_vsprintf_string (CGETTEXT (fmt), args);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2508 va_end (args);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2509
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2510 /* Fsignal GC-protects its args */
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2511 return maybe_signal_continuable_error (type, 0, obj, class, errb);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2512 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2513
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2514
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2515 /****************** Error functions class 5 ******************/
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2516
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2517 /* Class 5: Printf-like functions that signal an error.
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2518 These functions signal an error of a specified type, whose data
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2519 is a one or more objects, a string (created using the arguments)
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2520 and additional Lisp objects specified in FROB. (The syntax of FROB
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2521 is the same as for class 2.)
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2522
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2523 There is no need for a class 6 because you can always attach 2
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2524 objects using class 5 (for FROB, specify a list with three
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2525 elements, the first of which is Qunbound), and these functions are
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2526 not commonly used.
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2527 */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2528
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2529 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2530 signal_ferror_with_frob (Lisp_Object type, Lisp_Object frob, const CIntbyte *fmt,
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2531 ...)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2532 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2533 Lisp_Object obj;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2534 va_list args;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2535
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2536 va_start (args, fmt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
2537 obj = emacs_vsprintf_string (CGETTEXT (fmt), args);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2538 va_end (args);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2539
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2540 /* Fsignal GC-protects its args */
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2541 signal_error_1 (type, Fcons (obj, build_error_data (0, frob)));
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2542 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2543
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2544 void
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2545 maybe_signal_ferror_with_frob (Lisp_Object type, Lisp_Object frob,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
2546 Lisp_Object class, Error_Behavior errb,
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2547 const CIntbyte *fmt, ...)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2548 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2549 Lisp_Object obj;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2550 va_list args;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2551
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2552 /* Optimization: */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2553 if (ERRB_EQ (errb, ERROR_ME_NOT))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2554 return;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2555
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2556 va_start (args, fmt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
2557 obj = emacs_vsprintf_string (CGETTEXT (fmt), args);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2558 va_end (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2559
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2560 /* Fsignal GC-protects its args */
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2561 maybe_signal_error_1 (type, Fcons (obj, build_error_data (0, frob)), class,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2562 errb);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2563 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2564
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2565 Lisp_Object
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2566 signal_continuable_ferror_with_frob (Lisp_Object type, Lisp_Object frob,
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2567 const CIntbyte *fmt, ...)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2568 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2569 Lisp_Object obj;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2570 va_list args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2571
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2572 va_start (args, fmt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
2573 obj = emacs_vsprintf_string (CGETTEXT (fmt), args);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2574 va_end (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2575
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2576 /* Fsignal GC-protects its args */
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2577 return Fsignal (type, Fcons (obj, build_error_data (0, frob)));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2578 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2579
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2580 Lisp_Object
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2581 maybe_signal_continuable_ferror_with_frob (Lisp_Object type, Lisp_Object frob,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2582 Lisp_Object class,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
2583 Error_Behavior errb,
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2584 const CIntbyte *fmt, ...)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2585 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2586 Lisp_Object obj;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2587 va_list args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2588
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2589 /* Optimization: */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2590 if (ERRB_EQ (errb, ERROR_ME_NOT))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2591 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2592
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2593 va_start (args, fmt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
2594 obj = emacs_vsprintf_string (CGETTEXT (fmt), args);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2595 va_end (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2596
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2597 /* Fsignal GC-protects its args */
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2598 return maybe_signal_continuable_error_1 (type,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2599 Fcons (obj,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2600 build_error_data (0, frob)),
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2601 class, errb);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2602 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2603
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2604
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2605 /* This is what the QUIT macro calls to signal a quit */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2606 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2607 signal_quit (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2608 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2609 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2610 if (EQ (Vquit_flag, Qcritical))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2611 debug_on_quit |= 2; /* set critical bit. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2612 Vquit_flag = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2613 /* note that this is continuable. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2614 Fsignal (Qquit, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2615 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2616
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2617
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2618 /************************ convenience error functions ***********************/
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2619
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
2620 Lisp_Object
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2621 signal_void_function_error (Lisp_Object function)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2622 {
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
2623 return Fsignal (Qvoid_function, list1 (function));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2624 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2625
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
2626 Lisp_Object
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2627 signal_invalid_function_error (Lisp_Object function)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2628 {
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
2629 return Fsignal (Qinvalid_function, list1 (function));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2630 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2631
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
2632 Lisp_Object
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2633 signal_wrong_number_of_arguments_error (Lisp_Object function, int nargs)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2634 {
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
2635 return Fsignal (Qwrong_number_of_arguments,
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
2636 list2 (function, make_int (nargs)));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2637 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2638
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2639 /* Used in list traversal macros for efficiency. */
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
2640 DOESNT_RETURN
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2641 signal_malformed_list_error (Lisp_Object list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2642 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2643 signal_error (Qmalformed_list, 0, list);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2644 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2645
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
2646 DOESNT_RETURN
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2647 signal_malformed_property_list_error (Lisp_Object list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2648 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2649 signal_error (Qmalformed_property_list, 0, list);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2650 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2651
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
2652 DOESNT_RETURN
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2653 signal_circular_list_error (Lisp_Object list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2654 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2655 signal_error (Qcircular_list, 0, list);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2656 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2657
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
2658 DOESNT_RETURN
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2659 signal_circular_property_list_error (Lisp_Object list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2660 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2661 signal_error (Qcircular_property_list, 0, list);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2662 }
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2663
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2664 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2665 syntax_error (const CIntbyte *reason, Lisp_Object frob)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2666 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2667 signal_error (Qsyntax_error, reason, frob);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2668 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2669
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2670 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2671 syntax_error_2 (const CIntbyte *reason, Lisp_Object frob1, Lisp_Object frob2)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2672 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2673 signal_error_2 (Qsyntax_error, reason, frob1, frob2);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2674 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2675
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2676 void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2677 maybe_syntax_error (const CIntbyte *reason, Lisp_Object frob,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
2678 Lisp_Object class, Error_Behavior errb)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2679 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2680 maybe_signal_error (Qsyntax_error, reason, frob, class, errb);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2681 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2682
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2683 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2684 sferror (const CIntbyte *reason, Lisp_Object frob)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2685 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2686 signal_error (Qstructure_formation_error, reason, frob);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2687 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2688
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2689 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2690 sferror_2 (const CIntbyte *reason, Lisp_Object frob1, Lisp_Object frob2)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2691 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2692 signal_error_2 (Qstructure_formation_error, reason, frob1, frob2);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2693 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2694
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2695 void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2696 maybe_sferror (const CIntbyte *reason, Lisp_Object frob,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
2697 Lisp_Object class, Error_Behavior errb)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2698 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2699 maybe_signal_error (Qstructure_formation_error, reason, frob, class, errb);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2700 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2701
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2702 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2703 invalid_argument (const CIntbyte *reason, Lisp_Object frob)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2704 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2705 signal_error (Qinvalid_argument, reason, frob);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2706 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2707
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2708 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2709 invalid_argument_2 (const CIntbyte *reason, Lisp_Object frob1,
609
13e3d7ae7155 [xemacs-hg @ 2001-06-06 12:34:42 by ben]
ben
parents: 578
diff changeset
2710 Lisp_Object frob2)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2711 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2712 signal_error_2 (Qinvalid_argument, reason, frob1, frob2);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2713 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2714
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2715 void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2716 maybe_invalid_argument (const CIntbyte *reason, Lisp_Object frob,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
2717 Lisp_Object class, Error_Behavior errb)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2718 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2719 maybe_signal_error (Qinvalid_argument, reason, frob, class, errb);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2720 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2721
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2722 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2723 invalid_constant (const CIntbyte *reason, Lisp_Object frob)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2724 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2725 signal_error (Qinvalid_constant, reason, frob);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2726 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2727
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2728 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2729 invalid_constant_2 (const CIntbyte *reason, Lisp_Object frob1,
609
13e3d7ae7155 [xemacs-hg @ 2001-06-06 12:34:42 by ben]
ben
parents: 578
diff changeset
2730 Lisp_Object frob2)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2731 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2732 signal_error_2 (Qinvalid_constant, reason, frob1, frob2);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2733 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2734
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2735 void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2736 maybe_invalid_constant (const CIntbyte *reason, Lisp_Object frob,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
2737 Lisp_Object class, Error_Behavior errb)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2738 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2739 maybe_signal_error (Qinvalid_constant, reason, frob, class, errb);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2740 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2741
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2742 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2743 invalid_operation (const CIntbyte *reason, Lisp_Object frob)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2744 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2745 signal_error (Qinvalid_operation, reason, frob);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2746 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2747
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2748 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2749 invalid_operation_2 (const CIntbyte *reason, Lisp_Object frob1,
609
13e3d7ae7155 [xemacs-hg @ 2001-06-06 12:34:42 by ben]
ben
parents: 578
diff changeset
2750 Lisp_Object frob2)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2751 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2752 signal_error_2 (Qinvalid_operation, reason, frob1, frob2);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2753 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2754
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2755 void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2756 maybe_invalid_operation (const CIntbyte *reason, Lisp_Object frob,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
2757 Lisp_Object class, Error_Behavior errb)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2758 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2759 maybe_signal_error (Qinvalid_operation, reason, frob, class, errb);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2760 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2761
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2762 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2763 invalid_change (const CIntbyte *reason, Lisp_Object frob)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2764 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2765 signal_error (Qinvalid_change, reason, frob);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2766 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2767
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2768 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2769 invalid_change_2 (const CIntbyte *reason, Lisp_Object frob1, Lisp_Object frob2)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2770 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2771 signal_error_2 (Qinvalid_change, reason, frob1, frob2);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2772 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2773
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2774 void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2775 maybe_invalid_change (const CIntbyte *reason, Lisp_Object frob,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
2776 Lisp_Object class, Error_Behavior errb)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2777 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2778 maybe_signal_error (Qinvalid_change, reason, frob, class, errb);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2779 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2780
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2781 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2782 invalid_state (const CIntbyte *reason, Lisp_Object frob)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2783 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2784 signal_error (Qinvalid_state, reason, frob);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2785 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2786
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2787 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2788 invalid_state_2 (const CIntbyte *reason, Lisp_Object frob1, Lisp_Object frob2)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2789 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2790 signal_error_2 (Qinvalid_state, reason, frob1, frob2);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2791 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2792
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2793 void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2794 maybe_invalid_state (const CIntbyte *reason, Lisp_Object frob,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
2795 Lisp_Object class, Error_Behavior errb)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2796 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2797 maybe_signal_error (Qinvalid_state, reason, frob, class, errb);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2798 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2799
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2800 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2801 wtaerror (const CIntbyte *reason, Lisp_Object frob)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2802 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2803 signal_error (Qwrong_type_argument, reason, frob);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2804 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2805
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2806 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2807 stack_overflow (const CIntbyte *reason, Lisp_Object frob)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2808 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2809 signal_error (Qstack_overflow, reason, frob);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2810 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2811
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2812 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2813 out_of_memory (const CIntbyte *reason, Lisp_Object frob)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2814 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2815 signal_error (Qout_of_memory, reason, frob);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2816 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2817
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2818 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2819 printing_unreadable_object (const CIntbyte *fmt, ...)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2820 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2821 Lisp_Object obj;
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2822 va_list args;
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2823
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2824 va_start (args, fmt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
2825 obj = emacs_vsprintf_string (CGETTEXT (fmt), args);
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2826 va_end (args);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2827
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2828 /* Fsignal GC-protects its args */
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2829 signal_error (Qprinting_unreadable_object, 0, obj);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2830 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2831
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2832
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2833 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2834 /* User commands */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2835 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2836
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2837 DEFUN ("commandp", Fcommandp, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2838 Return t if FUNCTION makes provisions for interactive calling.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2839 This means it contains a description for how to read arguments to give it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2840 The value is nil for an invalid function or a symbol with no function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2841 definition.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2842
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2843 Interactively callable functions include
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2844
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2845 -- strings and vectors (treated as keyboard macros)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2846 -- lambda-expressions that contain a top-level call to `interactive'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2847 -- autoload definitions made by `autoload' with non-nil fourth argument
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2848 (i.e. the interactive flag)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2849 -- compiled-function objects with a non-nil `compiled-function-interactive'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2850 value
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2851 -- subrs (built-in functions) that are interactively callable
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2852
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2853 Also, a symbol satisfies `commandp' if its function definition does so.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2854 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2855 (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2856 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2857 Lisp_Object fun = indirect_function (function, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2858
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2859 if (COMPILED_FUNCTIONP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2860 return XCOMPILED_FUNCTION (fun)->flags.interactivep ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2861
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2862 /* Lists may represent commands. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2863 if (CONSP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2864 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2865 Lisp_Object funcar = XCAR (fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2866 if (EQ (funcar, Qlambda))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2867 return Fassq (Qinteractive, Fcdr (Fcdr (fun)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2868 if (EQ (funcar, Qautoload))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2869 return Fcar (Fcdr (Fcdr (Fcdr (fun))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2870 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2871 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2872 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2873
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2874 /* Emacs primitives are interactive if their DEFUN specifies an
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2875 interactive spec. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2876 if (SUBRP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2877 return XSUBR (fun)->prompt ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2878
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2879 /* Strings and vectors are keyboard macros. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2880 if (VECTORP (fun) || STRINGP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2881 return Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2882
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2883 /* Everything else (including Qunbound) is not a command. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2884 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2885 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2886
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2887 DEFUN ("command-execute", Fcommand_execute, 1, 3, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2888 Execute CMD as an editor command.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2889 CMD must be an object that satisfies the `commandp' predicate.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2890 Optional second arg RECORD-FLAG is as in `call-interactively'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2891 The argument KEYS specifies the value to use instead of (this-command-keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2892 when reading the arguments.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2893 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2894 (cmd, record_flag, keys))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2895 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2896 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2897 Lisp_Object prefixarg;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2898 Lisp_Object final = cmd;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2899 struct backtrace backtrace;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2900 struct console *con = XCONSOLE (Vselected_console);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2901
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2902 prefixarg = con->prefix_arg;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2903 con->prefix_arg = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2904 Vcurrent_prefix_arg = prefixarg;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2905 debug_on_next_call = 0; /* #### from FSFmacs; correct? */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2906
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2907 if (SYMBOLP (cmd) && !NILP (Fget (cmd, Qdisabled, Qnil)))
733
b1f74adcc1ff [xemacs-hg @ 2002-01-22 20:40:00 by janv]
janv
parents: 665
diff changeset
2908 return run_hook (Qdisabled_command_hook);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2909
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2910 for (;;)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2911 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2912 final = indirect_function (cmd, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2913 if (CONSP (final) && EQ (Fcar (final), Qautoload))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2914 do_autoload (final, cmd);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2915 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2916 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2917 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2918
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2919 if (CONSP (final) || SUBRP (final) || COMPILED_FUNCTIONP (final))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2920 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2921 backtrace.function = &Qcall_interactively;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2922 backtrace.args = &cmd;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2923 backtrace.nargs = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2924 backtrace.evalargs = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2925 backtrace.pdlcount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2926 backtrace.debug_on_exit = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2927 PUSH_BACKTRACE (backtrace);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2928
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2929 final = Fcall_interactively (cmd, record_flag, keys);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2930
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2931 POP_BACKTRACE (backtrace);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2932 return final;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2933 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2934 else if (STRINGP (final) || VECTORP (final))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2935 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2936 return Fexecute_kbd_macro (final, prefixarg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2937 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2938 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2939 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2940 Fsignal (Qwrong_type_argument,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2941 Fcons (Qcommandp,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2942 (EQ (cmd, final)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2943 ? list1 (cmd)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2944 : list2 (cmd, final))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2945 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2946 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2947 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2948
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2949 DEFUN ("interactive-p", Finteractive_p, 0, 0, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2950 Return t if function in which this appears was called interactively.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2951 This means that the function was called with call-interactively (which
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2952 includes being called as the binding of a key)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2953 and input is currently coming from the keyboard (not in keyboard macro).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2954 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2955 ())
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2956 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2957 REGISTER struct backtrace *btp;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2958 REGISTER Lisp_Object fun;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2959
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2960 if (!INTERACTIVE)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2961 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2962
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2963 /* Unless the object was compiled, skip the frame of interactive-p itself
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2964 (if interpreted) or the frame of byte-code (if called from a compiled
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2965 function). Note that *btp->function may be a symbol pointing at a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2966 compiled function. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2967 btp = backtrace_list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2968
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2969 #if 0 /* FSFmacs */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2970
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2971 /* #### FSFmacs does the following instead. I can't figure
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2972 out which one is more correct. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2973 /* If this isn't a byte-compiled function, there may be a frame at
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2974 the top for Finteractive_p itself. If so, skip it. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2975 fun = Findirect_function (*btp->function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2976 if (SUBRP (fun) && XSUBR (fun) == &Sinteractive_p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2977 btp = btp->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2978
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2979 /* If we're running an Emacs 18-style byte-compiled function, there
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2980 may be a frame for Fbyte_code. Now, given the strictest
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2981 definition, this function isn't really being called
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2982 interactively, but because that's the way Emacs 18 always builds
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2983 byte-compiled functions, we'll accept it for now. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2984 if (EQ (*btp->function, Qbyte_code))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2985 btp = btp->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2986
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2987 /* If this isn't a byte-compiled function, then we may now be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2988 looking at several frames for special forms. Skip past them. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2989 while (btp &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2990 btp->nargs == UNEVALLED)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2991 btp = btp->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2992
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2993 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2994
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2995 if (! (COMPILED_FUNCTIONP (Findirect_function (*btp->function))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2996 btp = btp->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2997 for (;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2998 btp && (btp->nargs == UNEVALLED
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2999 || EQ (*btp->function, Qbyte_code));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3000 btp = btp->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3001 {}
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3002 /* btp now points at the frame of the innermost function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3003 that DOES eval its args.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3004 If it is a built-in function (such as load or eval-region)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3005 return nil. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3006 /* Beats me why this is necessary, but it is */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3007 if (btp && EQ (*btp->function, Qcall_interactively))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3008 return Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3009
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3010 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3011
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3012 fun = Findirect_function (*btp->function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3013 if (SUBRP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3014 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3015 /* btp points to the frame of a Lisp function that called interactive-p.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3016 Return t if that function was called interactively. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3017 if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3018 return Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3019 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3020 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3021
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3022
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3023 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3024 /* Autoloading */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3025 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3026
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3027 DEFUN ("autoload", Fautoload, 2, 5, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3028 Define FUNCTION to autoload from FILENAME.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3029 FUNCTION is a symbol; FILENAME is a file name string to pass to `load'.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3030 The remaining optional arguments provide additional info about the
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3031 real definition.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3032 DOCSTRING is documentation for FUNCTION.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3033 INTERACTIVE, if non-nil, says FUNCTION can be called interactively.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3034 TYPE indicates the type of the object:
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3035 nil or omitted says FUNCTION is a function,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3036 `keymap' says FUNCTION is really a keymap, and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3037 `macro' or t says FUNCTION is really a macro.
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3038 If FUNCTION already has a non-void function definition that is not an
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3039 autoload object, this function does nothing and returns nil.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3040 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3041 (function, filename, docstring, interactive, type))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3042 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3043 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3044 CHECK_SYMBOL (function);
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3045 CHECK_STRING (filename);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3046
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3047 /* If function is defined and not as an autoload, don't override */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3048 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3049 Lisp_Object f = XSYMBOL (function)->function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3050 if (!UNBOUNDP (f) && !(CONSP (f) && EQ (XCAR (f), Qautoload)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3051 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3052 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3053
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3054 if (purify_flag)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3055 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3056 /* Attempt to avoid consing identical (string=) pure strings. */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3057 filename = Fsymbol_name (Fintern (filename, Qnil));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3058 }
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3059
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3060 return Ffset (function, Fcons (Qautoload, list4 (filename,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3061 docstring,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3062 interactive,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3063 type)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3064 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3065
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3066 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3067 un_autoload (Lisp_Object oldqueue)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3068 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3069 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3070 REGISTER Lisp_Object queue, first, second;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3071
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3072 /* Queue to unwind is current value of Vautoload_queue.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3073 oldqueue is the shadowed value to leave in Vautoload_queue. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3074 queue = Vautoload_queue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3075 Vautoload_queue = oldqueue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3076 while (CONSP (queue))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3077 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3078 first = XCAR (queue);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3079 second = Fcdr (first);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3080 first = Fcar (first);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3081 if (NILP (second))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3082 Vfeatures = first;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3083 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3084 Ffset (first, second);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3085 queue = Fcdr (queue);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3086 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3087 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3088 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3089
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3090 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3091 do_autoload (Lisp_Object fundef,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3092 Lisp_Object funname)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3093 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3094 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3095 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3096 Lisp_Object fun = funname;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3097 struct gcpro gcpro1, gcpro2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3098
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3099 CHECK_SYMBOL (funname);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3100 GCPRO2 (fun, funname);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3101
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3102 /* Value saved here is to be restored into Vautoload_queue */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3103 record_unwind_protect (un_autoload, Vautoload_queue);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3104 Vautoload_queue = Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3105 call4 (Qload, Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3106
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3107 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3108 Lisp_Object queue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3109
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3110 /* Save the old autoloads, in case we ever do an unload. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3111 for (queue = Vautoload_queue; CONSP (queue); queue = XCDR (queue))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3112 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3113 Lisp_Object first = XCAR (queue);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3114 Lisp_Object second = Fcdr (first);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3115
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3116 first = Fcar (first);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3117
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3118 /* Note: This test is subtle. The cdr of an autoload-queue entry
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3119 may be an atom if the autoload entry was generated by a defalias
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3120 or fset. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3121 if (CONSP (second))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3122 Fput (first, Qautoload, (XCDR (second)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3123 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3124 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3125
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3126 /* Once loading finishes, don't undo it. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3127 Vautoload_queue = Qt;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
3128 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3129
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3130 fun = indirect_function (fun, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3131
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3132 #if 0 /* FSFmacs */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3133 if (!NILP (Fequal (fun, fundef)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3134 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3135 if (UNBOUNDP (fun)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3136 || (CONSP (fun)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3137 && EQ (XCAR (fun), Qautoload)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3138 #endif
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
3139 invalid_state ("Autoloading failed to define function", funname);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3140 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3141 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3142
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3143
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3144 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3145 /* eval, funcall, apply */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3146 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3147
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3148 /* NOTE: If you are hearing the endless complaint that function calls in
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3149 elisp are extremely slow, it just isn't true any more! The stuff below
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3150 -- in particular, the calling of subrs and compiled functions, the most
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3151 common cases -- has been highly optimized. There isn't a whole lot left
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3152 to do to squeeze more speed out except by switching to lexical
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3153 variables, which would eliminate the specbind loop. (But the real gain
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3154 from lexical variables would come from better optimization -- with
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3155 dynamic binding, you have the constant problem that any function call
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3156 that you haven't explicitly proven to be side-effect-free might
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3157 potentially side effect your local variables, which makes optimization
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3158 extremely difficult when there are function calls anywhere in a chunk of
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3159 code to be optimized. Even worse, you don't know that *your* local
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3160 variables aren't side-effecting an outer function's local variables, so
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3161 it's impossible to optimize away almost *any* variable assignment.) */
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3162
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3163 static Lisp_Object funcall_lambda (Lisp_Object fun,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3164 int nargs, Lisp_Object args[]);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3165 static int in_warnings;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3166
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3167 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3168 in_warnings_restore (Lisp_Object minimus)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3169 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3170 in_warnings = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3171 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3172 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3173
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3174 void handle_compiled_function_with_and_rest (Lisp_Compiled_Function *f,
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3175 int nargs,
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3176 Lisp_Object args[]);
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3177
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3178 /* The theory behind making this a separate function is to shrink
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3179 funcall_compiled_function() so as to increase the likelihood of a cache
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3180 hit in the L1 cache -- &rest processing is not going to be fast anyway.
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3181 The idea is the same as with execute_rare_opcode() in bytecode.c. We
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3182 make this non-static to ensure the compiler doesn't inline it. */
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3183
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3184 void
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3185 handle_compiled_function_with_and_rest (Lisp_Compiled_Function *f, int nargs,
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3186 Lisp_Object args[])
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3187 {
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3188 REGISTER int i = 0;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3189 int max_non_rest_args = f->args_in_array - 1;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3190 int bindargs = min (nargs, max_non_rest_args);
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3191
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3192 for (i = 0; i < bindargs; i++)
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3193 SPECBIND_FAST_UNSAFE (f->args[i], args[i]);
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3194 for (i = bindargs; i < max_non_rest_args; i++)
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3195 SPECBIND_FAST_UNSAFE (f->args[i], Qnil);
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3196 SPECBIND_FAST_UNSAFE
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3197 (f->args[max_non_rest_args],
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3198 nargs > max_non_rest_args ?
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3199 Flist (nargs - max_non_rest_args, &args[max_non_rest_args]) :
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3200 Qnil);
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3201 }
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3202
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3203 /* Apply compiled-function object FUN to the NARGS evaluated arguments
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3204 in ARGS, and return the result of evaluation. */
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3205 inline static Lisp_Object
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3206 funcall_compiled_function (Lisp_Object fun, int nargs, Lisp_Object args[])
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3207 {
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3208 /* This function can GC */
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3209 int speccount = specpdl_depth();
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3210 REGISTER int i = 0;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3211 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3212
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3213 if (!OPAQUEP (f->instructions))
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3214 /* Lazily munge the instructions into a more efficient form */
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3215 optimize_compiled_function (fun);
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3216
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3217 /* optimize_compiled_function() guaranteed that f->specpdl_depth is
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3218 the required space on the specbinding stack for binding the args
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3219 and local variables of fun. So just reserve it once. */
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3220 SPECPDL_RESERVE (f->specpdl_depth);
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3221
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3222 if (nargs == f->max_args) /* Optimize for the common case -- no unspecified
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3223 optional arguments. */
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3224 {
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3225 #if 1
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3226 for (i = 0; i < nargs; i++)
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3227 SPECBIND_FAST_UNSAFE (f->args[i], args[i]);
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3228 #else
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3229 /* Here's an alternate way to write the loop that tries to further
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3230 optimize funcalls for functions with few arguments by partially
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3231 unrolling the loop. It's not clear whether this is a win since it
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3232 increases the size of the function and the possibility of L1 cache
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3233 misses. (Microsoft VC++ 6 with /O2 /G5 generates 0x90 == 144 bytes
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3234 per SPECBIND_FAST_UNSAFE().) Tests under VC++ 6, running the byte
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3235 compiler repeatedly and looking at the total time, show very
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3236 little difference between the simple loop above, the unrolled code
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3237 below, and a "partly unrolled" solution with only cases 0-2 below
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3238 instead of 0-4. Therefore, I'm keeping it at the simple loop
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3239 because it's smaller. */
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3240 switch (nargs)
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3241 {
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3242 default:
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3243 for (i = nargs - 1; i >= 4; i--)
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3244 SPECBIND_FAST_UNSAFE (f->args[i], args[i]);
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3245 case 4: SPECBIND_FAST_UNSAFE (f->args[3], args[3]);
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3246 case 3: SPECBIND_FAST_UNSAFE (f->args[2], args[2]);
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3247 case 2: SPECBIND_FAST_UNSAFE (f->args[1], args[1]);
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3248 case 1: SPECBIND_FAST_UNSAFE (f->args[0], args[0]);
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3249 case 0: break;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3250 }
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3251 #endif
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3252 }
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3253 else if (nargs < f->min_args)
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3254 goto wrong_number_of_arguments;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3255 else if (nargs < f->max_args)
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3256 {
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3257 for (i = 0; i < nargs; i++)
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3258 SPECBIND_FAST_UNSAFE (f->args[i], args[i]);
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3259 for (i = nargs; i < f->max_args; i++)
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3260 SPECBIND_FAST_UNSAFE (f->args[i], Qnil);
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3261 }
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3262 else if (f->max_args == MANY)
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3263 handle_compiled_function_with_and_rest (f, nargs, args);
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3264 else
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3265 {
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3266 wrong_number_of_arguments:
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3267 /* The actual printed compiled_function object is incomprehensible.
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3268 Check the backtrace to see if we can get a more meaningful symbol. */
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3269 if (EQ (fun, indirect_function (*backtrace_list->function, 0)))
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3270 fun = *backtrace_list->function;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3271 return Fsignal (Qwrong_number_of_arguments,
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3272 list2 (fun, make_int (nargs)));
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3273 }
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3274
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3275 {
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3276 Lisp_Object value =
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3277 execute_optimized_program ((Opbyte *) XOPAQUE_DATA (f->instructions),
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3278 f->stack_depth,
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3279 XVECTOR_DATA (f->constants));
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3280
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3281 /* The attempt to optimize this by only unbinding variables failed
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3282 because using buffer-local variables as function parameters
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3283 leads to specpdl_ptr->func != 0 */
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3284 /* UNBIND_TO_GCPRO_VARIABLES_ONLY (speccount, value); */
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3285 UNBIND_TO_GCPRO (speccount, value);
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3286 return value;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3287 }
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3288 }
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3289
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3290 DEFUN ("eval", Feval, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3291 Evaluate FORM and return its value.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3292 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3293 (form))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3294 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3295 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3296 Lisp_Object fun, val, original_fun, original_args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3297 int nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3298 struct backtrace backtrace;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3299
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3300 /* I think this is a pretty safe place to call Lisp code, don't you? */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3301 while (!in_warnings && !NILP (Vpending_warnings))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3302 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3303 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3304 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3305 Lisp_Object this_warning_cons, this_warning, class, level, messij;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3306
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3307 record_unwind_protect (in_warnings_restore, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3308 in_warnings = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3309 this_warning_cons = Vpending_warnings;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3310 this_warning = XCAR (this_warning_cons);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3311 /* in case an error occurs in the warn function, at least
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3312 it won't happen infinitely */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3313 Vpending_warnings = XCDR (Vpending_warnings);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3314 free_cons (XCONS (this_warning_cons));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3315 class = XCAR (this_warning);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3316 level = XCAR (XCDR (this_warning));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3317 messij = XCAR (XCDR (XCDR (this_warning)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3318 free_list (this_warning);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3319
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3320 if (NILP (Vpending_warnings))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3321 Vpending_warnings_tail = Qnil; /* perhaps not strictly necessary,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3322 but safer */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3323
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3324 GCPRO4 (form, class, level, messij);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3325 if (!STRINGP (messij))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3326 messij = Fprin1_to_string (messij, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3327 call3 (Qdisplay_warning, class, messij, level);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3328 UNGCPRO;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
3329 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3330 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3331
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3332 if (!CONSP (form))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3333 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3334 if (SYMBOLP (form))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3335 return Fsymbol_value (form);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3336 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3337 return form;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3338 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3339
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3340 QUIT;
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3341 if (need_to_garbage_collect)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3342 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3343 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3344 GCPRO1 (form);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3345 garbage_collect_1 ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3346 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3347 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3348
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3349 if (++lisp_eval_depth > max_lisp_eval_depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3350 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3351 if (max_lisp_eval_depth < 100)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3352 max_lisp_eval_depth = 100;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3353 if (lisp_eval_depth > max_lisp_eval_depth)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
3354 stack_overflow ("Lisp nesting exceeds `max-lisp-eval-depth'",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
3355 Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3356 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3357
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3358 /* We guaranteed CONSP (form) above */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3359 original_fun = XCAR (form);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3360 original_args = XCDR (form);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3361
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3362 GET_EXTERNAL_LIST_LENGTH (original_args, nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3363
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3364 backtrace.pdlcount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3365 backtrace.function = &original_fun; /* This also protects them from gc */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3366 backtrace.args = &original_args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3367 backtrace.nargs = UNEVALLED;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3368 backtrace.evalargs = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3369 backtrace.debug_on_exit = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3370 PUSH_BACKTRACE (backtrace);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3371
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3372 if (debug_on_next_call)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3373 do_debug_on_call (Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3374
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3375 if (profiling_active)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3376 profile_increase_call_count (original_fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3377
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3378 /* At this point, only original_fun and original_args
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3379 have values that will be used below. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3380 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3381 fun = indirect_function (original_fun, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3382
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3383 if (SUBRP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3384 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3385 Lisp_Subr *subr = XSUBR (fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3386 int max_args = subr->max_args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3387
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3388 if (nargs < subr->min_args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3389 goto wrong_number_of_arguments;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3390
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3391 if (max_args == UNEVALLED) /* Optimize for the common case */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3392 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3393 backtrace.evalargs = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3394 val = (((Lisp_Object (*) (Lisp_Object)) subr_function (subr))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3395 (original_args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3396 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3397 else if (nargs <= max_args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3398 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3399 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3400 Lisp_Object args[SUBR_MAX_ARGS];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3401 REGISTER Lisp_Object *p = args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3402
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3403 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3404 gcpro1.nvars = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3405
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3406 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3407 LIST_LOOP_2 (arg, original_args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3408 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3409 *p++ = Feval (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3410 gcpro1.nvars++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3411 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3412 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3413
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3414 /* &optional args default to nil. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3415 while (p - args < max_args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3416 *p++ = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3417
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3418 backtrace.args = args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3419 backtrace.nargs = nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3420
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3421 FUNCALL_SUBR (val, subr, args, max_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3422
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3423 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3424 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3425 else if (max_args == MANY)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3426 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3427 /* Pass a vector of evaluated arguments */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3428 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3429 Lisp_Object *args = alloca_array (Lisp_Object, nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3430 REGISTER Lisp_Object *p = args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3431
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3432 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3433 gcpro1.nvars = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3434
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3435 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3436 LIST_LOOP_2 (arg, original_args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3437 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3438 *p++ = Feval (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3439 gcpro1.nvars++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3440 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3441 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3442
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3443 backtrace.args = args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3444 backtrace.nargs = nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3445
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3446 val = (((Lisp_Object (*) (int, Lisp_Object *)) subr_function (subr))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3447 (nargs, args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3448
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3449 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3450 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3451 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3452 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3453 wrong_number_of_arguments:
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3454 val = signal_wrong_number_of_arguments_error (original_fun, nargs);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3455 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3456 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3457 else if (COMPILED_FUNCTIONP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3458 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3459 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3460 Lisp_Object *args = alloca_array (Lisp_Object, nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3461 REGISTER Lisp_Object *p = args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3462
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3463 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3464 gcpro1.nvars = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3465
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3466 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3467 LIST_LOOP_2 (arg, original_args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3468 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3469 *p++ = Feval (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3470 gcpro1.nvars++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3471 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3472 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3473
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3474 backtrace.args = args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3475 backtrace.nargs = nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3476 backtrace.evalargs = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3477
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3478 val = funcall_compiled_function (fun, nargs, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3479
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3480 /* Do the debug-on-exit now, while args is still GCPROed. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3481 if (backtrace.debug_on_exit)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3482 val = do_debug_on_exit (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3483 /* Don't do it again when we return to eval. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3484 backtrace.debug_on_exit = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3485
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3486 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3487 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3488 else if (CONSP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3489 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3490 Lisp_Object funcar = XCAR (fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3491
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3492 if (EQ (funcar, Qautoload))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3493 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3494 do_autoload (fun, original_fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3495 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3496 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3497 else if (EQ (funcar, Qmacro))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3498 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3499 val = Feval (apply1 (XCDR (fun), original_args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3500 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3501 else if (EQ (funcar, Qlambda))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3502 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3503 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3504 Lisp_Object *args = alloca_array (Lisp_Object, nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3505 REGISTER Lisp_Object *p = args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3506
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3507 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3508 gcpro1.nvars = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3509
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3510 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3511 LIST_LOOP_2 (arg, original_args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3512 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3513 *p++ = Feval (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3514 gcpro1.nvars++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3515 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3516 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3517
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3518 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3519
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3520 backtrace.args = args; /* this also GCPROs `args' */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3521 backtrace.nargs = nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3522 backtrace.evalargs = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3523
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3524 val = funcall_lambda (fun, nargs, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3525
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3526 /* Do the debug-on-exit now, while args is still GCPROed. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3527 if (backtrace.debug_on_exit)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3528 val = do_debug_on_exit (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3529 /* Don't do it again when we return to eval. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3530 backtrace.debug_on_exit = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3531 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3532 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3533 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3534 goto invalid_function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3535 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3536 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3537 else /* ! (SUBRP (fun) || COMPILED_FUNCTIONP (fun) || CONSP (fun)) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3538 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3539 invalid_function:
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
3540 val = signal_invalid_function_error (fun);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3541 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3542
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3543 lisp_eval_depth--;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3544 if (backtrace.debug_on_exit)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3545 val = do_debug_on_exit (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3546 POP_BACKTRACE (backtrace);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3547 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3548 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3549
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3550
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3551 DEFUN ("funcall", Ffuncall, 1, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3552 Call first argument as a function, passing the remaining arguments to it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3553 Thus, (funcall 'cons 'x 'y) returns (x . y).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3554 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3555 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3556 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3557 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3558 Lisp_Object fun;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3559 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3560 struct backtrace backtrace;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3561 int fun_nargs = nargs - 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3562 Lisp_Object *fun_args = args + 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3563
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3564 QUIT;
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3565 if (need_to_garbage_collect)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3566 /* Callers should gcpro lexpr args */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3567 garbage_collect_1 ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3568
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3569 if (++lisp_eval_depth > max_lisp_eval_depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3570 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3571 if (max_lisp_eval_depth < 100)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3572 max_lisp_eval_depth = 100;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3573 if (lisp_eval_depth > max_lisp_eval_depth)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
3574 stack_overflow ("Lisp nesting exceeds `max-lisp-eval-depth'",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
3575 Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3576 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3577
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3578 backtrace.pdlcount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3579 backtrace.function = &args[0];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3580 backtrace.args = fun_args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3581 backtrace.nargs = fun_nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3582 backtrace.evalargs = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3583 backtrace.debug_on_exit = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3584 PUSH_BACKTRACE (backtrace);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3585
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3586 if (debug_on_next_call)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3587 do_debug_on_call (Qlambda);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3588
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3589 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3590
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3591 fun = args[0];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3592
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3593 /* It might be useful to place this *after* all the checks. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3594 if (profiling_active)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3595 profile_increase_call_count (fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3596
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3597 /* We could call indirect_function directly, but profiling shows
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3598 this is worth optimizing by partially unrolling the loop. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3599 if (SYMBOLP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3600 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3601 fun = XSYMBOL (fun)->function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3602 if (SYMBOLP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3603 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3604 fun = XSYMBOL (fun)->function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3605 if (SYMBOLP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3606 fun = indirect_function (fun, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3607 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3608 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3609
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3610 if (SUBRP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3611 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3612 Lisp_Subr *subr = XSUBR (fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3613 int max_args = subr->max_args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3614 Lisp_Object spacious_args[SUBR_MAX_ARGS];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3615
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3616 if (fun_nargs == max_args) /* Optimize for the common case */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3617 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3618 funcall_subr:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3619 FUNCALL_SUBR (val, subr, fun_args, max_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3620 }
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
3621 else if (fun_nargs < subr->min_args)
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
3622 {
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
3623 goto wrong_number_of_arguments;
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
3624 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3625 else if (fun_nargs < max_args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3626 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3627 Lisp_Object *p = spacious_args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3628
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3629 /* Default optionals to nil */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3630 while (fun_nargs--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3631 *p++ = *fun_args++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3632 while (p - spacious_args < max_args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3633 *p++ = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3634
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3635 fun_args = spacious_args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3636 goto funcall_subr;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3637 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3638 else if (max_args == MANY)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3639 {
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
3640 val = SUBR_FUNCTION (subr, MANY) (fun_nargs, fun_args);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3641 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3642 else if (max_args == UNEVALLED) /* Can't funcall a special form */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3643 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3644 goto invalid_function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3645 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3646 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3647 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3648 wrong_number_of_arguments:
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
3649 val = signal_wrong_number_of_arguments_error (fun, fun_nargs);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3650 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3651 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3652 else if (COMPILED_FUNCTIONP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3653 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3654 val = funcall_compiled_function (fun, fun_nargs, fun_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3655 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3656 else if (CONSP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3657 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3658 Lisp_Object funcar = XCAR (fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3659
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3660 if (EQ (funcar, Qlambda))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3661 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3662 val = funcall_lambda (fun, fun_nargs, fun_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3663 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3664 else if (EQ (funcar, Qautoload))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3665 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3666 do_autoload (fun, args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3667 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3668 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3669 else /* Can't funcall a macro */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3670 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3671 goto invalid_function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3672 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3673 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3674 else if (UNBOUNDP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3675 {
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
3676 val = signal_void_function_error (args[0]);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3677 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3678 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3679 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3680 invalid_function:
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
3681 val = signal_invalid_function_error (fun);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3682 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3683
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3684 lisp_eval_depth--;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3685 if (backtrace.debug_on_exit)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3686 val = do_debug_on_exit (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3687 POP_BACKTRACE (backtrace);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3688 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3689 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3690
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3691 DEFUN ("functionp", Ffunctionp, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3692 Return t if OBJECT can be called as a function, else nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3693 A function is an object that can be applied to arguments,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3694 using for example `funcall' or `apply'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3695 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3696 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3697 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3698 if (SYMBOLP (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3699 object = indirect_function (object, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3700
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3701 return
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3702 (SUBRP (object) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3703 COMPILED_FUNCTIONP (object) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3704 (CONSP (object) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3705 (EQ (XCAR (object), Qlambda) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3706 EQ (XCAR (object), Qautoload))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3707 ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3708 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3709
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3710 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3711 function_argcount (Lisp_Object function, int function_min_args_p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3712 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3713 Lisp_Object orig_function = function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3714 Lisp_Object arglist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3715
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3716 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3717
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3718 if (SYMBOLP (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3719 function = indirect_function (function, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3720
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3721 if (SUBRP (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3722 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3723 /* Using return with the ?: operator tickles a DEC CC compiler bug. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3724 if (function_min_args_p)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3725 return Fsubr_min_args (function);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3726 else
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3727 return Fsubr_max_args (function);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3728 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3729 else if (COMPILED_FUNCTIONP (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3730 {
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3731 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (function);
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3732
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3733 if (function_min_args_p)
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3734 return make_int (f->min_args);
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3735 else if (f->max_args == MANY)
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3736 return Qnil;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3737 else
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
3738 return make_int (f->max_args);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3739 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3740 else if (CONSP (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3741 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3742 Lisp_Object funcar = XCAR (function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3743
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3744 if (EQ (funcar, Qmacro))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3745 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3746 function = XCDR (function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3747 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3748 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3749 else if (EQ (funcar, Qautoload))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3750 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3751 struct gcpro gcpro1;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3752
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3753 GCPRO1 (function);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3754 do_autoload (function, orig_function);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3755 UNGCPRO;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3756 function = orig_function;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3757 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3758 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3759 else if (EQ (funcar, Qlambda))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3760 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3761 arglist = Fcar (XCDR (function));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3762 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3763 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3764 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3765 goto invalid_function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3766 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3767 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3768 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3769 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3770 invalid_function:
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3771 return signal_invalid_function_error (orig_function);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3772 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3773
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3774 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3775 int argcount = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3776
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3777 EXTERNAL_LIST_LOOP_2 (arg, arglist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3778 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3779 if (EQ (arg, Qand_optional))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3780 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3781 if (function_min_args_p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3782 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3783 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3784 else if (EQ (arg, Qand_rest))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3785 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3786 if (function_min_args_p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3787 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3788 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3789 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3790 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3791 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3792 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3793 argcount++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3794 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3795 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3796
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3797 return make_int (argcount);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3798 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3799 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3800
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3801 DEFUN ("function-min-args", Ffunction_min_args, 1, 1, 0, /*
617
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
3802 Return the minimum number of arguments a function may be called with.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3803 The function may be any form that can be passed to `funcall',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3804 any special form, or any macro.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3805 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3806 (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3807 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3808 return function_argcount (function, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3809 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3810
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3811 DEFUN ("function-max-args", Ffunction_max_args, 1, 1, 0, /*
617
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
3812 Return the maximum number of arguments a function may be called with.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3813 The function may be any form that can be passed to `funcall',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3814 any special form, or any macro.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3815 If the function takes an arbitrary number of arguments or is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3816 a built-in special form, nil is returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3817 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3818 (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3819 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3820 return function_argcount (function, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3821 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3822
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3823
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3824 DEFUN ("apply", Fapply, 2, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3825 Call FUNCTION with the remaining args, using the last arg as a list of args.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3826 Thus, (apply '+ 1 2 '(3 4)) returns 10.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3827 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3828 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3829 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3830 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3831 Lisp_Object fun = args[0];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3832 Lisp_Object spread_arg = args [nargs - 1];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3833 int numargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3834 int funcall_nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3835
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3836 GET_EXTERNAL_LIST_LENGTH (spread_arg, numargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3837
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3838 if (numargs == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3839 /* (apply foo 0 1 '()) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3840 return Ffuncall (nargs - 1, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3841 else if (numargs == 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3842 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3843 /* (apply foo 0 1 '(2)) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3844 args [nargs - 1] = XCAR (spread_arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3845 return Ffuncall (nargs, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3846 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3847
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3848 /* -1 for function, -1 for spread arg */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3849 numargs = nargs - 2 + numargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3850 /* +1 for function */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3851 funcall_nargs = 1 + numargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3852
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3853 if (SYMBOLP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3854 fun = indirect_function (fun, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3855
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3856 if (SUBRP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3857 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3858 Lisp_Subr *subr = XSUBR (fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3859 int max_args = subr->max_args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3860
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3861 if (numargs < subr->min_args
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3862 || (max_args >= 0 && max_args < numargs))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3863 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3864 /* Let funcall get the error */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3865 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3866 else if (max_args > numargs)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3867 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3868 /* Avoid having funcall cons up yet another new vector of arguments
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3869 by explicitly supplying nil's for optional values */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3870 funcall_nargs += (max_args - numargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3871 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3872 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3873 else if (UNBOUNDP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3874 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3875 /* Let funcall get the error */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3876 fun = args[0];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3877 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3878
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3879 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3880 REGISTER int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3881 Lisp_Object *funcall_args = alloca_array (Lisp_Object, funcall_nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3882 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3883
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3884 GCPRO1 (*funcall_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3885 gcpro1.nvars = funcall_nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3886
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3887 /* Copy in the unspread args */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3888 memcpy (funcall_args, args, (nargs - 1) * sizeof (Lisp_Object));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3889 /* Spread the last arg we got. Its first element goes in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3890 the slot that it used to occupy, hence this value of I. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3891 for (i = nargs - 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3892 !NILP (spread_arg); /* i < 1 + numargs */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3893 i++, spread_arg = XCDR (spread_arg))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3894 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3895 funcall_args [i] = XCAR (spread_arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3896 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3897 /* Supply nil for optional args (to subrs) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3898 for (; i < funcall_nargs; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3899 funcall_args[i] = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3900
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3901
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3902 RETURN_UNGCPRO (Ffuncall (funcall_nargs, funcall_args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3903 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3904 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3905
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3906
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3907 /* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3908 return the result of evaluation. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3909
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3910 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3911 funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object args[])
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3912 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3913 /* This function can GC */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3914 Lisp_Object arglist, body, tail;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3915 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3916 REGISTER int i = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3917
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3918 tail = XCDR (fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3919
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3920 if (!CONSP (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3921 goto invalid_function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3922
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3923 arglist = XCAR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3924 body = XCDR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3925
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3926 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3927 int optional = 0, rest = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3928
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3929 EXTERNAL_LIST_LOOP_2 (symbol, arglist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3930 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3931 if (!SYMBOLP (symbol))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3932 goto invalid_function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3933 if (EQ (symbol, Qand_rest))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3934 rest = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3935 else if (EQ (symbol, Qand_optional))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3936 optional = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3937 else if (rest)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3938 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3939 specbind (symbol, Flist (nargs - i, &args[i]));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3940 i = nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3941 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3942 else if (i < nargs)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3943 specbind (symbol, args[i++]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3944 else if (!optional)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3945 goto wrong_number_of_arguments;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3946 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3947 specbind (symbol, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3948 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3949 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3950
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3951 if (i < nargs)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3952 goto wrong_number_of_arguments;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3953
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
3954 return unbind_to_1 (speccount, Fprogn (body));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3955
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3956 wrong_number_of_arguments:
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
3957 return signal_wrong_number_of_arguments_error (fun, nargs);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3958
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3959 invalid_function:
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
3960 return signal_invalid_function_error (fun);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3961 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3962
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3963
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3964 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3965 /* Run hook variables in various ways. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3966 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3967
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3968 DEFUN ("run-hooks", Frun_hooks, 1, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3969 Run each hook in HOOKS. Major mode functions use this.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3970 Each argument should be a symbol, a hook variable.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3971 These symbols are processed in the order specified.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3972 If a hook symbol has a non-nil value, that value may be a function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3973 or a list of functions to be called to run the hook.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3974 If the value is a function, it is called with no arguments.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3975 If it is a list, the elements are called, in order, with no arguments.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3976
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3977 To make a hook variable buffer-local, use `make-local-hook',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3978 not `make-local-variable'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3979 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3980 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3981 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3982 REGISTER int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3983
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3984 for (i = 0; i < nargs; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3985 run_hook_with_args (1, args + i, RUN_HOOKS_TO_COMPLETION);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3986
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3987 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3988 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3989
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3990 DEFUN ("run-hook-with-args", Frun_hook_with_args, 1, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3991 Run HOOK with the specified arguments ARGS.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3992 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3993 value, that value may be a function or a list of functions to be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3994 called to run the hook. If the value is a function, it is called with
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3995 the given arguments and its return value is returned. If it is a list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3996 of functions, those functions are called, in order,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3997 with the given arguments ARGS.
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3998 It is best not to depend on the value returned by `run-hook-with-args',
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3999 as that may change.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4001 To make a hook variable buffer-local, use `make-local-hook',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4002 not `make-local-variable'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4003 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4004 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4005 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4006 return run_hook_with_args (nargs, args, RUN_HOOKS_TO_COMPLETION);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4007 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4008
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4009 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success, 1, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4010 Run HOOK with the specified arguments ARGS.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4011 HOOK should be a symbol, a hook variable. Its value should
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4012 be a list of functions. We call those functions, one by one,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4013 passing arguments ARGS to each of them, until one of them
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4014 returns a non-nil value. Then we return that value.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4015 If all the functions return nil, we return nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4016
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4017 To make a hook variable buffer-local, use `make-local-hook',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4018 not `make-local-variable'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4019 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4020 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4021 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4022 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_SUCCESS);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4023 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4024
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4025 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure, 1, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4026 Run HOOK with the specified arguments ARGS.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4027 HOOK should be a symbol, a hook variable. Its value should
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4028 be a list of functions. We call those functions, one by one,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4029 passing arguments ARGS to each of them, until one of them
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4030 returns nil. Then we return nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4031 If all the functions return non-nil, we return non-nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4032
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4033 To make a hook variable buffer-local, use `make-local-hook',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4034 not `make-local-variable'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4035 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4036 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4037 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4038 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_FAILURE);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4039 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4040
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4041 /* ARGS[0] should be a hook symbol.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4042 Call each of the functions in the hook value, passing each of them
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4043 as arguments all the rest of ARGS (all NARGS - 1 elements).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4044 COND specifies a condition to test after each call
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4045 to decide whether to stop.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4046 The caller (or its caller, etc) must gcpro all of ARGS,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4047 except that it isn't necessary to gcpro ARGS[0]. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4048
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4049 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4050 run_hook_with_args_in_buffer (struct buffer *buf, int nargs, Lisp_Object *args,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4051 enum run_hooks_condition cond)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4052 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4053 Lisp_Object sym, val, ret;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4054
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4055 if (!initialized || preparing_for_armageddon)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4056 /* We need to bail out of here pronto. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4057 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4058
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4059 /* Whenever gc_in_progress is true, preparing_for_armageddon
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4060 will also be true unless something is really hosed. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4061 assert (!gc_in_progress);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4062
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4063 sym = args[0];
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
4064 val = symbol_value_in_buffer (sym, wrap_buffer (buf));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4065 ret = (cond == RUN_HOOKS_UNTIL_FAILURE ? Qt : Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4066
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4067 if (UNBOUNDP (val) || NILP (val))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4068 return ret;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4069 else if (!CONSP (val) || EQ (XCAR (val), Qlambda))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4070 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4071 args[0] = val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4072 return Ffuncall (nargs, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4073 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4074 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4075 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4076 struct gcpro gcpro1, gcpro2, gcpro3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4077 Lisp_Object globals = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4078 GCPRO3 (sym, val, globals);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4079
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4080 for (;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4081 CONSP (val) && ((cond == RUN_HOOKS_TO_COMPLETION)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4082 || (cond == RUN_HOOKS_UNTIL_SUCCESS ? NILP (ret)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4083 : !NILP (ret)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4084 val = XCDR (val))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4085 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4086 if (EQ (XCAR (val), Qt))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4087 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4088 /* t indicates this hook has a local binding;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4089 it means to run the global binding too. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4090 globals = Fdefault_value (sym);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4091
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4092 if ((! CONSP (globals) || EQ (XCAR (globals), Qlambda)) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4093 ! NILP (globals))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4094 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4095 args[0] = globals;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4096 ret = Ffuncall (nargs, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4097 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4098 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4099 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4100 for (;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4101 CONSP (globals) && ((cond == RUN_HOOKS_TO_COMPLETION)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4102 || (cond == RUN_HOOKS_UNTIL_SUCCESS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4103 ? NILP (ret)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4104 : !NILP (ret)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4105 globals = XCDR (globals))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4106 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4107 args[0] = XCAR (globals);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4108 /* In a global value, t should not occur. If it does, we
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4109 must ignore it to avoid an endless loop. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4110 if (!EQ (args[0], Qt))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4111 ret = Ffuncall (nargs, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4112 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4113 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4114 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4115 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4116 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4117 args[0] = XCAR (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4118 ret = Ffuncall (nargs, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4119 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4120 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4121
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4122 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4123 return ret;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4124 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4125 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4126
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4127 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4128 run_hook_with_args (int nargs, Lisp_Object *args,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4129 enum run_hooks_condition cond)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4130 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4131 return run_hook_with_args_in_buffer (current_buffer, nargs, args, cond);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4132 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4133
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4134 #if 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4135
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4136 /* From FSF 19.30, not currently used */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4137
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4138 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4139 present value of that symbol.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4140 Call each element of FUNLIST,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4141 passing each of them the rest of ARGS.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4142 The caller (or its caller, etc) must gcpro all of ARGS,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4143 except that it isn't necessary to gcpro ARGS[0]. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4144
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4145 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4146 run_hook_list_with_args (Lisp_Object funlist, int nargs, Lisp_Object *args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4147 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4148 Lisp_Object sym = args[0];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4149 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4150 struct gcpro gcpro1, gcpro2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4151
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4152 GCPRO2 (sym, val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4153
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4154 for (val = funlist; CONSP (val); val = XCDR (val))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4155 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4156 if (EQ (XCAR (val), Qt))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4157 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4158 /* t indicates this hook has a local binding;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4159 it means to run the global binding too. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4160 Lisp_Object globals;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4161
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4162 for (globals = Fdefault_value (sym);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4163 CONSP (globals);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4164 globals = XCDR (globals))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4165 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4166 args[0] = XCAR (globals);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4167 /* In a global value, t should not occur. If it does, we
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4168 must ignore it to avoid an endless loop. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4169 if (!EQ (args[0], Qt))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4170 Ffuncall (nargs, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4171 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4172 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4173 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4174 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4175 args[0] = XCAR (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4176 Ffuncall (nargs, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4177 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4178 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4179 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4180 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4181 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4182
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4183 #endif /* 0 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4184
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4185 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4186 va_run_hook_with_args (Lisp_Object hook_var, int nargs, ...)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4187 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4188 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4189 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4190 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4191 va_list vargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4192 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4193
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4194 va_start (vargs, nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4195 funcall_args[0] = hook_var;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4196 for (i = 0; i < nargs; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4197 funcall_args[i + 1] = va_arg (vargs, Lisp_Object);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4198 va_end (vargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4199
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4200 GCPRO1 (*funcall_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4201 gcpro1.nvars = nargs + 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4202 run_hook_with_args (nargs + 1, funcall_args, RUN_HOOKS_TO_COMPLETION);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4203 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4204 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4205
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4206 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4207 va_run_hook_with_args_in_buffer (struct buffer *buf, Lisp_Object hook_var,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4208 int nargs, ...)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4209 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4210 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4211 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4212 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4213 va_list vargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4214 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4215
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4216 va_start (vargs, nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4217 funcall_args[0] = hook_var;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4218 for (i = 0; i < nargs; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4219 funcall_args[i + 1] = va_arg (vargs, Lisp_Object);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4220 va_end (vargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4221
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4222 GCPRO1 (*funcall_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4223 gcpro1.nvars = nargs + 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4224 run_hook_with_args_in_buffer (buf, nargs + 1, funcall_args,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4225 RUN_HOOKS_TO_COMPLETION);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4226 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4227 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4228
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4229 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4230 run_hook (Lisp_Object hook)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4231 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4232 Frun_hooks (1, &hook);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4233 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4234 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4235
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4236
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4237 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4238 /* Front-ends to eval, funcall, apply */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4239 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4240
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4241 /* Apply fn to arg */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4242 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4243 apply1 (Lisp_Object fn, Lisp_Object arg)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4244 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4245 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4246 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4247 Lisp_Object args[2];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4248
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4249 if (NILP (arg))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4250 return Ffuncall (1, &fn);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4251 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4252 gcpro1.nvars = 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4253 args[0] = fn;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4254 args[1] = arg;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4255 RETURN_UNGCPRO (Fapply (2, args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4256 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4257
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4258 /* Call function fn on no arguments */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4259 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4260 call0 (Lisp_Object fn)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4261 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4262 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4263 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4264
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4265 GCPRO1 (fn);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4266 RETURN_UNGCPRO (Ffuncall (1, &fn));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4267 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4268
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4269 /* Call function fn with argument arg0 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4270 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4271 call1 (Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4272 Lisp_Object arg0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4273 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4274 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4275 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4276 Lisp_Object args[2];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4277 args[0] = fn;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4278 args[1] = arg0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4279 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4280 gcpro1.nvars = 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4281 RETURN_UNGCPRO (Ffuncall (2, args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4282 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4283
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4284 /* Call function fn with arguments arg0, arg1 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4285 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4286 call2 (Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4287 Lisp_Object arg0, Lisp_Object arg1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4288 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4289 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4290 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4291 Lisp_Object args[3];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4292 args[0] = fn;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4293 args[1] = arg0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4294 args[2] = arg1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4295 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4296 gcpro1.nvars = 3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4297 RETURN_UNGCPRO (Ffuncall (3, args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4298 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4299
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4300 /* Call function fn with arguments arg0, arg1, arg2 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4301 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4302 call3 (Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4303 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4304 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4305 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4306 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4307 Lisp_Object args[4];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4308 args[0] = fn;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4309 args[1] = arg0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4310 args[2] = arg1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4311 args[3] = arg2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4312 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4313 gcpro1.nvars = 4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4314 RETURN_UNGCPRO (Ffuncall (4, args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4315 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4316
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4317 /* Call function fn with arguments arg0, arg1, arg2, arg3 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4318 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4319 call4 (Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4320 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4321 Lisp_Object arg3)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4322 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4323 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4324 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4325 Lisp_Object args[5];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4326 args[0] = fn;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4327 args[1] = arg0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4328 args[2] = arg1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4329 args[3] = arg2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4330 args[4] = arg3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4331 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4332 gcpro1.nvars = 5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4333 RETURN_UNGCPRO (Ffuncall (5, args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4334 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4335
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4336 /* Call function fn with arguments arg0, arg1, arg2, arg3, arg4 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4337 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4338 call5 (Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4339 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4340 Lisp_Object arg3, Lisp_Object arg4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4341 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4342 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4343 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4344 Lisp_Object args[6];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4345 args[0] = fn;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4346 args[1] = arg0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4347 args[2] = arg1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4348 args[3] = arg2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4349 args[4] = arg3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4350 args[5] = arg4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4351 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4352 gcpro1.nvars = 6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4353 RETURN_UNGCPRO (Ffuncall (6, args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4354 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4355
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4356 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4357 call6 (Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4358 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4359 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4360 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4361 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4362 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4363 Lisp_Object args[7];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4364 args[0] = fn;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4365 args[1] = arg0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4366 args[2] = arg1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4367 args[3] = arg2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4368 args[4] = arg3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4369 args[5] = arg4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4370 args[6] = arg5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4371 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4372 gcpro1.nvars = 7;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4373 RETURN_UNGCPRO (Ffuncall (7, args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4374 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4375
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4376 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4377 call7 (Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4378 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4379 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4380 Lisp_Object arg6)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4381 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4382 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4383 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4384 Lisp_Object args[8];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4385 args[0] = fn;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4386 args[1] = arg0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4387 args[2] = arg1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4388 args[3] = arg2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4389 args[4] = arg3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4390 args[5] = arg4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4391 args[6] = arg5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4392 args[7] = arg6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4393 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4394 gcpro1.nvars = 8;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4395 RETURN_UNGCPRO (Ffuncall (8, args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4396 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4397
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4398 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4399 call8 (Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4400 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4401 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4402 Lisp_Object arg6, Lisp_Object arg7)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4403 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4404 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4405 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4406 Lisp_Object args[9];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4407 args[0] = fn;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4408 args[1] = arg0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4409 args[2] = arg1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4410 args[3] = arg2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4411 args[4] = arg3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4412 args[5] = arg4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4413 args[6] = arg5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4414 args[7] = arg6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4415 args[8] = arg7;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4416 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4417 gcpro1.nvars = 9;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4418 RETURN_UNGCPRO (Ffuncall (9, args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4419 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4420
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4421 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4422 call0_in_buffer (struct buffer *buf, Lisp_Object fn)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4423 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4424 if (current_buffer == buf)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4425 return call0 (fn);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4426 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4427 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4428 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4429 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4430 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4431 set_buffer_internal (buf);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4432 val = call0 (fn);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
4433 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4434 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4435 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4436 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4437
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4438 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4439 call1_in_buffer (struct buffer *buf, Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4440 Lisp_Object arg0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4441 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4442 if (current_buffer == buf)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4443 return call1 (fn, arg0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4444 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4445 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4446 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4447 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4448 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4449 set_buffer_internal (buf);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4450 val = call1 (fn, arg0);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
4451 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4452 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4453 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4454 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4455
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4456 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4457 call2_in_buffer (struct buffer *buf, Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4458 Lisp_Object arg0, Lisp_Object arg1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4459 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4460 if (current_buffer == buf)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4461 return call2 (fn, arg0, arg1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4462 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4463 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4464 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4465 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4466 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4467 set_buffer_internal (buf);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4468 val = call2 (fn, arg0, arg1);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
4469 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4470 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4471 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4472 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4473
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4474 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4475 call3_in_buffer (struct buffer *buf, Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4476 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4477 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4478 if (current_buffer == buf)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4479 return call3 (fn, arg0, arg1, arg2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4480 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4481 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4482 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4483 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4484 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4485 set_buffer_internal (buf);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4486 val = call3 (fn, arg0, arg1, arg2);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
4487 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4488 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4489 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4490 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4491
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4492 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4493 call4_in_buffer (struct buffer *buf, Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4494 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4495 Lisp_Object arg3)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4496 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4497 if (current_buffer == buf)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4498 return call4 (fn, arg0, arg1, arg2, arg3);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4499 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4500 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4501 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4502 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4503 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4504 set_buffer_internal (buf);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4505 val = call4 (fn, arg0, arg1, arg2, arg3);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
4506 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4507 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4508 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4509 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4510
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4511 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4512 eval_in_buffer (struct buffer *buf, Lisp_Object form)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4513 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4514 if (current_buffer == buf)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4515 return Feval (form);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4516 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4517 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4518 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4519 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4520 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4521 set_buffer_internal (buf);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4522 val = Feval (form);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
4523 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4524 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4525 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4526 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4527
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4528
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4529 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4530 /* Error-catching front-ends to eval, funcall, apply */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4531 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4532
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4533 /* Call function fn on no arguments, with condition handler */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4534 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4535 call0_with_handler (Lisp_Object handler, Lisp_Object fn)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4536 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4537 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4538 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4539 Lisp_Object args[2];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4540 args[0] = handler;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4541 args[1] = fn;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4542 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4543 gcpro1.nvars = 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4544 RETURN_UNGCPRO (Fcall_with_condition_handler (2, args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4545 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4546
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4547 /* Call function fn with argument arg0, with condition handler */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4548 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4549 call1_with_handler (Lisp_Object handler, Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4550 Lisp_Object arg0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4551 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4552 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4553 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4554 Lisp_Object args[3];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4555 args[0] = handler;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4556 args[1] = fn;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4557 args[2] = arg0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4558 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4559 gcpro1.nvars = 3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4560 RETURN_UNGCPRO (Fcall_with_condition_handler (3, args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4561 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4562
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4563
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4564 /* The following functions provide you with error-trapping versions
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4565 of the various front-ends above. They take an additional
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4566 "warning_string" argument; if non-zero, a warning with this
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4567 string and the actual error that occurred will be displayed
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4568 in the *Warnings* buffer if an error occurs. In all cases,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4569 QUIT is inhibited while these functions are running, and if
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4570 an error occurs, Qunbound is returned instead of the normal
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4571 return value.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4572 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4573
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4574 /* #### This stuff needs to catch throws as well. We need to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4575 improve internal_catch() so it can take a "catch anything"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4576 argument similar to Qt or Qerror for condition_case_1(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4577
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4578 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4579 caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4580 {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
4581 /* #### should be rewritten to work with emacs_sprintf_string_lisp(); but this
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
4582 whole stuff is getting junked and replaced from my stderr-proc ws */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4583 if (!NILP (errordata))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4584 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4585 Lisp_Object args[2];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4586
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4587 if (!NILP (arg))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4588 {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
4589 Intbyte *str = (Intbyte *) get_opaque_ptr (arg);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
4590 args[0] = build_intstring (str);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4591 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4592 else
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
4593 args[0] = build_msg_string ("error");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4594 /* #### This should call
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4595 (with-output-to-string (display-error errordata))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4596 but that stuff is all in Lisp currently. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4597 args[1] = errordata;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4598 warn_when_safe_lispobj
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4599 (Qerror, Qwarning,
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
4600 emacs_vsprintf_string_lisp ("%s: %s", Qnil, 2, args));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4601 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4602 return Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4603 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4604
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4605 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4606 allow_quit_caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4607 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4608 if (CONSP (errordata) && EQ (XCAR (errordata), Qquit))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4609 return Fsignal (Qquit, XCDR (errordata));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4610 return caught_a_squirmer (errordata, arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4611 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4612
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4613 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4614 safe_run_hook_caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4615 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4616 Lisp_Object hook = Fcar (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4617 arg = Fcdr (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4618 /* Clear out the hook. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4619 Fset (hook, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4620 return caught_a_squirmer (errordata, arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4621 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4622
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4623 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4624 allow_quit_safe_run_hook_caught_a_squirmer (Lisp_Object errordata,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4625 Lisp_Object arg)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4626 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4627 Lisp_Object hook = Fcar (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4628 arg = Fcdr (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4629 if (!CONSP (errordata) || !EQ (XCAR (errordata), Qquit))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4630 /* Clear out the hook. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4631 Fset (hook, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4632 return allow_quit_caught_a_squirmer (errordata, arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4633 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4634
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4635 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4636 catch_them_squirmers_eval_in_buffer (Lisp_Object cons)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4637 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4638 return eval_in_buffer (XBUFFER (XCAR (cons)), XCDR (cons));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4639 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4640
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4641 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4642 eval_in_buffer_trapping_errors (const CIntbyte *warning_string,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4643 struct buffer *buf, Lisp_Object form)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4644 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4645 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4646 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4647 Lisp_Object buffer;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4648 Lisp_Object cons;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4649 Lisp_Object opaque;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4650 struct gcpro gcpro1, gcpro2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4651
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
4652 buffer = wrap_buffer (buf);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4653
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4654 specbind (Qinhibit_quit, Qt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
4655 /* begin_gc_forbidden(); Currently no reason to do this; */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4656
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4657 cons = noseeum_cons (buffer, form);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4658 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4659 GCPRO2 (cons, opaque);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4660 /* Qerror not Qt, so you can get a backtrace */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4661 tem = condition_case_1 (Qerror,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4662 catch_them_squirmers_eval_in_buffer, cons,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4663 caught_a_squirmer, opaque);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4664 free_cons (XCONS (cons));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4665 if (OPAQUE_PTRP (opaque))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4666 free_opaque_ptr (opaque);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4667 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4668
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
4669 return unbind_to_1 (speccount, tem);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4670 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4671
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4672 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4673 catch_them_squirmers_run_hook (Lisp_Object hook_symbol)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4674 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4675 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4676 run_hook (hook_symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4677 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4678 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4679
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4680 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4681 run_hook_trapping_errors (const CIntbyte *warning_string,
609
13e3d7ae7155 [xemacs-hg @ 2001-06-06 12:34:42 by ben]
ben
parents: 578
diff changeset
4682 Lisp_Object hook_symbol)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4683 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4684 int speccount;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4685 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4686 Lisp_Object opaque;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4687 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4688
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4689 if (!initialized || preparing_for_armageddon)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4690 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4691 tem = find_symbol_value (hook_symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4692 if (NILP (tem) || UNBOUNDP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4693 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4694
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4695 speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4696 specbind (Qinhibit_quit, Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4697
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4698 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4699 GCPRO1 (opaque);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4700 /* Qerror not Qt, so you can get a backtrace */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4701 tem = condition_case_1 (Qerror,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4702 catch_them_squirmers_run_hook, hook_symbol,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4703 caught_a_squirmer, opaque);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4704 if (OPAQUE_PTRP (opaque))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4705 free_opaque_ptr (opaque);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4706 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4707
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
4708 return unbind_to_1 (speccount, tem);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4709 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4710
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4711 /* Same as run_hook_trapping_errors() but also set the hook to nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4712 if an error occurs. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4713
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4714 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4715 safe_run_hook_trapping_errors (const CIntbyte *warning_string,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4716 Lisp_Object hook_symbol,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4717 int allow_quit)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4718 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4719 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4720 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4721 Lisp_Object cons = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4722 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4723
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4724 if (!initialized || preparing_for_armageddon)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4725 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4726 tem = find_symbol_value (hook_symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4727 if (NILP (tem) || UNBOUNDP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4728 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4729
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4730 if (!allow_quit)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4731 specbind (Qinhibit_quit, Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4732
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4733 cons = noseeum_cons (hook_symbol,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4734 warning_string ? make_opaque_ptr ((void *)warning_string)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4735 : Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4736 GCPRO1 (cons);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4737 /* Qerror not Qt, so you can get a backtrace */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4738 tem = condition_case_1 (Qerror,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4739 catch_them_squirmers_run_hook,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4740 hook_symbol,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4741 allow_quit ?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4742 allow_quit_safe_run_hook_caught_a_squirmer :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4743 safe_run_hook_caught_a_squirmer,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4744 cons);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4745 if (OPAQUE_PTRP (XCDR (cons)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4746 free_opaque_ptr (XCDR (cons));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4747 free_cons (XCONS (cons));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4748 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4749
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
4750 return unbind_to_1 (speccount, tem);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4751 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4752
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4753 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4754 catch_them_squirmers_call0 (Lisp_Object function)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4755 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4756 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4757 return call0 (function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4758 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4759
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4760 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4761 call0_trapping_errors (const CIntbyte *warning_string, Lisp_Object function)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4762 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4763 int speccount;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4764 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4765 Lisp_Object opaque = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4766 struct gcpro gcpro1, gcpro2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4767
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4768 if (SYMBOLP (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4769 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4770 tem = XSYMBOL (function)->function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4771 if (NILP (tem) || UNBOUNDP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4772 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4773 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4774
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4775 GCPRO2 (opaque, function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4776 speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4777 specbind (Qinhibit_quit, Qt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
4778 /* begin_gc_forbidden(); Currently no reason to do this; */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4779
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4780 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4781 /* Qerror not Qt, so you can get a backtrace */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4782 tem = condition_case_1 (Qerror,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4783 catch_them_squirmers_call0, function,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4784 caught_a_squirmer, opaque);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4785 if (OPAQUE_PTRP (opaque))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4786 free_opaque_ptr (opaque);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4787 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4788
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
4789 return unbind_to_1 (speccount, tem);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4790 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4791
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4792 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4793 catch_them_squirmers_call1 (Lisp_Object cons)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4794 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4795 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4796 return call1 (XCAR (cons), XCDR (cons));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4797 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4798
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4799 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4800 catch_them_squirmers_call2 (Lisp_Object cons)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4801 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4802 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4803 return call2 (XCAR (cons), XCAR (XCDR (cons)), XCAR (XCDR (XCDR (cons))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4804 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4805
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4806 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4807 call1_trapping_errors (const CIntbyte *warning_string, Lisp_Object function,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4808 Lisp_Object object)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4809 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4810 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4811 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4812 Lisp_Object cons = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4813 Lisp_Object opaque = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4814 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4815
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4816 if (SYMBOLP (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4817 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4818 tem = XSYMBOL (function)->function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4819 if (NILP (tem) || UNBOUNDP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4820 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4821 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4822
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4823 GCPRO4 (cons, opaque, function, object);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4824
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4825 specbind (Qinhibit_quit, Qt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
4826 /* begin_gc_forbidden(); Currently no reason to do this; */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4827
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4828 cons = noseeum_cons (function, object);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4829 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4830 /* Qerror not Qt, so you can get a backtrace */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4831 tem = condition_case_1 (Qerror,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4832 catch_them_squirmers_call1, cons,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4833 caught_a_squirmer, opaque);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4834 if (OPAQUE_PTRP (opaque))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4835 free_opaque_ptr (opaque);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4836 free_cons (XCONS (cons));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4837 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4838
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
4839 return unbind_to_1 (speccount, tem);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4840 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4841
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4842 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4843 call2_trapping_errors (const CIntbyte *warning_string, Lisp_Object function,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4844 Lisp_Object object1, Lisp_Object object2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4845 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4846 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4847 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4848 Lisp_Object cons = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4849 Lisp_Object opaque = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4850 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4851
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4852 if (SYMBOLP (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4853 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4854 tem = XSYMBOL (function)->function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4855 if (NILP (tem) || UNBOUNDP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4856 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4857 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4858
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4859 GCPRO5 (cons, opaque, function, object1, object2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4860 specbind (Qinhibit_quit, Qt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
4861 /* begin_gc_forbidden(); Currently no reason to do this; */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4862
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4863 cons = list3 (function, object1, object2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4864 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4865 /* Qerror not Qt, so you can get a backtrace */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4866 tem = condition_case_1 (Qerror,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4867 catch_them_squirmers_call2, cons,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4868 caught_a_squirmer, opaque);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4869 if (OPAQUE_PTRP (opaque))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4870 free_opaque_ptr (opaque);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4871 free_list (cons);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4872 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4873
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
4874 return unbind_to_1 (speccount, tem);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4875 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4876
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4877
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4878 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4879 /* The special binding stack */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
4880 /* Most C code should simply use specbind() and unbind_to_1(). */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4881 /* When performance is critical, use the macros in backtrace.h. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4882 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4883
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4884 #define min_max_specpdl_size 400
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4885
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4886 void
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
4887 grow_specpdl (EMACS_INT reserved)
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
4888 {
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
4889 EMACS_INT size_needed = specpdl_depth() + reserved;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4890 if (size_needed >= max_specpdl_size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4891 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4892 if (max_specpdl_size < min_max_specpdl_size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4893 max_specpdl_size = min_max_specpdl_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4894 if (size_needed >= max_specpdl_size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4895 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4896 if (!NILP (Vdebug_on_error) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4897 !NILP (Vdebug_on_signal))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4898 /* Leave room for some specpdl in the debugger. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4899 max_specpdl_size = size_needed + 100;
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
4900 signal_continuable_error
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
4901 (Qstack_overflow,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
4902 "Variable binding depth exceeds max-specpdl-size", Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4903 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4904 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4905 while (specpdl_size < size_needed)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4906 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4907 specpdl_size *= 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4908 if (specpdl_size > max_specpdl_size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4909 specpdl_size = max_specpdl_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4910 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4911 XREALLOC_ARRAY (specpdl, struct specbinding, specpdl_size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4912 specpdl_ptr = specpdl + specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4913 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4914
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4915
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4916 /* Handle unbinding buffer-local variables */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4917 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4918 specbind_unwind_local (Lisp_Object ovalue)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4919 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4920 Lisp_Object current = Fcurrent_buffer ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4921 Lisp_Object symbol = specpdl_ptr->symbol;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
4922 Lisp_Cons *victim = XCONS (ovalue);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4923 Lisp_Object buf = get_buffer (victim->car, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4924 ovalue = victim->cdr;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4925
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4926 free_cons (victim);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4927
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4928 if (NILP (buf))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4929 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4930 /* Deleted buffer -- do nothing */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4931 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4932 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buf)) == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4933 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4934 /* Was buffer-local when binding was made, now no longer is.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4935 * (kill-local-variable can do this.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4936 * Do nothing in this case.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4937 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4938 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4939 else if (EQ (buf, current))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4940 Fset (symbol, ovalue);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4941 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4942 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4943 /* Urk! Somebody switched buffers */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4944 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4945 GCPRO1 (current);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4946 Fset_buffer (buf);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4947 Fset (symbol, ovalue);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4948 Fset_buffer (current);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4949 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4950 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4951 return symbol;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4952 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4953
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4954 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4955 specbind_unwind_wasnt_local (Lisp_Object buffer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4956 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4957 Lisp_Object current = Fcurrent_buffer ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4958 Lisp_Object symbol = specpdl_ptr->symbol;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4959
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4960 buffer = get_buffer (buffer, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4961 if (NILP (buffer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4962 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4963 /* Deleted buffer -- do nothing */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4964 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4965 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buffer)) == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4966 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4967 /* Was buffer-local when binding was made, now no longer is.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4968 * (kill-local-variable can do this.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4969 * Do nothing in this case.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4970 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4971 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4972 else if (EQ (buffer, current))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4973 Fkill_local_variable (symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4974 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4975 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4976 /* Urk! Somebody switched buffers */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4977 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4978 GCPRO1 (current);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4979 Fset_buffer (buffer);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4980 Fkill_local_variable (symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4981 Fset_buffer (current);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4982 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4983 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4984 return symbol;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4985 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4986
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4987
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4988 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4989 specbind (Lisp_Object symbol, Lisp_Object value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4990 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4991 SPECBIND (symbol, value);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4992 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4993
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4994 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4995 specbind_magic (Lisp_Object symbol, Lisp_Object value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4996 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4997 int buffer_local =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4998 symbol_value_buffer_local_info (symbol, current_buffer);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4999
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5000 if (buffer_local == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5001 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5002 specpdl_ptr->old_value = find_symbol_value (symbol);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5003 specpdl_ptr->func = 0; /* Handled specially by unbind_to_1 */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5004 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5005 else if (buffer_local > 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5006 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5007 /* Already buffer-local */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5008 specpdl_ptr->old_value = noseeum_cons (Fcurrent_buffer (),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5009 find_symbol_value (symbol));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5010 specpdl_ptr->func = specbind_unwind_local;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5011 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5012 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5013 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5014 /* About to become buffer-local */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5015 specpdl_ptr->old_value = Fcurrent_buffer ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5016 specpdl_ptr->func = specbind_unwind_wasnt_local;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5017 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5018
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5019 specpdl_ptr->symbol = symbol;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5020 specpdl_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5021 specpdl_depth_counter++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5022
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5023 Fset (symbol, value);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5024 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5025
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5026 /* Record an unwind-protect -- FUNCTION will be called with ARG no matter
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5027 whether a normal or non-local exit occurs. (You need to call unbind_to_1()
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5028 before your function returns normally, passing in the integer returned
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5029 by this function.) Note: As long as the unwind-protect exists, ARG is
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5030 automatically GCPRO'd. The return value from FUNCTION is completely
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5031 ignored. #### We should eliminate it entirely. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5032
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5033 int
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5034 record_unwind_protect (Lisp_Object (*function) (Lisp_Object arg),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5035 Lisp_Object arg)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5036 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5037 SPECPDL_RESERVE (1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5038 specpdl_ptr->func = function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5039 specpdl_ptr->symbol = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5040 specpdl_ptr->old_value = arg;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5041 specpdl_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5042 specpdl_depth_counter++;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5043 return specpdl_depth_counter - 1;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5044 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5045
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5046 static Lisp_Object
802
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5047 restore_lisp_object (Lisp_Object cons)
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5048 {
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5049 Lisp_Object opaque = XCAR (cons);
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5050 Lisp_Object *addr = (Lisp_Object *) get_opaque_ptr (opaque);
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5051 *addr = XCDR (cons);
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5052 free_opaque_ptr (opaque);
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5053 free_cons (XCONS (cons));
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5054 return Qnil;
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5055 }
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5056
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5057 /* Establish an unwind-protect which will restore the Lisp_Object pointed to
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5058 by ADDR with the value VAL. */
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
5059 static int
802
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5060 record_unwind_protect_restoring_lisp_object (Lisp_Object *addr,
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5061 Lisp_Object val)
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5062 {
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5063 Lisp_Object opaque = make_opaque_ptr (addr);
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5064 return record_unwind_protect (restore_lisp_object,
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5065 noseeum_cons (opaque, val));
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5066 }
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5067
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5068 /* Similar to specbind() but for any C variable whose value is a
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5069 Lisp_Object. Sets up an unwind-protect to restore the variable
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5070 pointed to by ADDR to its existing value, and then changes its
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5071 value to NEWVAL. Returns the previous value of specpdl_depth();
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5072 pass this to unbind_to() after you are done. */
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5073 int
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5074 internal_bind_lisp_object (Lisp_Object *addr, Lisp_Object newval)
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5075 {
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5076 int count = specpdl_depth ();
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5077 record_unwind_protect_restoring_lisp_object (addr, *addr);
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5078 *addr = newval;
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5079 return count;
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5080 }
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5081
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5082 static Lisp_Object
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5083 restore_int (Lisp_Object cons)
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5084 {
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5085 Lisp_Object opaque = XCAR (cons);
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5086 Lisp_Object lval = XCDR (cons);
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5087 int *addr = (int *) get_opaque_ptr (opaque);
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5088 int val;
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5089
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5090 if (INTP (lval))
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5091 val = XINT (lval);
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5092 else
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5093 {
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5094 val = (int) get_opaque_ptr (lval);
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5095 free_opaque_ptr (lval);
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5096 }
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5097
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5098 *addr = val;
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5099 free_opaque_ptr (opaque);
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5100 free_cons (XCONS (cons));
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5101 return Qnil;
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5102 }
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5103
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5104 /* Establish an unwind-protect which will restore the int pointed to
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5105 by ADDR with the value VAL. This function works correctly with
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5106 all ints, even those that don't fit into a Lisp integer. */
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
5107 static int
802
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5108 record_unwind_protect_restoring_int (int *addr, int val)
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5109 {
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5110 Lisp_Object opaque = make_opaque_ptr (addr);
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5111 Lisp_Object lval;
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5112
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5113 if (NUMBER_FITS_IN_AN_EMACS_INT (val))
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5114 lval = make_int (val);
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5115 else
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5116 lval = make_opaque_ptr ((void *) val);
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5117 return record_unwind_protect (restore_int, noseeum_cons (opaque, lval));
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5118 }
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5119
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5120 /* Similar to specbind() but for any C variable whose value is an int.
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5121 Sets up an unwind-protect to restore the variable pointed to by
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5122 ADDR to its existing value, and then changes its value to NEWVAL.
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5123 Returns the previous value of specpdl_depth(); pass this to
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5124 unbind_to() after you are done. This function works correctly with
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5125 all ints, even those that don't fit into a Lisp integer. */
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5126 int
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5127 internal_bind_int (int *addr, int newval)
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5128 {
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5129 int count = specpdl_depth ();
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5130 record_unwind_protect_restoring_int (addr, *addr);
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5131 *addr = newval;
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5132 return count;
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5133 }
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5134
19dfb459d51a [xemacs-hg @ 2002-04-03 10:47:37 by ben]
ben
parents: 801
diff changeset
5135 static Lisp_Object
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5136 free_pointer (Lisp_Object opaque)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5137 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5138 xfree (get_opaque_ptr (opaque));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5139 free_opaque_ptr (opaque);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5140 return Qnil;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5141 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5142
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5143 /* Establish an unwind-protect which will free the specified block.
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5144 */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5145 int
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5146 record_unwind_protect_freeing (void *ptr)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5147 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5148 Lisp_Object opaque = make_opaque_ptr (ptr);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5149 return record_unwind_protect (free_pointer, opaque);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5150 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5151
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5152 static Lisp_Object
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5153 free_dynarr (Lisp_Object opaque)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5154 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5155 Dynarr_free (get_opaque_ptr (opaque));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5156 free_opaque_ptr (opaque);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5157 return Qnil;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5158 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5159
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5160 int
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5161 record_unwind_protect_freeing_dynarr (void *ptr)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5162 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5163 Lisp_Object opaque = make_opaque_ptr (ptr);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5164 return record_unwind_protect (free_dynarr, opaque);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5165 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5166
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5167 /* Unwind the stack till specpdl_depth() == COUNT.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5168 VALUE is not used, except that, purely as a convenience to the
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5169 caller, it is protected from garbage-protection and returned. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5170 Lisp_Object
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5171 unbind_to_1 (int count, Lisp_Object value)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5172 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5173 UNBIND_TO_GCPRO (count, value);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5174 return value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5175 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5176
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5177 /* Don't call this directly.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5178 Only for use by UNBIND_TO* macros in backtrace.h */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5179 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5180 unbind_to_hairy (int count)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5181 {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5182 Lisp_Object oquit;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5183
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5184 ++specpdl_ptr;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5185 ++specpdl_depth_counter;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5186
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5187 /* Allow QUIT within unwind-protect routines, but defer any existing QUIT
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5188 until afterwards. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5189 check_quit (); /* make Vquit_flag accurate */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5190 oquit = Vquit_flag;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5191 Vquit_flag = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5192
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5193 while (specpdl_depth_counter != count)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5194 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5195 --specpdl_ptr;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5196 --specpdl_depth_counter;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5197
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5198 if (specpdl_ptr->func != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5199 /* An unwind-protect */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5200 (*specpdl_ptr->func) (specpdl_ptr->old_value);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5201 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5202 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5203 /* We checked symbol for validity when we specbound it,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5204 so only need to call Fset if symbol has magic value. */
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
5205 Lisp_Symbol *sym = XSYMBOL (specpdl_ptr->symbol);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5206 if (!SYMBOL_VALUE_MAGIC_P (sym->value))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5207 sym->value = specpdl_ptr->old_value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5208 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5209 Fset (specpdl_ptr->symbol, specpdl_ptr->old_value);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5210 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5211
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5212 #if 0 /* martin */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5213 #ifndef EXCEEDINGLY_QUESTIONABLE_CODE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5214 /* There should never be anything here for us to remove.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5215 If so, it indicates a logic error in Emacs. Catches
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5216 should get removed when a throw or signal occurs, or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5217 when a catch or condition-case exits normally. But
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5218 it's too dangerous to just remove this code. --ben */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5219
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5220 /* Furthermore, this code is not in FSFmacs!!!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5221 Braino on mly's part? */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5222 /* If we're unwound past the pdlcount of a catch frame,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5223 that catch can't possibly still be valid. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5224 while (catchlist && catchlist->pdlcount > specpdl_depth_counter)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5225 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5226 catchlist = catchlist->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5227 /* Don't mess with gcprolist, backtrace_list here */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5228 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5229 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5230 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5231 }
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5232 Vquit_flag = oquit;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5233 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5234
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5235
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5236
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5237 /* Get the value of symbol's global binding, even if that binding is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5238 not now dynamically visible. May return Qunbound or magic values. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5239
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5240 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5241 top_level_value (Lisp_Object symbol)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5242 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5243 REGISTER struct specbinding *ptr = specpdl;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5244
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5245 CHECK_SYMBOL (symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5246 for (; ptr != specpdl_ptr; ptr++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5247 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5248 if (EQ (ptr->symbol, symbol))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5249 return ptr->old_value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5250 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5251 return XSYMBOL (symbol)->value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5252 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5253
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5254 #if 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5255
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5256 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5257 top_level_set (Lisp_Object symbol, Lisp_Object newval)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5258 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5259 REGISTER struct specbinding *ptr = specpdl;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5260
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5261 CHECK_SYMBOL (symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5262 for (; ptr != specpdl_ptr; ptr++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5263 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5264 if (EQ (ptr->symbol, symbol))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5265 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5266 ptr->old_value = newval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5267 return newval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5268 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5269 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5270 return Fset (symbol, newval);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5271 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5272
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5273 #endif /* 0 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5274
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5275
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5276 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5277 /* Backtraces */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5278 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5279
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5280 DEFUN ("backtrace-debug", Fbacktrace_debug, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5281 Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5282 The debugger is entered when that frame exits, if the flag is non-nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5283 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5284 (level, flag))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5285 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5286 REGISTER struct backtrace *backlist = backtrace_list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5287 REGISTER int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5288
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5289 CHECK_INT (level);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5290
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5291 for (i = 0; backlist && i < XINT (level); i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5292 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5293 backlist = backlist->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5294 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5295
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5296 if (backlist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5297 backlist->debug_on_exit = !NILP (flag);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5298
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5299 return flag;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5300 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5301
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5302 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5303 backtrace_specials (int speccount, int speclimit, Lisp_Object stream)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5304 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5305 int printing_bindings = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5306
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5307 for (; speccount > speclimit; speccount--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5308 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5309 if (specpdl[speccount - 1].func == 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5310 || specpdl[speccount - 1].func == specbind_unwind_local
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5311 || specpdl[speccount - 1].func == specbind_unwind_wasnt_local)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5312 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5313 write_c_string (((!printing_bindings) ? " # bind (" : " "),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5314 stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5315 Fprin1 (specpdl[speccount - 1].symbol, stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5316 printing_bindings = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5317 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5318 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5319 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5320 if (printing_bindings) write_c_string (")\n", stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5321 write_c_string (" # (unwind-protect ...)\n", stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5322 printing_bindings = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5323 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5324 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5325 if (printing_bindings) write_c_string (")\n", stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5326 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5327
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5328 DEFUN ("backtrace", Fbacktrace, 0, 2, "", /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5329 Print a trace of Lisp function calls currently active.
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 436
diff changeset
5330 Optional arg STREAM specifies the output stream to send the backtrace to,
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
5331 and defaults to the value of `standard-output'.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
5332 Optional second arg DETAILED non-nil means show places where currently
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
5333 active variable bindings, catches, condition-cases, and
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
5334 unwind-protects, as well as function calls, were made.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5335 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5336 (stream, detailed))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5337 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5338 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5339 struct backtrace *backlist = backtrace_list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5340 struct catchtag *catches = catchlist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5341 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5342
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5343 int old_nl = print_escape_newlines;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5344 int old_pr = print_readably;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5345 Lisp_Object old_level = Vprint_level;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5346 Lisp_Object oiq = Vinhibit_quit;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5347 struct gcpro gcpro1, gcpro2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5348
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5349 /* We can't allow quits in here because that could cause the values
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5350 of print_readably and print_escape_newlines to get screwed up.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5351 Normally we would use a record_unwind_protect but that would
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5352 screw up the functioning of this function. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5353 Vinhibit_quit = Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5354
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5355 entering_debugger = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5356
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5357 Vprint_level = make_int (3);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5358 print_readably = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5359 print_escape_newlines = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5360
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5361 GCPRO2 (stream, old_level);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5362
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5363 if (NILP (stream))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5364 stream = Vstandard_output;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5365 if (!noninteractive && (NILP (stream) || EQ (stream, Qt)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5366 stream = Fselected_frame (Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5367
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5368 for (;;)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5369 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5370 if (!NILP (detailed) && catches && catches->backlist == backlist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5371 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5372 int catchpdl = catches->pdlcount;
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 436
diff changeset
5373 if (speccount > catchpdl
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 436
diff changeset
5374 && specpdl[catchpdl].func == condition_case_unwind)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5375 /* This is a condition-case catchpoint */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5376 catchpdl = catchpdl + 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5377
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5378 backtrace_specials (speccount, catchpdl, stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5379
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5380 speccount = catches->pdlcount;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5381 if (catchpdl == speccount)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5382 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5383 write_c_string (" # (catch ", stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5384 Fprin1 (catches->tag, stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5385 write_c_string (" ...)\n", stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5386 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5387 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5388 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5389 write_c_string (" # (condition-case ... . ", stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5390 Fprin1 (Fcdr (Fcar (catches->tag)), stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5391 write_c_string (")\n", stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5392 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5393 catches = catches->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5394 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5395 else if (!backlist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5396 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5397 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5398 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5399 if (!NILP (detailed) && backlist->pdlcount < speccount)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5400 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5401 backtrace_specials (speccount, backlist->pdlcount, stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5402 speccount = backlist->pdlcount;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5403 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5404 write_c_string (((backlist->debug_on_exit) ? "* " : " "),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5405 stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5406 if (backlist->nargs == UNEVALLED)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5407 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5408 Fprin1 (Fcons (*backlist->function, *backlist->args), stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5409 write_c_string ("\n", stream); /* from FSFmacs 19.30 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5410 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5411 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5412 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5413 Lisp_Object tem = *backlist->function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5414 Fprin1 (tem, stream); /* This can QUIT */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5415 write_c_string ("(", stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5416 if (backlist->nargs == MANY)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5417 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5418 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5419 Lisp_Object tail = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5420 struct gcpro ngcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5421
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5422 NGCPRO1 (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5423 for (tail = *backlist->args, i = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5424 !NILP (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5425 tail = Fcdr (tail), i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5426 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5427 if (i != 0) write_c_string (" ", stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5428 Fprin1 (Fcar (tail), stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5429 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5430 NUNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5431 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5432 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5433 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5434 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5435 for (i = 0; i < backlist->nargs; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5436 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5437 if (!i && EQ(tem, Qbyte_code)) {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5438 write_c_string("\"...\"", stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5439 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5440 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5441 if (i != 0) write_c_string (" ", stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5442 Fprin1 (backlist->args[i], stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5443 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5444 }
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5445 write_c_string (")\n", stream);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5446 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5447 backlist = backlist->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5448 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5449 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5450 Vprint_level = old_level;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5451 print_readably = old_pr;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5452 print_escape_newlines = old_nl;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5453 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5454 Vinhibit_quit = oiq;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5455 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5456 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5457
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5458
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
5459 DEFUN ("backtrace-frame", Fbacktrace_frame, 1, 1, 0, /*
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
5460 Return the function and arguments NFRAMES up from current execution point.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5461 If that frame has not evaluated the arguments yet (or is a special form),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5462 the value is (nil FUNCTION ARG-FORMS...).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5463 If that frame has evaluated its arguments and called its function already,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5464 the value is (t FUNCTION ARG-VALUES...).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5465 A &rest arg is represented as the tail of the list ARG-VALUES.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5466 FUNCTION is whatever was supplied as car of evaluated list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5467 or a lambda expression for macro calls.
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
5468 If NFRAMES is more than the number of frames, the value is nil.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5469 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5470 (nframes))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5471 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5472 REGISTER struct backtrace *backlist = backtrace_list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5473 REGISTER int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5474 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5475
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5476 CHECK_NATNUM (nframes);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5477
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5478 /* Find the frame requested. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5479 for (i = XINT (nframes); backlist && (i-- > 0);)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5480 backlist = backlist->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5481
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5482 if (!backlist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5483 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5484 if (backlist->nargs == UNEVALLED)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5485 return Fcons (Qnil, Fcons (*backlist->function, *backlist->args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5486 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5487 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5488 if (backlist->nargs == MANY)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5489 tem = *backlist->args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5490 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5491 tem = Flist (backlist->nargs, backlist->args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5492
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5493 return Fcons (Qt, Fcons (*backlist->function, tem));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5494 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5495 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5496
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5497
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5498 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5499 /* Warnings */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5500 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5501
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5502 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5503 warn_when_safe_lispobj (Lisp_Object class, Lisp_Object level,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5504 Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5505 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
5506 /* Don't even generate debug warnings if they're going to be discarded,
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
5507 to avoid excessive consing. */
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
5508 if (EQ (level, Qdebug) && !NILP (Vlog_warning_minimum_level) &&
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
5509 !EQ (Vlog_warning_minimum_level, Qdebug))
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
5510 return;
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
5511
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5512 obj = list1 (list3 (class, level, obj));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5513 if (NILP (Vpending_warnings))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5514 Vpending_warnings = Vpending_warnings_tail = obj;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5515 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5516 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5517 Fsetcdr (Vpending_warnings_tail, obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5518 Vpending_warnings_tail = obj;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5519 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5520 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5521
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5522 /* #### This should probably accept Lisp objects; but then we have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5523 to make sure that Feval() isn't called, since it might not be safe.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5524
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5525 An alternative approach is to just pass some non-string type of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5526 Lisp_Object to warn_when_safe_lispobj(); `prin1-to-string' will
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5527 automatically be called when it is safe to do so. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5528
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5529 void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
5530 warn_when_safe (Lisp_Object class, Lisp_Object level, const CIntbyte *fmt, ...)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5531 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5532 Lisp_Object obj;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5533 va_list args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5534
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
5535 /* Don't even generate debug warnings if they're going to be discarded,
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
5536 to avoid excessive consing. */
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
5537 if (EQ (level, Qdebug) && !NILP (Vlog_warning_minimum_level) &&
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
5538 !EQ (Vlog_warning_minimum_level, Qdebug))
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
5539 return;
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
5540
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5541 va_start (args, fmt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5542 obj = emacs_vsprintf_string (CGETTEXT (fmt), args);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5543 va_end (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5544
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5545 warn_when_safe_lispobj (class, level, obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5546 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5547
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5548
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5549
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5550
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5551 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5552 /* Initialization */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5553 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5554
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5555 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5556 syms_of_eval (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5557 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5558 INIT_LRECORD_IMPLEMENTATION (subr);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5559
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5560 DEFSYMBOL (Qinhibit_quit);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5561 DEFSYMBOL (Qautoload);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5562 DEFSYMBOL (Qdebug_on_error);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5563 DEFSYMBOL (Qstack_trace_on_error);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5564 DEFSYMBOL (Qdebug_on_signal);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5565 DEFSYMBOL (Qstack_trace_on_signal);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5566 DEFSYMBOL (Qdebugger);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5567 DEFSYMBOL (Qmacro);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5568 defsymbol (&Qand_rest, "&rest");
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5569 defsymbol (&Qand_optional, "&optional");
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5570 /* Note that the process code also uses Qexit */
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5571 DEFSYMBOL (Qexit);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5572 DEFSYMBOL (Qsetq);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5573 DEFSYMBOL (Qinteractive);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5574 DEFSYMBOL (Qcommandp);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5575 DEFSYMBOL (Qdefun);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5576 DEFSYMBOL (Qprogn);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5577 DEFSYMBOL (Qvalues);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5578 DEFSYMBOL (Qdisplay_warning);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5579 DEFSYMBOL (Qrun_hooks);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5580 DEFSYMBOL (Qif);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5581
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5582 DEFSUBR (For);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5583 DEFSUBR (Fand);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5584 DEFSUBR (Fif);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5585 DEFSUBR_MACRO (Fwhen);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5586 DEFSUBR_MACRO (Funless);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5587 DEFSUBR (Fcond);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5588 DEFSUBR (Fprogn);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5589 DEFSUBR (Fprog1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5590 DEFSUBR (Fprog2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5591 DEFSUBR (Fsetq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5592 DEFSUBR (Fquote);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5593 DEFSUBR (Ffunction);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5594 DEFSUBR (Fdefun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5595 DEFSUBR (Fdefmacro);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5596 DEFSUBR (Fdefvar);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5597 DEFSUBR (Fdefconst);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5598 DEFSUBR (Fuser_variable_p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5599 DEFSUBR (Flet);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5600 DEFSUBR (FletX);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5601 DEFSUBR (Fwhile);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5602 DEFSUBR (Fmacroexpand_internal);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5603 DEFSUBR (Fcatch);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5604 DEFSUBR (Fthrow);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5605 DEFSUBR (Funwind_protect);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5606 DEFSUBR (Fcondition_case);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5607 DEFSUBR (Fcall_with_condition_handler);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5608 DEFSUBR (Fsignal);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5609 DEFSUBR (Finteractive_p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5610 DEFSUBR (Fcommandp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5611 DEFSUBR (Fcommand_execute);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5612 DEFSUBR (Fautoload);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5613 DEFSUBR (Feval);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5614 DEFSUBR (Fapply);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5615 DEFSUBR (Ffuncall);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5616 DEFSUBR (Ffunctionp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5617 DEFSUBR (Ffunction_min_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5618 DEFSUBR (Ffunction_max_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5619 DEFSUBR (Frun_hooks);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5620 DEFSUBR (Frun_hook_with_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5621 DEFSUBR (Frun_hook_with_args_until_success);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5622 DEFSUBR (Frun_hook_with_args_until_failure);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5623 DEFSUBR (Fbacktrace_debug);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5624 DEFSUBR (Fbacktrace);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5625 DEFSUBR (Fbacktrace_frame);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5626 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5627
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5628 void
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 802
diff changeset
5629 init_eval_semi_early (void)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5630 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5631 specpdl_ptr = specpdl;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5632 specpdl_depth_counter = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5633 catchlist = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5634 Vcondition_handlers = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5635 backtrace_list = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5636 Vquit_flag = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5637 debug_on_next_call = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5638 lisp_eval_depth = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5639 entering_debugger = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5640 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5641
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5642 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5643 reinit_vars_of_eval (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5644 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5645 preparing_for_armageddon = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5646 in_warnings = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5647 Qunbound_suspended_errors_tag = make_opaque_ptr (&Qunbound_suspended_errors_tag);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5648 staticpro_nodump (&Qunbound_suspended_errors_tag);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5649
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5650 specpdl_size = 50;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5651 specpdl = xnew_array (struct specbinding, specpdl_size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5652 /* XEmacs change: increase these values. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5653 max_specpdl_size = 3000;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5654 max_lisp_eval_depth = 1000;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5655 #ifdef DEFEND_AGAINST_THROW_RECURSION
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5656 throw_level = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5657 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5658 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5659
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5660 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5661 vars_of_eval (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5662 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5663 reinit_vars_of_eval ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5664
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5665 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5666 Limit on number of Lisp variable bindings & unwind-protects before error.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5667 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5668
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5669 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5670 Limit on depth in `eval', `apply' and `funcall' before error.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5671 This limit is to catch infinite recursions for you before they cause
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5672 actual stack overflow in C, which would be fatal for Emacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5673 You can safely make it considerably larger than its default value,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5674 if that proves inconveniently small.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5675 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5676
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5677 DEFVAR_LISP ("quit-flag", &Vquit_flag /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5678 Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5679 Typing C-G sets `quit-flag' non-nil, regardless of `inhibit-quit'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5680 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5681 Vquit_flag = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5682
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5683 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5684 Non-nil inhibits C-g quitting from happening immediately.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5685 Note that `quit-flag' will still be set by typing C-g,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5686 so a quit will be signalled as soon as `inhibit-quit' is nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5687 To prevent this happening, set `quit-flag' to nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5688 before making `inhibit-quit' nil. The value of `inhibit-quit' is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5689 ignored if a critical quit is requested by typing control-shift-G in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5690 an X frame.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5691 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5692 Vinhibit_quit = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5693
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5694 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5695 *Non-nil means automatically display a backtrace buffer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5696 after any error that is not handled by a `condition-case'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5697 If the value is a list, an error only means to display a backtrace
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5698 if one of its condition symbols appears in the list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5699 See also variable `stack-trace-on-signal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5700 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5701 Vstack_trace_on_error = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5702
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5703 DEFVAR_LISP ("stack-trace-on-signal", &Vstack_trace_on_signal /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5704 *Non-nil means automatically display a backtrace buffer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5705 after any error that is signalled, whether or not it is handled by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5706 a `condition-case'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5707 If the value is a list, an error only means to display a backtrace
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5708 if one of its condition symbols appears in the list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5709 See also variable `stack-trace-on-error'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5710 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5711 Vstack_trace_on_signal = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5712
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5713 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5714 *List of errors for which the debugger should not be called.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5715 Each element may be a condition-name or a regexp that matches error messages.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5716 If any element applies to a given error, that error skips the debugger
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5717 and just returns to top level.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5718 This overrides the variable `debug-on-error'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5719 It does not apply to errors handled by `condition-case'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5720 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5721 Vdebug_ignored_errors = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5722
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5723 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5724 *Non-nil means enter debugger if an unhandled error is signalled.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5725 The debugger will not be entered if the error is handled by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5726 a `condition-case'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5727 If the value is a list, an error only means to enter the debugger
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5728 if one of its condition symbols appears in the list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5729 This variable is overridden by `debug-ignored-errors'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5730 See also variables `debug-on-quit' and `debug-on-signal'.
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5731 If this variable is set while XEmacs is running noninteractively,
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5732 an unhandled error will cause a backtrace to be output and the C
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5733 debugger entered using `force-debugging-signal'. This can be very
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5734 useful when debugging noninteractive errors in tricky situations,
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5735 e.g. makefiles, since you can set this variable using an environment
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5736 variable, like this:
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5737
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5738 \(using csh) setenv XEMACSDEBUG '(setq debug-on-error t)'
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5739 \(using bash) export XEMACSDEBUG='(setq debug-on-error t)'
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5740 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5741 Vdebug_on_error = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5742
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5743 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5744 *Non-nil means enter debugger if an error is signalled.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5745 The debugger will be entered whether or not the error is handled by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5746 a `condition-case'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5747 If the value is a list, an error only means to enter the debugger
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5748 if one of its condition symbols appears in the list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5749 See also variable `debug-on-quit'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5750 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5751 Vdebug_on_signal = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5752
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5753 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5754 *Non-nil means enter debugger if quit is signalled (C-G, for example).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5755 Does not apply if quit is handled by a `condition-case'. Entering the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5756 debugger can also be achieved at any time (for X11 console) by typing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5757 control-shift-G to signal a critical quit.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5758 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5759 debug_on_quit = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5760
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5761 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5762 Non-nil means enter debugger before next `eval', `apply' or `funcall'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5763 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5764
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5765 DEFVAR_LISP ("debugger", &Vdebugger /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5766 Function to call to invoke debugger.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5767 If due to frame exit, args are `exit' and the value being returned;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5768 this function's value will be returned instead of that.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5769 If due to error, args are `error' and a list of the args to `signal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5770 If due to `apply' or `funcall' entry, one arg, `lambda'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5771 If due to `eval' entry, one arg, t.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5772 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5773 Vdebugger = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5774
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5775 staticpro (&Vpending_warnings);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5776 Vpending_warnings = Qnil;
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 444
diff changeset
5777 dump_add_root_object (&Vpending_warnings_tail);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5778 Vpending_warnings_tail = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5779
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
5780 DEFVAR_LISP ("log-warning-minimum-level", &Vlog_warning_minimum_level);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
5781 Vlog_warning_minimum_level = Qinfo;
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
5782
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5783 staticpro (&Vautoload_queue);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5784 Vautoload_queue = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5785
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5786 staticpro (&Vcondition_handlers);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5787
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5788 staticpro (&Vcurrent_warning_class);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5789 Vcurrent_warning_class = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5790
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
5791 staticpro (&Vcurrent_warning_level);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
5792 Vcurrent_warning_level = Qnil;
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
5793
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5794 staticpro (&Vcurrent_error_state);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5795 Vcurrent_error_state = Qnil; /* errors as normal */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 733
diff changeset
5796 }