annotate src/eval.c @ 665:fdefd0186b75

[xemacs-hg @ 2001-09-20 06:28:42 by ben] The great integral types renaming. The purpose of this is to rationalize the names used for various integral types, so that they match their intended uses and follow consist conventions, and eliminate types that were not semantically different from each other. The conventions are: -- All integral types that measure quantities of anything are signed. Some people disagree vociferously with this, but their arguments are mostly theoretical, and are vastly outweighed by the practical headaches of mixing signed and unsigned values, and more importantly by the far increased likelihood of inadvertent bugs: Because of the broken "viral" nature of unsigned quantities in C (operations involving mixed signed/unsigned are done unsigned, when exactly the opposite is nearly always wanted), even a single error in declaring a quantity unsigned that should be signed, or even the even more subtle error of comparing signed and unsigned values and forgetting the necessary cast, can be catastrophic, as comparisons will yield wrong results. -Wsign-compare is turned on specifically to catch this, but this tends to result in a great number of warnings when mixing signed and unsigned, and the casts are annoying. More has been written on this elsewhere. -- All such quantity types just mentioned boil down to EMACS_INT, which is 32 bits on 32-bit machines and 64 bits on 64-bit machines. This is guaranteed to be the same size as Lisp objects of type `int', and (as far as I can tell) of size_t (unsigned!) and ssize_t. The only type below that is not an EMACS_INT is Hashcode, which is an unsigned value of the same size as EMACS_INT. -- Type names should be relatively short (no more than 10 characters or so), with the first letter capitalized and no underscores if they can at all be avoided. -- "count" == a zero-based measurement of some quantity. Includes sizes, offsets, and indexes. -- "bpos" == a one-based measurement of a position in a buffer. "Charbpos" and "Bytebpos" count text in the buffer, rather than bytes in memory; thus Bytebpos does not directly correspond to the memory representation. Use "Membpos" for this. -- "Char" refers to internal-format characters, not to the C type "char", which is really a byte. -- For the actual name changes, see the script below. I ran the following script to do the conversion. (NOTE: This script is idempotent. You can safely run it multiple times and it will not screw up previous results -- in fact, it will do nothing if nothing has changed. Thus, it can be run repeatedly as necessary to handle patches coming in from old workspaces, or old branches.) There are two tags, just before and just after the change: `pre-integral-type-rename' and `post-integral-type-rename'. When merging code from the main trunk into a branch, the best thing to do is first merge up to `pre-integral-type-rename', then apply the script and associated changes, then merge from `post-integral-type-change' to the present. (Alternatively, just do the merging in one operation; but you may then have a lot of conflicts needing to be resolved by hand.) Script `fixtypes.sh' follows: ----------------------------------- cut ------------------------------------ files="*.[ch] s/*.h m/*.h config.h.in ../configure.in Makefile.in.in ../lib-src/*.[ch] ../lwlib/*.[ch]" gr Memory_Count Bytecount $files gr Lstream_Data_Count Bytecount $files gr Element_Count Elemcount $files gr Hash_Code Hashcode $files gr extcount bytecount $files gr bufpos charbpos $files gr bytind bytebpos $files gr memind membpos $files gr bufbyte intbyte $files gr Extcount Bytecount $files gr Bufpos Charbpos $files gr Bytind Bytebpos $files gr Memind Membpos $files gr Bufbyte Intbyte $files gr EXTCOUNT BYTECOUNT $files gr BUFPOS CHARBPOS $files gr BYTIND BYTEBPOS $files gr MEMIND MEMBPOS $files gr BUFBYTE INTBYTE $files gr MEMORY_COUNT BYTECOUNT $files gr LSTREAM_DATA_COUNT BYTECOUNT $files gr ELEMENT_COUNT ELEMCOUNT $files gr HASH_CODE HASHCODE $files ----------------------------------- cut ------------------------------------ `fixtypes.sh' is a Bourne-shell script; it uses 'gr': ----------------------------------- cut ------------------------------------ #!/bin/sh # Usage is like this: # gr FROM TO FILES ... # globally replace FROM with TO in FILES. FROM and TO are regular expressions. # backup files are stored in the `backup' directory. from="$1" to="$2" shift 2 echo ${1+"$@"} | xargs global-replace "s/$from/$to/g" ----------------------------------- cut ------------------------------------ `gr' in turn uses a Perl script to do its real work, `global-replace', which follows: ----------------------------------- cut ------------------------------------ : #-*- Perl -*- ### global-modify --- modify the contents of a file by a Perl expression ## Copyright (C) 1999 Martin Buchholz. ## Copyright (C) 2001 Ben Wing. ## Authors: Martin Buchholz <martin@xemacs.org>, Ben Wing <ben@xemacs.org> ## Maintainer: Ben Wing <ben@xemacs.org> ## Current Version: 1.0, May 5, 2001 # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # General Public License for more details. # # You should have received a copy of the GNU General Public License # along with XEmacs; see the file COPYING. If not, write to the Free # Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA # 02111-1307, USA. eval 'exec perl -w -S $0 ${1+"$@"}' if 0; use strict; use FileHandle; use Carp; use Getopt::Long; use File::Basename; (my $myName = $0) =~ s@.*/@@; my $usage=" Usage: $myName [--help] [--backup-dir=DIR] [--line-mode] [--hunk-mode] PERLEXPR FILE ... Globally modify a file, either line by line or in one big hunk. Typical usage is like this: [with GNU print, GNU xargs: guaranteed to handle spaces, quotes, etc. in file names] find . -name '*.[ch]' -print0 | xargs -0 $0 's/\bCONST\b/const/g'\n [with non-GNU print, xargs] find . -name '*.[ch]' -print | xargs $0 's/\bCONST\b/const/g'\n The file is read in, either line by line (with --line-mode specified) or in one big hunk (with --hunk-mode specified; it's the default), and the Perl expression is then evalled with \$_ set to the line or hunk of text, including the terminating newline if there is one. It should destructively modify the value there, storing the changed result in \$_. Files in which any modifications are made are backed up to the directory specified using --backup-dir, or to `backup' by default. To disable this, use --backup-dir= with no argument. Hunk mode is the default because it is MUCH MUCH faster than line-by-line. Use line-by-line only when it matters, e.g. you want to do a replacement only once per line (the default without the `g' argument). Conversely, when using hunk mode, *ALWAYS* use `g'; otherwise, you will only make one replacement in the entire file! "; my %options = (); $Getopt::Long::ignorecase = 0; &GetOptions ( \%options, 'help', 'backup-dir=s', 'line-mode', 'hunk-mode', ); die $usage if $options{"help"} or @ARGV <= 1; my $code = shift; die $usage if grep (-d || ! -w, @ARGV); sub SafeOpen { open ((my $fh = new FileHandle), $_[0]); confess "Can't open $_[0]: $!" if ! defined $fh; return $fh; } sub SafeClose { close $_[0] or confess "Can't close $_[0]: $!"; } sub FileContents { my $fh = SafeOpen ("< $_[0]"); my $olddollarslash = $/; local $/ = undef; my $contents = <$fh>; $/ = $olddollarslash; return $contents; } sub WriteStringToFile { my $fh = SafeOpen ("> $_[0]"); binmode $fh; print $fh $_[1] or confess "$_[0]: $!\n"; SafeClose $fh; } foreach my $file (@ARGV) { my $changed_p = 0; my $new_contents = ""; if ($options{"line-mode"}) { my $fh = SafeOpen $file; while (<$fh>) { my $save_line = $_; eval $code; $changed_p = 1 if $save_line ne $_; $new_contents .= $_; } } else { my $orig_contents = $_ = FileContents $file; eval $code; if ($_ ne $orig_contents) { $changed_p = 1; $new_contents = $_; } } if ($changed_p) { my $backdir = $options{"backup-dir"}; $backdir = "backup" if !defined ($backdir); if ($backdir) { my ($name, $path, $suffix) = fileparse ($file, ""); my $backfulldir = $path . $backdir; my $backfile = "$backfulldir/$name"; mkdir $backfulldir, 0755 unless -d $backfulldir; print "modifying $file (original saved in $backfile)\n"; rename $file, $backfile; } WriteStringToFile ($file, $new_contents); } } ----------------------------------- cut ------------------------------------ In addition to those programs, I needed to fix up a few other things, particularly relating to the duplicate definitions of types, now that some types merged with others. Specifically: 1. in lisp.h, removed duplicate declarations of Bytecount. The changed code should now look like this: (In each code snippet below, the first and last lines are the same as the original, as are all lines outside of those lines. That allows you to locate the section to be replaced, and replace the stuff in that section, verifying that there isn't anything new added that would need to be kept.) --------------------------------- snip ------------------------------------- /* Counts of bytes or chars */ typedef EMACS_INT Bytecount; typedef EMACS_INT Charcount; /* Counts of elements */ typedef EMACS_INT Elemcount; /* Hash codes */ typedef unsigned long Hashcode; /* ------------------------ dynamic arrays ------------------- */ --------------------------------- snip ------------------------------------- 2. in lstream.h, removed duplicate declaration of Bytecount. Rewrote the comment about this type. The changed code should now look like this: --------------------------------- snip ------------------------------------- #endif /* The have been some arguments over the what the type should be that specifies a count of bytes in a data block to be written out or read in, using Lstream_read(), Lstream_write(), and related functions. Originally it was long, which worked fine; Martin "corrected" these to size_t and ssize_t on the grounds that this is theoretically cleaner and is in keeping with the C standards. Unfortunately, this practice is horribly error-prone due to design flaws in the way that mixed signed/unsigned arithmetic happens. In fact, by doing this change, Martin introduced a subtle but fatal error that caused the operation of sending large mail messages to the SMTP server under Windows to fail. By putting all values back to be signed, avoiding any signed/unsigned mixing, the bug immediately went away. The type then in use was Lstream_Data_Count, so that it be reverted cleanly if a vote came to that. Now it is Bytecount. Some earlier comments about why the type must be signed: This MUST BE SIGNED, since it also is used in functions that return the number of bytes actually read to or written from in an operation, and these functions can return -1 to signal error. Note that the standard Unix read() and write() functions define the count going in as a size_t, which is UNSIGNED, and the count going out as an ssize_t, which is SIGNED. This is a horrible design flaw. Not only is it highly likely to lead to logic errors when a -1 gets interpreted as a large positive number, but operations are bound to fail in all sorts of horrible ways when a number in the upper-half of the size_t range is passed in -- this number is unrepresentable as an ssize_t, so code that checks to see how many bytes are actually written (which is mandatory if you are dealing with certain types of devices) will get completely screwed up. --ben */ typedef enum lstream_buffering --------------------------------- snip ------------------------------------- 3. in dumper.c, there are four places, all inside of switch() statements, where XD_BYTECOUNT appears twice as a case tag. In each case, the two case blocks contain identical code, and you should *REMOVE THE SECOND* and leave the first.
author ben
date Thu, 20 Sep 2001 06:31:11 +0000
parents b39c14581166
children b1f74adcc1ff
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.
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
4 Copyright (C) 2000, 2001 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 #ifdef ERROR_CHECK_GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
36 int always_gc; /* Debugging hack */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
37 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
38 #define always_gc 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
39 #endif
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 struct backtrace *backtrace_list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
42
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
43 /* 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
44 before pushing them on the backtrace_list. The profiling code depends
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
45 on this. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
46
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
47 #define PUSH_BACKTRACE(bt) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
48 (bt).next = backtrace_list; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
49 backtrace_list = &(bt); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
50 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
51
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
52 #define POP_BACKTRACE(bt) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
53 backtrace_list = (bt).next; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
54 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
55
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
56 /* Macros for calling subrs with an argument list whose length is only
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
57 known at runtime. See EXFUN and DEFUN for similar hackery. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
58
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
59 #define AV_0(av)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
60 #define AV_1(av) av[0]
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
61 #define AV_2(av) AV_1(av), av[1]
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
62 #define AV_3(av) AV_2(av), av[2]
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
63 #define AV_4(av) AV_3(av), av[3]
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
64 #define AV_5(av) AV_4(av), av[4]
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
65 #define AV_6(av) AV_5(av), av[5]
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
66 #define AV_7(av) AV_6(av), av[6]
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
67 #define AV_8(av) AV_7(av), av[7]
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
68
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
69 #define PRIMITIVE_FUNCALL_1(fn, av, ac) \
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
70 (((Lisp_Object (*)(EXFUN_##ac)) (fn)) (AV_##ac (av)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
71
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
72 /* 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
73 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
74 a SUBR with more than 8 arguments, use max_args == MANY.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
75 See the DEFUN macro in lisp.h) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
76 #define PRIMITIVE_FUNCALL(rv, fn, av, ac) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
77 void (*PF_fn)(void) = (void (*)(void)) fn; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
78 Lisp_Object *PF_av = (av); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
79 switch (ac) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
80 { \
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
81 default:rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 0); break; \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
82 case 1: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 1); break; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
83 case 2: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 2); break; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
84 case 3: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 3); break; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
85 case 4: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 4); break; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
86 case 5: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 5); break; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
87 case 6: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 6); break; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
88 case 7: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 7); break; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
89 case 8: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 8); break; \
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 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
92
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
93 #define FUNCALL_SUBR(rv, subr, av, ac) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
94 PRIMITIVE_FUNCALL (rv, subr_function (subr), av, ac);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
95
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
96
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
97 /* This is the list of current catches (and also condition-cases).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
98 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
99 list. Catches are created by declaring a 'struct catchtag'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
100 locally, filling the .TAG field in with the tag, and doing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
101 a setjmp() on .JMP. Fthrow() will store the value passed
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
102 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
103 that established the catch. This will always be either
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
104 internal_catch() (catches established internally or through
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
105 `catch') or condition_case_1 (condition-cases established
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
106 internally or through `condition-case').
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
107
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
108 The catchtag also records the current position in the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
109 call stack (stored in BACKTRACE_LIST), the current position
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
110 in the specpdl stack (used for variable bindings and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
111 unwind-protects), the value of LISP_EVAL_DEPTH, and the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
112 current position in the GCPRO stack. All of these are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
113 restored by Fthrow().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
114 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
115
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
116 struct catchtag *catchlist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
117
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
118 Lisp_Object Qautoload, Qmacro, Qexit;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
119 Lisp_Object Qinteractive, Qcommandp, Qdefun, Qprogn, Qvalues;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
120 Lisp_Object Vquit_flag, Vinhibit_quit;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
121 Lisp_Object Qand_rest, Qand_optional;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
122 Lisp_Object Qdebug_on_error, Qstack_trace_on_error;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
123 Lisp_Object Qdebug_on_signal, Qstack_trace_on_signal;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
124 Lisp_Object Qdebugger;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
125 Lisp_Object Qinhibit_quit;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
126 Lisp_Object Qrun_hooks;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
127 Lisp_Object Qsetq;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
128 Lisp_Object Qdisplay_warning;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
129 Lisp_Object Vpending_warnings, Vpending_warnings_tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
130 Lisp_Object Qif;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
131
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
132 /* Records whether we want errors to occur. This will be a boolean,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
133 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
134 throw to Qunbound_suspended_errors_tag.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
135
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
136 See call_with_suspended_errors(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
137 Lisp_Object Vcurrent_error_state;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
138
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
139 /* Current warning class when warnings occur, or nil for no warnings.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
140 Only meaningful when Vcurrent_error_state is non-nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
141 See call_with_suspended_errors(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
142 Lisp_Object Vcurrent_warning_class;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
143
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
144 /* Special catch tag used in call_with_suspended_errors(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
145 Lisp_Object Qunbound_suspended_errors_tag;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
146
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
147 /* 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
148 if the file being autoloaded is not fully loaded.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
149 They are recorded by being consed onto the front of Vautoload_queue:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
150 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
151 Lisp_Object Vautoload_queue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
152
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
153 /* Current number of specbindings allocated in specpdl. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
154 int specpdl_size;
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 /* Pointer to beginning of specpdl. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
157 struct specbinding *specpdl;
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 first unused element in specpdl. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
160 struct specbinding *specpdl_ptr;
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 /* specpdl_ptr - specpdl */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
163 int specpdl_depth_counter;
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 /* Maximum size allowed for specpdl allocation */
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
166 Fixnum max_specpdl_size;
428
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 /* Depth in Lisp evaluations and function calls. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
169 static int lisp_eval_depth;
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 /* Maximum allowed depth in Lisp evaluations and function calls. */
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
172 Fixnum max_lisp_eval_depth;
428
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 /* Nonzero means enter debugger before next function call */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
175 static int debug_on_next_call;
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 /* List of conditions (non-nil atom means all) which cause a backtrace
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
178 if an error is handled by the command loop's error handler. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
179 Lisp_Object Vstack_trace_on_error;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
180
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
181 /* List of conditions (non-nil atom means all) which enter the debugger
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
182 if an error is handled by the command loop's error handler. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
183 Lisp_Object Vdebug_on_error;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
184
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
185 /* List of conditions and regexps specifying error messages which
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
186 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
187 Lisp_Object Vdebug_ignored_errors;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
188
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
189 /* List of conditions (non-nil atom means all) which cause a backtrace
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
190 if any error is signalled. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
191 Lisp_Object Vstack_trace_on_signal;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
192
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
193 /* List of conditions (non-nil atom means all) which enter the debugger
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
194 if any error is signalled. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
195 Lisp_Object Vdebug_on_signal;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
196
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
197 /* Nonzero means enter debugger if a quit signal
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
198 is handled by the command loop's error handler.
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 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
201 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
202 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
203 after it is processed in signal_call_debugger(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
204 int debug_on_quit;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
205
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
206 #if 0 /* FSFmacs */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
207 /* entering_debugger is basically equivalent */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
208 /* 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
209 started to enter the debugger. If we decide to enter the debugger
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
210 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
211 know that the debugger itself has an error, and we should just
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
212 signal the error instead of entering an infinite loop of debugger
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
213 invocations. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
214 int when_entered_debugger;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
215 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
216
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
217 /* Nonzero means we are trying to enter the debugger.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
218 This is to prevent recursive attempts.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
219 Cleared by the debugger calling Fbacktrace */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
220 static int entering_debugger;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
221
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
222 /* Function to call to invoke the debugger */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
223 Lisp_Object Vdebugger;
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 /* Chain of condition handlers currently in effect.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
226 The elements of this chain are contained in the stack frames
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
227 of Fcondition_case and internal_condition_case.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
228 When an error is signaled (by calling Fsignal, below),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
229 this chain is searched for an element that applies.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
230
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
231 Each element of this list is one of the following:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
232
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
233 A list of a handler function and possibly args to pass to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
234 the function. This is a handler established with
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
235 `call-with-condition-handler' (q.v.).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
236
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
237 A list whose car is Qunbound and whose cdr is Qt.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
238 This is a special condition-case handler established
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
239 by C code with condition_case_1(). All errors are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
240 trapped; the debugger is not invoked even if
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
241 `debug-on-error' was set.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
242
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
243 A list whose car is Qunbound and whose cdr is Qerror.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
244 This is a special condition-case handler established
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
245 by C code with condition_case_1(). It is like Qt
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
246 except that the debugger is invoked normally if it is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
247 called for.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
248
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
249 A list whose car is Qunbound and whose cdr is a list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
250 of lists (CONDITION-NAME BODY ...) exactly as in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
251 `condition-case'. This is a normal `condition-case'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
252 handler.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
253
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
254 Note that in all cases *except* the first, there is a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
255 corresponding catch, whose TAG is the value of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
256 Vcondition_handlers just after the handler data just
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
257 described is pushed onto it. The reason is that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
258 `condition-case' handlers need to throw back to the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
259 place where the handler was installed before invoking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
260 it, while `call-with-condition-handler' handlers are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
261 invoked in the environment that `signal' was invoked
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
262 in.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
263 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
264 static Lisp_Object Vcondition_handlers;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
265
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
266
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
267 #define DEFEND_AGAINST_THROW_RECURSION
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
268
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
269 #ifdef DEFEND_AGAINST_THROW_RECURSION
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
270 /* Used for error catching purposes by throw_or_bomb_out */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
271 static int throw_level;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
272 #endif
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
273
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
274 #ifdef ERROR_CHECK_TYPECHECK
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
275 void check_error_state_sanity (void);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
276 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
277
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
278
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
279 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
280 /* The subr object type */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
281 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
282
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
283 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
284 print_subr (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
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 Lisp_Subr *subr = XSUBR (obj);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
287 const CIntbyte *header =
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
288 (subr->max_args == UNEVALLED) ? "#<special-form " : "#<subr ";
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
289 const CIntbyte *name = subr_name (subr);
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
290 const CIntbyte *trailer = subr->prompt ? " (interactive)>" : ">";
428
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 if (print_readably)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
293 printing_unreadable_object ("%s%s%s", header, name, trailer);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
294
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
295 write_c_string (header, printcharfun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
296 write_c_string (name, printcharfun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
297 write_c_string (trailer, printcharfun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
298 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
299
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
300 static const struct lrecord_description subr_description[] = {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
301 { XD_DOC_STRING, offsetof (Lisp_Subr, doc) },
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
302 { XD_END }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
303 };
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 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("subr", subr,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
306 0, print_subr, 0, 0, 0,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
307 subr_description,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
308 Lisp_Subr);
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 /* Entering the debugger */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
312 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
313
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
314 /* unwind-protect used by call_debugger() to restore the value of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
315 entering_debugger. (We cannot use specbind() because the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
316 variable is not Lisp-accessible.) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
317
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
318 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
319 restore_entering_debugger (Lisp_Object arg)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
320 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
321 entering_debugger = ! NILP (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
322 return arg;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
325 /* 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
326 passed to the debugger function, as follows;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
327
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
328 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
329 this function's value will be returned instead of that.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
330 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
331 If due to `apply' or `funcall' entry, one arg, `lambda'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
332 If due to `eval' entry, one arg, t.
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 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
335
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
336 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
337 call_debugger_259 (Lisp_Object arg)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
338 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
339 return apply1 (Vdebugger, arg);
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 /* Call the debugger, doing some encapsulation. We make sure we have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
343 some room on the eval and specpdl stacks, and bind entering_debugger
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
344 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
345 when entering the debugger (e.g. the value of `debugger' is invalid),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
346 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
347 is set. (Otherwise, XEmacs would infinitely recurse, attempting to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
348 enter the debugger.) entering_debugger gets reset to 0 as soon
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
349 as a backtrace is displayed, so that further errors can indeed be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
350 handled normally.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
351
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
352 We also establish a catch for 'debugger. If the debugger function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
353 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
354 pressed 'c' (pretend like the debugger was never entered). The
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
355 function then returns Qunbound. (If the user pressed 'r', for
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
356 return a value, then the debugger function returns normally with
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
357 this value.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
358
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
359 The difference between 'c' and 'r' is as follows:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
360
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
361 debug-on-call:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
362 No difference. The call proceeds as normal.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
363 debug-on-exit:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
364 With 'r', the specified value is returned as the function's
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
365 return value. With 'c', the value that would normally be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
366 returned is returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
367 signal:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
368 With 'r', the specified value is returned as the return
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
369 value of `signal'. (This is the only time that `signal'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
370 can return, instead of making a non-local exit.) With `c',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
371 `signal' will continue looking for handlers as if the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
372 debugger was never entered, and will probably end up
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
373 throwing to a handler or to top-level.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
374 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
375
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
376 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
377 call_debugger (Lisp_Object arg)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
378 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
379 int threw;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
380 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
381 int speccount;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
382
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
383 if (lisp_eval_depth + 20 > max_lisp_eval_depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
384 max_lisp_eval_depth = lisp_eval_depth + 20;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
385 if (specpdl_size + 40 > max_specpdl_size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
386 max_specpdl_size = specpdl_size + 40;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
387 debug_on_next_call = 0;
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 speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
390 record_unwind_protect (restore_entering_debugger,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
391 (entering_debugger ? Qt : Qnil));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
392 entering_debugger = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
393 val = internal_catch (Qdebugger, call_debugger_259, arg, &threw);
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 return unbind_to (speccount, ((threw)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
396 ? Qunbound /* Not returning a value */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
397 : val));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
398 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
399
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
400 /* Called when debug-on-exit behavior is called for. Enter the debugger
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
401 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
402 about to be returned. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
403
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
404 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
405 do_debug_on_exit (Lisp_Object val)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
406 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
407 /* This is falsified by call_debugger */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
408 Lisp_Object v = call_debugger (list2 (Qexit, val));
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 return !UNBOUNDP (v) ? v : val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
411 }
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 /* Called when debug-on-call behavior is called for. Enter the debugger
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
414 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
415 through `eval' or 'lambda for a call through `funcall'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
416
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
417 #### The differentiation here between EVAL and FUNCALL is bogus.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
418 FUNCALL can be defined as
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
419
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
420 (defmacro func (fun &rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
421 (cons (eval fun) args))
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 and should be treated as such.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
424 */
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 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
427 do_debug_on_call (Lisp_Object code)
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 debug_on_next_call = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
430 backtrace_list->debug_on_exit = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
431 call_debugger (list1 (code));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
432 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
433
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
434 /* LIST is the value of one of the variables `debug-on-error',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
435 `debug-on-signal', `stack-trace-on-error', or `stack-trace-on-signal',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
436 and CONDITIONS is the list of error conditions associated with
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
437 the error being signalled. This returns non-nil if LIST
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
438 matches CONDITIONS. (A nil value for LIST does not match
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
439 CONDITIONS. A non-list value for LIST does match CONDITIONS.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
440 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
441 same as one of the symbols in CONDITIONS.) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
442
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
443 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
444 wants_debugger (Lisp_Object list, Lisp_Object conditions)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
445 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
446 if (NILP (list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
447 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
448 if (! CONSP (list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
449 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
450
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
451 while (CONSP (conditions))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
452 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
453 Lisp_Object this, tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
454 this = XCAR (conditions);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
455 for (tail = list; CONSP (tail); tail = XCDR (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
456 if (EQ (XCAR (tail), this))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
457 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
458 conditions = XCDR (conditions);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
459 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
460 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
461 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
462
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
463
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
464 /* Return 1 if an error with condition-symbols CONDITIONS,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
465 and described by SIGNAL-DATA, should skip the debugger
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
466 according to debugger-ignore-errors. */
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 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
469 skip_debugger (Lisp_Object conditions, Lisp_Object data)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
470 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
471 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
472 Lisp_Object tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
473 int first_string = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
474 Lisp_Object error_message = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
475
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
476 for (tail = Vdebug_ignored_errors; CONSP (tail); tail = XCDR (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
477 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
478 if (STRINGP (XCAR (tail)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
479 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
480 if (first_string)
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 error_message = Ferror_message_string (data);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
483 first_string = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
484 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
485 if (fast_lisp_string_match (XCAR (tail), error_message) >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
486 return 1;
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 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
489 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
490 Lisp_Object contail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
491
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
492 for (contail = conditions; CONSP (contail); contail = XCDR (contail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
493 if (EQ (XCAR (tail), XCAR (contail)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
494 return 1;
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 }
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 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
499 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
500
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
501 /* Actually generate a backtrace on STREAM. */
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 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
504 backtrace_259 (Lisp_Object stream)
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 return Fbacktrace (stream, Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
507 }
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 /* 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
510 etc. variables call for this. CONDITIONS is the list of conditions
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
511 associated with the error being signalled. SIG is the actual error
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
512 being signalled, and DATA is the associated data (these are exactly
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
513 the same as the arguments to `signal'). ACTIVE_HANDLERS is the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
514 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
515 is called. This is generally the remaining handlers that are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
516 outside of the innermost handler trapping this error. This way,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
517 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
518 the debugger entered recursively.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
519
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
520 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
521 the user asked (through 'c') that XEmacs should pretend like the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
522 debugger was never entered. Otherwise, it returns the value
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
523 that the user specified with `r'. (Note that much of the time,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
524 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
525 return anything at all.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
526
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
527 SIGNAL_VARS_ONLY means we should only look at debug-on-signal
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
528 and stack-trace-on-signal to control whether we do anything.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
529 This is so that debug-on-error doesn't make handled errors
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
530 cause the debugger to get invoked.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
531
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
532 STACK_TRACE_DISPLAYED and DEBUGGER_ENTERED are used so that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
533 those functions aren't done more than once in a single `signal'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
534 session. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
535
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
536 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
537 signal_call_debugger (Lisp_Object conditions,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
538 Lisp_Object sig, Lisp_Object data,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
539 Lisp_Object active_handlers,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
540 int signal_vars_only,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
541 int *stack_trace_displayed,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
542 int *debugger_entered)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
543 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
544 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
545 Lisp_Object val = Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
546 Lisp_Object all_handlers = Vcondition_handlers;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
547 Lisp_Object temp_data = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
548 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
549 struct gcpro gcpro1, gcpro2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
550 GCPRO2 (all_handlers, temp_data);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
551
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
552 Vcondition_handlers = active_handlers;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
553
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
554 temp_data = Fcons (sig, data); /* needed for skip_debugger */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
555
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
556 if (!entering_debugger && !*stack_trace_displayed && !signal_vars_only
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
557 && wants_debugger (Vstack_trace_on_error, conditions)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
558 && !skip_debugger (conditions, temp_data))
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 specbind (Qdebug_on_error, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
561 specbind (Qstack_trace_on_error, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
562 specbind (Qdebug_on_signal, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
563 specbind (Qstack_trace_on_signal, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
564
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
565 if (!noninteractive)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
566 internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
567 backtrace_259,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
568 Qnil,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
569 Qnil);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
570 else /* in batch mode, we want this going to stderr. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
571 backtrace_259 (Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
572 unbind_to (speccount, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
573 *stack_trace_displayed = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
574 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
575
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
576 if (!entering_debugger && !*debugger_entered && !signal_vars_only
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
577 && (EQ (sig, Qquit)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
578 ? debug_on_quit
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
579 : wants_debugger (Vdebug_on_error, conditions))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
580 && !skip_debugger (conditions, temp_data))
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 debug_on_quit &= ~2; /* reset critical bit */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
583 specbind (Qdebug_on_error, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
584 specbind (Qstack_trace_on_error, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
585 specbind (Qdebug_on_signal, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
586 specbind (Qstack_trace_on_signal, Qnil);
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 val = call_debugger (list2 (Qerror, (Fcons (sig, data))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
589 *debugger_entered = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
590 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
591
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
592 if (!entering_debugger && !*stack_trace_displayed
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
593 && wants_debugger (Vstack_trace_on_signal, conditions))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
594 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
595 specbind (Qdebug_on_error, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
596 specbind (Qstack_trace_on_error, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
597 specbind (Qdebug_on_signal, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
598 specbind (Qstack_trace_on_signal, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
599
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
600 if (!noninteractive)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
601 internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
602 backtrace_259,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
603 Qnil,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
604 Qnil);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
605 else /* in batch mode, we want this going to stderr. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
606 backtrace_259 (Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
607 unbind_to (speccount, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
608 *stack_trace_displayed = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
609 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
610
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
611 if (!entering_debugger && !*debugger_entered
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
612 && (EQ (sig, Qquit)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
613 ? debug_on_quit
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
614 : wants_debugger (Vdebug_on_signal, conditions)))
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 debug_on_quit &= ~2; /* reset critical bit */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
617 specbind (Qdebug_on_error, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
618 specbind (Qstack_trace_on_error, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
619 specbind (Qdebug_on_signal, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
620 specbind (Qstack_trace_on_signal, Qnil);
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 val = call_debugger (list2 (Qerror, (Fcons (sig, data))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
623 *debugger_entered = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
624 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
625
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
626 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
627 Vcondition_handlers = all_handlers;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
628 return unbind_to (speccount, val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
629 }
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 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
633 /* The basic special forms */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
634 /************************************************************************/
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 /* Except for Fprogn(), the basic special forms below are only called
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
637 from interpreted code. The byte compiler turns them into bytecodes. */
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 DEFUN ("or", For, 0, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
640 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
641 The remaining args are not evalled at all.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
642 If all args return nil, return nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
643 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
644 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
645 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
646 /* This function can GC */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
647 REGISTER Lisp_Object val;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
648
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
649 LIST_LOOP_2 (arg, args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
650 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
651 if (!NILP (val = Feval (arg)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
652 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
653 }
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 return Qnil;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
658 DEFUN ("and", Fand, 0, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
659 Eval args until one of them yields nil, then return nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
660 The remaining args are not evalled at all.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
661 If no arg yields nil, return the last arg's value.
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 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
664 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
665 /* This function can GC */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
666 REGISTER Lisp_Object val = Qt;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
667
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
668 LIST_LOOP_2 (arg, args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
669 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
670 if (NILP (val = Feval (arg)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
671 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
672 }
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 return val;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
677 DEFUN ("if", Fif, 2, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
678 \(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
679 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
680 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
681 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
682 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
683 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
684 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
685 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
686 Lisp_Object condition = XCAR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
687 Lisp_Object then_form = XCAR (XCDR (args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
688 Lisp_Object else_forms = XCDR (XCDR (args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
689
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
690 if (!NILP (Feval (condition)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
691 return Feval (then_form);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
692 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
693 return Fprogn (else_forms);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
694 }
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 /* Macros `when' and `unless' are trivially defined in Lisp,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
697 but it helps for bootstrapping to have them ALWAYS defined. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
698
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
699 DEFUN ("when", Fwhen, 1, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
700 \(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
701 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
702 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
703 (int nargs, Lisp_Object *args))
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 Lisp_Object cond = args[0];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
706 Lisp_Object body;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
707
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
708 switch (nargs)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
709 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
710 case 1: body = Qnil; break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
711 case 2: body = args[1]; break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
712 default: body = Fcons (Qprogn, Flist (nargs-1, args+1)); break;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
715 return list3 (Qif, cond, body);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
716 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
717
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
718 DEFUN ("unless", Funless, 1, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
719 \(unless COND BODY...): if COND yields nil, do BODY, else return nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
720 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
721 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
722 (int nargs, Lisp_Object *args))
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 Lisp_Object cond = args[0];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
725 Lisp_Object body = Flist (nargs-1, args+1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
726 return Fcons (Qif, Fcons (cond, Fcons (Qnil, body)));
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
729 DEFUN ("cond", Fcond, 0, UNEVALLED, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
730 \(cond CLAUSES...): try each clause until one succeeds.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
731 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
732 and, if the value is non-nil, this clause succeeds:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
733 then the expressions in BODY are evaluated and the last one's
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
734 value is the value of the cond-form.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
735 If no clause succeeds, cond returns nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
736 If a clause has one element, as in (CONDITION),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
737 CONDITION's value if non-nil is returned from the cond-form.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
738 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
739 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
740 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
741 /* This function can GC */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
742 REGISTER Lisp_Object val;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
743
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
744 LIST_LOOP_2 (clause, args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
745 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
746 CHECK_CONS (clause);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
747 if (!NILP (val = Feval (XCAR (clause))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
748 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
749 if (!NILP (clause = XCDR (clause)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
750 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
751 CHECK_TRUE_LIST (clause);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
752 val = Fprogn (clause);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
753 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
754 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
755 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
758 return Qnil;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
761 DEFUN ("progn", Fprogn, 0, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
762 \(progn BODY...): eval BODY forms sequentially and return value of last one.
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 (args))
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 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
767 /* Caller must provide a true list in ARGS */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
768 REGISTER Lisp_Object val = Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
769 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
770
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
771 GCPRO1 (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
772
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
773 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
774 LIST_LOOP_2 (form, args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
775 val = Feval (form);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
778 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
779 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
780 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
781
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
782 /* Fprog1() is the canonical example of a function that must GCPRO a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
783 Lisp_Object across calls to Feval(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
784
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
785 DEFUN ("prog1", Fprog1, 1, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
786 Similar to `progn', but the value of the first form is returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
787 \(prog1 FIRST BODY...): All the arguments are evaluated sequentially.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
788 The value of FIRST is saved during evaluation of the remaining args,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
789 whose values are discarded.
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 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
792 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
793 /* This function can GC */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
794 REGISTER Lisp_Object val;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
795 struct gcpro gcpro1;
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 val = Feval (XCAR (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 GCPRO1 (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
800
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
801 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
802 LIST_LOOP_2 (form, XCDR (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
803 Feval (form);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
806 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
807 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
808 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
809
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
810 DEFUN ("prog2", Fprog2, 2, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
811 Similar to `progn', but the value of the second form is returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
812 \(prog2 FIRST SECOND BODY...): All the arguments are evaluated sequentially.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
813 The value of SECOND is saved during evaluation of the remaining args,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
814 whose values are discarded.
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 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
817 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
818 /* This function can GC */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
819 REGISTER Lisp_Object val;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
820 struct gcpro gcpro1;
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 Feval (XCAR (args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
823 args = XCDR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
824 val = Feval (XCAR (args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
825 args = XCDR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
826
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
827 GCPRO1 (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
828
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
829 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
830 LIST_LOOP_2 (form, args)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
831 Feval (form);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
832 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
833
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
834 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
835 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
836 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
837
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
838 DEFUN ("let*", FletX, 1, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
839 \(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
840 The value of the last form in BODY is returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
841 Each element of VARLIST is a symbol (which is bound to nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
842 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
843 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
844 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
845 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
846 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
847 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
848 Lisp_Object varlist = XCAR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
849 Lisp_Object body = XCDR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
850 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
851
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
852 EXTERNAL_LIST_LOOP_3 (var, varlist, tail)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
853 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
854 Lisp_Object symbol, value, tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
855 if (SYMBOLP (var))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
856 symbol = var, value = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
857 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
858 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
859 CHECK_CONS (var);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
860 symbol = XCAR (var);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
861 tem = XCDR (var);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
862 if (NILP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
863 value = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
864 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
865 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
866 CHECK_CONS (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
867 value = Feval (XCAR (tem));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
868 if (!NILP (XCDR (tem)))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
869 sferror
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
870 ("`let' bindings can have only one value-form", var);
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
873 specbind (symbol, value);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
874 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
875 return unbind_to (speccount, Fprogn (body));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
876 }
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 DEFUN ("let", Flet, 1, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
879 \(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
880 The value of the last form in BODY is returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
881 Each element of VARLIST is a symbol (which is bound to nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
882 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
883 All the VALUEFORMs are evalled before any symbols are bound.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
884 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
885 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
886 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
887 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
888 Lisp_Object varlist = XCAR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
889 Lisp_Object body = XCDR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
890 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
891 Lisp_Object *temps;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
892 int idx;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
893 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
894
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
895 /* Make space to hold the values to give the bound variables. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
896 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
897 int varcount;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
898 GET_EXTERNAL_LIST_LENGTH (varlist, varcount);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
899 temps = alloca_array (Lisp_Object, varcount);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
902 /* Compute the values and store them in `temps' */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
903 GCPRO1 (*temps);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
904 gcpro1.nvars = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
905
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
906 idx = 0;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
907 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
908 LIST_LOOP_2 (var, varlist)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
909 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
910 Lisp_Object *value = &temps[idx++];
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
911 if (SYMBOLP (var))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
912 *value = Qnil;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
913 else
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
914 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
915 Lisp_Object tem;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
916 CHECK_CONS (var);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
917 tem = XCDR (var);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
918 if (NILP (tem))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
919 *value = Qnil;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
920 else
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
921 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
922 CHECK_CONS (tem);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
923 *value = Feval (XCAR (tem));
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
924 gcpro1.nvars = idx;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
925
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
926 if (!NILP (XCDR (tem)))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
927 sferror
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
928 ("`let' bindings can have only one value-form", var);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
929 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
930 }
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 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
933
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
934 idx = 0;
442
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 LIST_LOOP_2 (var, varlist)
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 specbind (SYMBOLP (var) ? var : XCAR (var), temps[idx++]);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
939 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
940 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
941
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
942 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
943
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
944 return unbind_to (speccount, Fprogn (body));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
945 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
946
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
947 DEFUN ("while", Fwhile, 1, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
948 \(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
949 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
950 until TEST returns nil.
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 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
953 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
954 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
955 Lisp_Object test = XCAR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
956 Lisp_Object body = XCDR (args);
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 while (!NILP (Feval (test)))
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 QUIT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
961 Fprogn (body);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
962 }
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 return Qnil;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
967 DEFUN ("setq", Fsetq, 0, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
968 \(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
969 The symbols SYM are variables; they are literal (not evaluated).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
970 The values VAL are expressions; they are evaluated.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
971 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
972 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
973 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
974 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
975 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
976 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
977 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
978 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
979 Lisp_Object symbol, tail, val = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
980 int nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
981 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
982
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
983 GET_LIST_LENGTH (args, nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
984
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
985 if (nargs & 1) /* Odd number of arguments? */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
986 Fsignal (Qwrong_number_of_arguments, list2 (Qsetq, make_int (nargs)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
987
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
988 GCPRO1 (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
989
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
990 PROPERTY_LIST_LOOP (tail, symbol, val, args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
991 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
992 val = Feval (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
993 Fset (symbol, val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
994 }
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 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
997 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
998 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
999
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1000 DEFUN ("quote", Fquote, 1, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1001 Return the argument, without evaluating it. `(quote x)' yields `x'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1002 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1003 (args))
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 return XCAR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1006 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1007
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1008 DEFUN ("function", Ffunction, 1, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1009 Like `quote', but preferred for objects which are functions.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1010 In byte compilation, `function' causes its argument to be compiled.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1011 `quote' cannot do that.
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 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1014 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1015 return XCAR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1016 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1017
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 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1020 /* Defining functions/variables */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1021 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1022 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1023 define_function (Lisp_Object name, Lisp_Object defn)
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 Ffset (name, defn);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1026 LOADHIST_ATTACH (name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1027 return name;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1028 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1029
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1030 DEFUN ("defun", Fdefun, 2, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1031 \(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1032 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1033 See also the function `interactive'.
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 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1036 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1037 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1038 return define_function (XCAR (args),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1039 Fcons (Qlambda, XCDR (args)));
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1042 DEFUN ("defmacro", Fdefmacro, 2, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1043 \(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1044 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1045 When the macro is called, as in (NAME ARGS...),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1046 the function (lambda ARGLIST BODY...) is applied to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1047 the list ARGS... as it appears in the expression,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1048 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
1049 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1050 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1051 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1052 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1053 return define_function (XCAR (args),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1054 Fcons (Qmacro, Fcons (Qlambda, XCDR (args))));
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1057 DEFUN ("defvar", Fdefvar, 1, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1058 \(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1059 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
1060 but the definition can supply documentation and an initial value
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1061 in a way that tags can recognize.
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 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
1064 void. (However, when you evaluate a defvar interactively, it acts like a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1065 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
1066 void.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1067 If SYMBOL is buffer-local, its default value is what is set;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1068 buffer-local values are not affected.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1069 INITVALUE and DOCSTRING are optional.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1070 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
1071 This means that M-x set-variable recognizes it.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1072 If INITVALUE is missing, SYMBOL's value is not set.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1073
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1074 In lisp-interaction-mode defvar is treated as defconst.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1075 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1076 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1077 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1078 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1079 Lisp_Object sym = XCAR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1080
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1081 if (!NILP (args = XCDR (args)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1082 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1083 Lisp_Object val = XCAR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1084
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1085 if (NILP (Fdefault_boundp (sym)))
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 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1088 GCPRO1 (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1089 val = Feval (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1090 Fset_default (sym, val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1091 UNGCPRO;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1094 if (!NILP (args = XCDR (args)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1095 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1096 Lisp_Object doc = XCAR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1097 Fput (sym, Qvariable_documentation, doc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1098 if (!NILP (args = XCDR (args)))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
1099 signal_error (Qwrong_number_of_arguments, "too many arguments", Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1100 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1103 #ifdef I18N3
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1104 if (!NILP (Vfile_domain))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1105 Fput (sym, Qvariable_domain, Vfile_domain);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1106 #endif
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 LOADHIST_ATTACH (sym);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1109 return sym;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1110 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1111
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1112 DEFUN ("defconst", Fdefconst, 2, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1113 \(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1114 variable.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1115 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
1116 Always sets the value of SYMBOL to the result of evalling INITVALUE.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1117 If SYMBOL is buffer-local, its default value is what is set;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1118 buffer-local values are not affected.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1119 DOCSTRING is optional.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1120 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
1121 This means that M-x set-variable recognizes it.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1122
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1123 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
1124 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
1125 their own values for such variables before loading the library.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1126 Since `defconst' unconditionally assigns the variable,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1127 it would override the user's choice.
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 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1130 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1131 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1132 Lisp_Object sym = XCAR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1133 Lisp_Object val = Feval (XCAR (args = XCDR (args)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1134 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1135
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1136 GCPRO1 (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1137
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1138 Fset_default (sym, val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1139
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1140 UNGCPRO;
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 if (!NILP (args = XCDR (args)))
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 Lisp_Object doc = XCAR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1145 Fput (sym, Qvariable_documentation, doc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1146 if (!NILP (args = XCDR (args)))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
1147 signal_error (Qwrong_number_of_arguments, "too many arguments", Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1148 }
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 #ifdef I18N3
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1151 if (!NILP (Vfile_domain))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1152 Fput (sym, Qvariable_domain, Vfile_domain);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1153 #endif
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 LOADHIST_ATTACH (sym);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1156 return sym;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1157 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1158
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1159 DEFUN ("user-variable-p", Fuser_variable_p, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1160 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
1161 \(The alternative is a variable used internally in a Lisp program.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1162 Determined by whether the first character of the documentation
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1163 for the variable is `*'.
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 (variable))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1166 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1167 Lisp_Object documentation = Fget (variable, Qvariable_documentation, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1168
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1169 return
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1170 ((INTP (documentation) && XINT (documentation) < 0) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1171
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1172 (STRINGP (documentation) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1173 (string_byte (XSTRING (documentation), 0) == '*')) ||
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 /* If (STRING . INTEGER), a negative integer means a user variable. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1176 (CONSP (documentation)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1177 && STRINGP (XCAR (documentation))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1178 && INTP (XCDR (documentation))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1179 && XINT (XCDR (documentation)) < 0)) ?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1180 Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1181 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1182
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1183 DEFUN ("macroexpand-internal", Fmacroexpand_internal, 1, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1184 Return result of expanding macros at top level of FORM.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1185 If FORM is not a macro call, it is returned unchanged.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1186 Otherwise, the macro is expanded and the expansion is considered
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1187 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
1188
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1189 The second optional arg ENVIRONMENT specifies an environment of macro
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1190 definitions to shadow the loaded ones for use in file byte-compilation.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1191 */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1192 (form, environment))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1193 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1194 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1195 /* With cleanups from Hallvard Furuseth. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1196 REGISTER Lisp_Object expander, sym, def, tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1197
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1198 while (1)
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 /* Come back here each time we expand a macro call,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1201 in case it expands into another macro call. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1202 if (!CONSP (form))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1203 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1204 /* 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
1205 def = sym = XCAR (form);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1206 tem = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1207 /* Trace symbols aliases to other symbols
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1208 until we get a symbol that is not an alias. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1209 while (SYMBOLP (def))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1210 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1211 QUIT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1212 sym = def;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1213 tem = Fassq (sym, environment);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1214 if (NILP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1215 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1216 def = XSYMBOL (sym)->function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1217 if (!UNBOUNDP (def))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1218 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1219 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1220 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1221 }
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1222 /* Right now TEM is the result from SYM in ENVIRONMENT,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1223 and if TEM is nil then DEF is SYM's function definition. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1224 if (NILP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1225 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1226 /* SYM is not mentioned in ENVIRONMENT.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1227 Look at its function definition. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1228 if (UNBOUNDP (def)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1229 || !CONSP (def))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1230 /* Not defined or definition not suitable */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1231 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1232 if (EQ (XCAR (def), Qautoload))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1233 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1234 /* Autoloading function: will it be a macro when loaded? */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1235 tem = Felt (def, make_int (4));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1236 if (EQ (tem, Qt) || EQ (tem, Qmacro))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1237 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1238 /* Yes, load it and try again. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1239 do_autoload (def, sym);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1240 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1241 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1242 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1243 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1244 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1245 else if (!EQ (XCAR (def), Qmacro))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1246 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1247 else expander = XCDR (def);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1248 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1249 else
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 expander = XCDR (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1252 if (NILP (expander))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1253 break;
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 form = apply1 (expander, XCDR (form));
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 return form;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1258 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1259
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 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1262 /* Non-local exits */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1263 /************************************************************************/
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 DEFUN ("catch", Fcatch, 1, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1266 \(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1267 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
1268 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
1269 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
1270 If a throw happens, it specifies the value to return from `catch'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1271 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1272 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1273 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1274 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1275 Lisp_Object tag = Feval (XCAR (args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1276 Lisp_Object body = XCDR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1277 return internal_catch (tag, Fprogn, body, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1278 }
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 /* Set up a catch, then call C function FUNC on argument ARG.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1281 FUNC should return a Lisp_Object.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1282 This is how catches are done from within C code. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1283
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1284 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1285 internal_catch (Lisp_Object tag,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1286 Lisp_Object (*func) (Lisp_Object arg),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1287 Lisp_Object arg,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1288 int * volatile threw)
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 /* This structure is made part of the chain `catchlist'. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1291 struct catchtag c;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1292
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1293 /* Fill in the components of c, and put it on the list. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1294 c.next = catchlist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1295 c.tag = tag;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1296 c.val = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1297 c.backlist = backtrace_list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1298 #if 0 /* FSFmacs */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1299 /* #### */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1300 c.handlerlist = handlerlist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1301 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1302 c.lisp_eval_depth = lisp_eval_depth;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1303 c.pdlcount = specpdl_depth();
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 c.poll_suppress_count = async_timer_suppress_count;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1306 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1307 c.gcpro = gcprolist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1308 catchlist = &c;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1309
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1310 /* Call FUNC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1311 if (SETJMP (c.jmp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1312 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1313 /* Throw works by a longjmp that comes right here. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1314 if (threw) *threw = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1315 return c.val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1316 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1317 c.val = (*func) (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1318 if (threw) *threw = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1319 catchlist = c.next;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1320 #ifdef ERROR_CHECK_TYPECHECK
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1321 check_error_state_sanity ();
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1322 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1323 return c.val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1324 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1325
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1326
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1327 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1328 jump to that CATCH, returning VALUE as the value of that catch.
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 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
1331 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
1332 condition-case form has a TAG of Qnil.
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 Before each catch is discarded, unbind all special bindings and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1335 execute all unwind-protect clauses made above that catch. Unwind
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1336 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
1337 effect for each unwind-protect clause we run. At the end, restore
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1338 some static info saved in CATCH, and longjmp to the location
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1339 specified in the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1340
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1341 This is used for correct unwinding in Fthrow and Fsignal. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1342
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1343 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1344 unwind_to_catch (struct catchtag *c, Lisp_Object val)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1345 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1346 REGISTER int last_time;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1347
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1348 /* Unwind the specbind, catch, and handler stacks back to CATCH
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1349 Before each catch is discarded, unbind all special bindings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1350 and execute all unwind-protect clauses made above that catch.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1351 At the end, restore some static info saved in CATCH,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1352 and longjmp to the location specified.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1353 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1354
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1355 /* Save the value somewhere it will be GC'ed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1356 (Can't overwrite tag slot because an unwind-protect may
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1357 want to throw to this same tag, which isn't yet invalid.) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1358 c->val = val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1359
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1360 #if 0 /* FSFmacs */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1361 /* Restore the polling-suppression count. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1362 set_poll_suppress_count (catch->poll_suppress_count);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1363 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1364
617
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1365 #if 1
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1366 do
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1367 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1368 last_time = catchlist == c;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1369
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1370 /* Unwind the specpdl stack, and then restore the proper set of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1371 handlers. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1372 unbind_to (catchlist->pdlcount, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1373 catchlist = catchlist->next;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1374 #ifdef ERROR_CHECK_TYPECHECK
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1375 check_error_state_sanity ();
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1376 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1377 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1378 while (! last_time);
617
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1379 #else
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1380 /* 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
1381 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
1382 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
1383 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
1384 be a particular problem with code like this:
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1385
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1386 (catch 'foo
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1387 (call-some-code-which-does...
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1388 (catch 'bar
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1389 (unwind-protect
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1390 (call-some-code-which-does...
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1391 (catch 'bar
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 (throw 'foo nil))))
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1394 (throw 'bar nil)))))
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1395
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1396 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
1397
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1398 --ben
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1399 */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1400 /* Unwind the specpdl stack */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1401 unbind_to (c->pdlcount, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1402 catchlist = c->next;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1403 #ifdef ERROR_CHECK_TYPECHECK
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1404 check_error_state_sanity ();
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1405 #endif
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)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1425 abort();
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));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1511 return unbind_to (speccount, Feval (XCAR (args)));
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;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1699 #ifdef ERROR_CHECK_TYPECHECK
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1700 check_error_state_sanity ();
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1701 #endif
617
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1702 /* 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
1703 delete this here. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1704 Vcondition_handlers = XCDR (c.tag);
617
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1705 unbind_to (speccount, Qnil);
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1706
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1707 UNGCPRO;
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1708 /* 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
1709 condition_case_unwind above. */
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1710 free_cons (XCONS (XCAR (c.tag)));
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1711 free_cons (XCONS (c.tag));
af57a77cbc92 [xemacs-hg @ 2001-06-18 07:09:50 by ben]
ben
parents: 609
diff changeset
1712 return c.val;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1713 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1714
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1715 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1716 run_condition_case_handlers (Lisp_Object val, Lisp_Object var)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1717 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1718 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1719 #if 0 /* FSFmacs */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1720 if (!NILP (h.var))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1721 specbind (h.var, c.val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1722 val = Fprogn (Fcdr (h.chosen_clause));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1723
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1724 /* Note that this just undoes the binding of h.var; whoever
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1725 longjmp()ed to us unwound the stack to c.pdlcount before
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1726 throwing. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1727 unbind_to (c.pdlcount, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1728 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1729 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1730 int speccount;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1731
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1732 CHECK_TRUE_LIST (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1733 if (NILP (var))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1734 return Fprogn (Fcdr (val)); /* tail call */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1735
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1736 speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1737 specbind (var, Fcar (val));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1738 val = Fprogn (Fcdr (val));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1739 return unbind_to (speccount, val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1740 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1741 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1742
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1743 /* Here for bytecode to call non-consfully. This is exactly like
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1744 condition-case except that it takes three arguments rather
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1745 than a single list of arguments. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1746 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1747 condition_case_3 (Lisp_Object bodyform, Lisp_Object var, Lisp_Object handlers)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1748 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1749 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1750 EXTERNAL_LIST_LOOP_2 (handler, handlers)
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 if (NILP (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 else if (CONSP (handler))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1755 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1756 Lisp_Object conditions = XCAR (handler);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1757 /* CONDITIONS must a condition name or a list of condition names */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1758 if (SYMBOLP (conditions))
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 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1761 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1762 EXTERNAL_LIST_LOOP_2 (condition, conditions)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1763 if (!SYMBOLP (condition))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1764 goto invalid_condition_handler;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1765 }
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 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1768 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1769 invalid_condition_handler:
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
1770 sferror ("Invalid condition handler", handler);
428
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 }
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 CHECK_SYMBOL (var);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1775
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1776 return condition_case_1 (handlers,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1777 Feval, bodyform,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1778 run_condition_case_handlers,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1779 var);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1780 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1781
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1782 DEFUN ("condition-case", Fcondition_case, 2, UNEVALLED, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1783 Regain control when an error is signalled.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1784 Usage looks like (condition-case VAR BODYFORM HANDLERS...).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1785 Executes BODYFORM and returns its value if no error happens.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1786 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1787 where the BODY is made of Lisp expressions.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1788
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1789 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
1790 error's condition names. If an error happens, the first applicable
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1791 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
1792 all errors, even those without the `error' condition name on them
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1793 \(e.g. `quit').
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1794
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1795 The car of a handler may be a list of condition names
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1796 instead of a single condition name.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1797
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1798 When a handler handles an error,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1799 control returns to the condition-case and the handler BODY... is executed
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1800 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1801 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
1802
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1803 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
1804 See also the function `signal' for more info.
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 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
1807 and the current catches, condition-cases, and bindings have all been
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1808 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
1809 `condition-case'. This means that resignalling the error from
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1810 within the handler will not result in an infinite loop.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1811
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1812 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
1813 Lisp stack, bindings, etc. as they were when `signal' was called,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1814 rather than when the handler was set, use `call-with-condition-handler'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1815 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1816 (args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1817 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1818 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1819 Lisp_Object var = XCAR (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1820 Lisp_Object bodyform = XCAR (XCDR (args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1821 Lisp_Object handlers = XCDR (XCDR (args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1822 return condition_case_3 (bodyform, var, handlers);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1823 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1824
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1825 DEFUN ("call-with-condition-handler", Fcall_with_condition_handler, 2, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1826 Regain control when an error is signalled, without popping the stack.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1827 Usage looks like (call-with-condition-handler HANDLER FUNCTION &rest ARGS).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1828 This function is similar to `condition-case', but the handler is invoked
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1829 with the same environment (Lisp stack, bindings, catches, condition-cases)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1830 that was current when `signal' was called, rather than when the handler
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1831 was established.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1832
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1833 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
1834 \(SIG . DATA) that were passed to `signal'. It is invoked whenever
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1835 `signal' is called (this differs from `condition-case', which allows
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1836 you to specify which errors are trapped). If the handler function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1837 returns, `signal' continues as if the handler were never invoked.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1838 \(It continues to look for handlers established earlier than this one,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1839 and invokes the standard error-handler if none is found.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1840 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1841 (int nargs, Lisp_Object *args)) /* Note! Args side-effected! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1842 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1843 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1844 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1845 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1846
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1847 /* #### 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
1848 which accepted one arg, that should be done here ... */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1849
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1850 /* (handler-fun . handler-args) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1851 tem = noseeum_cons (list1 (args[0]), Vcondition_handlers);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1852 record_unwind_protect (condition_bind_unwind, tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1853 Vcondition_handlers = tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1854
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1855 /* Caller should have GC-protected args */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1856 return unbind_to (speccount, Ffuncall (nargs - 1, args + 1));
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1859 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1860 condition_type_p (Lisp_Object type, Lisp_Object conditions)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1861 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1862 if (EQ (type, Qt))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1863 /* (condition-case c # (t c)) catches -all- signals
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1864 * Use with caution! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1865 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1866
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1867 if (SYMBOLP (type))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1868 return !NILP (Fmemq (type, conditions));
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 for (; CONSP (type); type = XCDR (type))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1871 if (!NILP (Fmemq (XCAR (type), conditions)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1872 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1873
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1874 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1875 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1876
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1877 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1878 return_from_signal (Lisp_Object value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1879 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1880 #if 1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1881 /* Most callers are not prepared to handle gc if this
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1882 returns. So, since this feature is not very useful,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1883 take it out. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1884 /* Have called debugger; return value to signaller */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1885 return value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1886 #else /* But the reality is that that stinks, because: */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1887 /* GACK!!! Really want some way for debug-on-quit errors
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1888 to be continuable!! */
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
1889 signal_error (Qunimplemented,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
1890 "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
1891 Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1892 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1893 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1894
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1895 extern int in_display;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1896
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1897
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1898 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1899 /* the workhorse error-signaling function */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1900 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1901
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1902 /* #### This function has not been synched with FSF. It diverges
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1903 significantly. */
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 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1906 signal_1 (Lisp_Object sig, Lisp_Object data)
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 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1909 struct gcpro gcpro1, gcpro2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1910 Lisp_Object conditions;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1911 Lisp_Object handlers;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1912 /* signal_call_debugger() could get called more than once
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1913 (once when a call-with-condition-handler is about to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1914 be dealt with, and another when a condition-case handler
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1915 is about to be invoked). So make sure the debugger and/or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1916 stack trace aren't done more than once. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1917 int stack_trace_displayed = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1918 int debugger_entered = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1919 GCPRO2 (conditions, handlers);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1920
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1921 if (!initialized)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1922 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1923 /* who knows how much has been initialized? Safest bet is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1924 just to bomb out immediately. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1925 /* let's not use stderr_out() here, because that does a bunch of
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1926 things that might not be safe yet. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1927 fprintf (stderr, "Error before initialization is complete!\n");
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1928 abort ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1929 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1930
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1931 if (gc_in_progress || in_display)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1932 /* 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
1933 There is no sensible way to handle errors there. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1934 abort ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1935
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1936 conditions = Fget (sig, Qerror_conditions, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1937
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1938 for (handlers = Vcondition_handlers;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1939 CONSP (handlers);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1940 handlers = XCDR (handlers))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1941 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1942 Lisp_Object handler_fun = XCAR (XCAR (handlers));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1943 Lisp_Object handler_data = XCDR (XCAR (handlers));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1944 Lisp_Object outer_handlers = XCDR (handlers);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1945
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1946 if (!UNBOUNDP (handler_fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1947 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1948 /* call-with-condition-handler */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1949 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1950 Lisp_Object all_handlers = Vcondition_handlers;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1951 struct gcpro ngcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1952 NGCPRO1 (all_handlers);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1953 Vcondition_handlers = outer_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 tem = signal_call_debugger (conditions, sig, data,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1956 outer_handlers, 1,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1957 &stack_trace_displayed,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1958 &debugger_entered);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1959 if (!UNBOUNDP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1960 RETURN_NUNGCPRO (return_from_signal (tem));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1961
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1962 tem = Fcons (sig, data);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1963 if (NILP (handler_data))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1964 tem = call1 (handler_fun, tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1965 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1966 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1967 /* (This code won't be used (for now?).) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1968 struct gcpro nngcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1969 Lisp_Object args[3];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1970 NNGCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1971 nngcpro1.nvars = 3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1972 args[0] = handler_fun;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1973 args[1] = tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1974 args[2] = handler_data;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1975 nngcpro1.var = args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1976 tem = Fapply (3, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1977 NNUNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1978 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1979 NUNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1980 #if 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1981 if (!EQ (tem, Qsignal))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1982 return return_from_signal (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1983 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1984 /* If handler didn't throw, try another handler */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1985 Vcondition_handlers = all_handlers;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1986 }
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 /* It's a condition-case handler */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1989
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1990 /* 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
1991 * debugger is not called even if debug_on_error */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1992 else if (EQ (handler_data, Qt))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1993 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1994 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1995 return Fthrow (handlers, Fcons (sig, data));
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 /* `error' is used similarly to the way `t' is used, but in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1998 addition it invokes the debugger if debug_on_error.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1999 This is normally used for the outer command-loop error
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2000 handler. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2001 else if (EQ (handler_data, Qerror))
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 Lisp_Object tem = signal_call_debugger (conditions, sig, data,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2004 outer_handlers, 0,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2005 &stack_trace_displayed,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2006 &debugger_entered);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2007
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2008 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2009 if (!UNBOUNDP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2010 return return_from_signal (tem);
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 tem = Fcons (sig, data);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2013 return Fthrow (handlers, tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2014 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2015 else
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 /* handler established by real (Lisp) condition-case */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2018 Lisp_Object h;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2019
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2020 for (h = handler_data; CONSP (h); h = Fcdr (h))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2021 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2022 Lisp_Object clause = Fcar (h);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2023 Lisp_Object tem = Fcar (clause);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2024
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2025 if (condition_type_p (tem, conditions))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2026 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2027 tem = signal_call_debugger (conditions, sig, data,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2028 outer_handlers, 1,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2029 &stack_trace_displayed,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2030 &debugger_entered);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2031 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2032 if (!UNBOUNDP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2033 return return_from_signal (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2034
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2035 /* Doesn't return */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2036 tem = Fcons (Fcons (sig, data), Fcdr (clause));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2037 return Fthrow (handlers, tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2038 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2039 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2040 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2041 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2042
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2043 /* If no handler is present now, try to run the debugger,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2044 and if that fails, throw to top level.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2045
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2046 #### The only time that no handler is present is during
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2047 temacs or perhaps very early in XEmacs. In both cases,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2048 there is no 'top-level catch. (That's why the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2049 "bomb-out" hack was added.)
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 #### Fix this horrifitude!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2052 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2053 signal_call_debugger (conditions, sig, data, Qnil, 0,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2054 &stack_trace_displayed,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2055 &debugger_entered);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2056 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2057 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
2058 return Qnil;
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
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 /****************** Error functions class 1 ******************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2063
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2064 /* Class 1: General functions that signal an error.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2065 These functions take an error type and a list of associated error
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2066 data. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2067
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2068 /* 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
2069 signal_continuable_error_1() in the terminology below, but it's
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2070 Lisp-callable. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2071
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2072 DEFUN ("signal", Fsignal, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2073 Signal a continuable error. Args are ERROR-SYMBOL, and associated DATA.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2074 An error symbol is a symbol defined using `define-error'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2075 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
2076 If the signal is handled, DATA is made available to the handler.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2077 See also the function `signal-error', and the functions to handle errors:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2078 `condition-case' and `call-with-condition-handler'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2079
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2080 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
2081 user invokes the "return from signal" option.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2082 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2083 (error_symbol, data))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2084 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2085 /* Fsignal() is one of these functions that's called all the time
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2086 with newly-created Lisp objects. We allow this; but we must GC-
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2087 protect the objects because all sorts of weird stuff could
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2088 happen. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2089
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2090 struct gcpro gcpro1;
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 GCPRO1 (data);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2093 if (!NILP (Vcurrent_error_state))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2094 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2095 if (!NILP (Vcurrent_warning_class))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2096 warn_when_safe_lispobj (Vcurrent_warning_class, Qwarning,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2097 Fcons (error_symbol, data));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2098 Fthrow (Qunbound_suspended_errors_tag, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2099 abort (); /* Better not get here! */
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 RETURN_UNGCPRO (signal_1 (error_symbol, data));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2102 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2103
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2104 /* Signal a non-continuable error. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2105
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2106 DOESNT_RETURN
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2107 signal_error_1 (Lisp_Object sig, Lisp_Object data)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2108 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2109 for (;;)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2110 Fsignal (sig, data);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2111 }
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2112 #ifdef ERROR_CHECK_TYPECHECK
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2113 void
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2114 check_error_state_sanity (void)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2115 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2116 struct catchtag *c;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2117 int found_error_tag = 0;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2118
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2119 for (c = catchlist; c; c = c->next)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2120 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2121 if (EQ (c->tag, Qunbound_suspended_errors_tag))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2122 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2123 found_error_tag = 1;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2124 break;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2125 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2126 }
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 assert (found_error_tag || NILP (Vcurrent_error_state));
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 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2131
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2132 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2133 restore_current_warning_class (Lisp_Object warning_class)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2134 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2135 Vcurrent_warning_class = warning_class;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2136 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2137 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2138
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2139 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2140 restore_current_error_state (Lisp_Object error_state)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2141 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2142 Vcurrent_error_state = error_state;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2143 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2144 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2145
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2146 static Lisp_Object
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2147 call_with_suspended_errors_1 (Lisp_Object opaque_arg)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2148 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2149 Lisp_Object val;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2150 Lisp_Object *kludgy_args = (Lisp_Object *) get_opaque_ptr (opaque_arg);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2151 Lisp_Object no_error = kludgy_args[2];
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2152 int speccount = specpdl_depth ();
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2153
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2154 if (!EQ (Vcurrent_error_state, no_error))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2155 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2156 record_unwind_protect (restore_current_error_state,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2157 Vcurrent_error_state);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2158 Vcurrent_error_state = no_error;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2159 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2160 PRIMITIVE_FUNCALL (val, get_opaque_ptr (kludgy_args[0]),
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2161 kludgy_args + 3, XINT (kludgy_args[1]));
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2162 return unbind_to (speccount, val);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2163 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2164
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2165 /* 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
2166 occurs:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2167
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2168 (1) signal the error, as usual.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2169 (2) silently fail and return some error value.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2170 (3) do as (2) but issue a warning in the process.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2171
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
2172 Currently there's lots of stuff that passes an Error_Behavior
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2173 value and calls maybe_signal_error() and other such functions.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2174 This approach is inherently error-prone and broken. A much
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2175 more robust and easier approach is to use call_with_suspended_errors().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2176 Wrap this around any function in which you might want errors
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2177 to not be errors.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2178 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2179
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2180 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2181 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
2182 Lisp_Object class, Error_Behavior errb,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2183 int nargs, ...)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2184 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2185 va_list vargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2186 int speccount;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2187 Lisp_Object kludgy_args[23];
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2188 Lisp_Object *args = kludgy_args + 3;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2189 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2190 Lisp_Object no_error;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2191
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2192 assert (SYMBOLP (class)); /* sanity-check */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2193 assert (!NILP (class));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2194 assert (nargs >= 0 && nargs < 20);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2195
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2196 /* ERROR_ME means don't trap errors. (However, if errors are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2197 already trapped, we leave them trapped.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2198
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2199 Otherwise, we trap errors, and trap warnings if ERROR_ME_WARN.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2200
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2201 If ERROR_ME_NOT, it causes no warnings even if warnings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2202 were previously enabled. However, we never change the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2203 warning class from one to another. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2204 if (!ERRB_EQ (errb, ERROR_ME))
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 if (ERRB_EQ (errb, ERROR_ME_NOT)) /* person wants no warnings */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2207 class = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2208 errb = ERROR_ME_NOT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2209 no_error = Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2210 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2211 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2212 no_error = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2213
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2214 va_start (vargs, nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2215 for (i = 0; i < nargs; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2216 args[i] = va_arg (vargs, Lisp_Object);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2217 va_end (vargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2218
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2219 /* If error-checking is not disabled, just call the function.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2220 It's important not to override disabled error-checking with
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2221 enabled error-checking. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2222
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2223 if (ERRB_EQ (errb, ERROR_ME))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2224 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2225 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2226 PRIMITIVE_FUNCALL (val, fun, args, nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2227 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2228 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2229
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2230 speccount = specpdl_depth ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2231 if (NILP (class) || NILP (Vcurrent_warning_class))
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 /* If we're currently calling for no warnings, then make it so.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2234 If we're currently calling for warnings and we weren't
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2235 previously, then set our warning class; otherwise, leave
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2236 the existing one alone. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2237 record_unwind_protect (restore_current_warning_class,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2238 Vcurrent_warning_class);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2239 Vcurrent_warning_class = class;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2240 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2241
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2242 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2243 int threw;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2244 Lisp_Object the_retval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2245 Lisp_Object opaque1 = make_opaque_ptr (kludgy_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2246 Lisp_Object opaque2 = make_opaque_ptr ((void *) fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2247 struct gcpro gcpro1, gcpro2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2248
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2249 GCPRO2 (opaque1, opaque2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2250 kludgy_args[0] = opaque2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2251 kludgy_args[1] = make_int (nargs);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2252 kludgy_args[2] = no_error;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2253 the_retval = internal_catch (Qunbound_suspended_errors_tag,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2254 call_with_suspended_errors_1,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2255 opaque1, &threw);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2256 free_opaque_ptr (opaque1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2257 free_opaque_ptr (opaque2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2258 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2259 /* Use the returned value except in non-local exit, when
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2260 RETVAL applies. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2261 /* Some perverse compilers require the perverse cast below. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2262 return unbind_to (speccount,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2263 threw ? *((Lisp_Object*) &(retval)) : the_retval);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2264 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2265 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2266
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2267 /* Signal a non-continuable error or display a warning or do nothing,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2268 according to ERRB. CLASS is the class of warning and should
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2269 refer to what sort of operation is being done (e.g. Qtoolbar,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2270 Qresource, etc.). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2271
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2272 void
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2273 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
2274 Error_Behavior errb)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2275 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2276 if (ERRB_EQ (errb, ERROR_ME_NOT))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2277 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2278 else if (ERRB_EQ (errb, ERROR_ME_WARN))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2279 warn_when_safe_lispobj (class, Qwarning, Fcons (sig, data));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2280 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2281 for (;;)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2282 Fsignal (sig, data);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2283 }
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 /* Signal a continuable error or display a warning or do nothing,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2286 according to ERRB. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2287
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2288 Lisp_Object
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2289 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
2290 Lisp_Object class, Error_Behavior errb)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2291 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2292 if (ERRB_EQ (errb, ERROR_ME_NOT))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2293 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2294 else if (ERRB_EQ (errb, ERROR_ME_WARN))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2295 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2296 warn_when_safe_lispobj (class, Qwarning, Fcons (sig, data));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2297 return Qnil;
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 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2300 return Fsignal (sig, data);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2301 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2304 /****************** Error functions class 2 ******************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2305
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2306 /* 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
2307 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
2308 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
2309 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
2310 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
2311 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
2312 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
2313 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
2314 specified as FROB. */
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2315
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2316 /* 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
2317 to signal_error_1(). */
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2318
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2319 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2320 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
2321 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2322 if (EQ (frob, Qunbound))
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2323 frob = Qnil;
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2324 else if (CONSP (frob) && EQ (XCAR (frob), Qunbound))
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2325 frob = XCDR (frob);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2326 else
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2327 frob = list1 (frob);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2328 if (!reason)
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2329 return frob;
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2330 else
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2331 return Fcons (build_translated_string (reason), frob);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2332 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2333
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2334 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2335 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
2336 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2337 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
2338 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2339
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2340 void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2341 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
2342 Lisp_Object frob, Lisp_Object class,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
2343 Error_Behavior errb)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2344 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2345 /* Optimization: */
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2346 if (ERRB_EQ (errb, ERROR_ME_NOT))
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2347 return;
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2348 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
2349 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2350
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2351 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2352 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
2353 Lisp_Object frob)
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2354 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2355 return Fsignal (type, build_error_data (reason, frob));
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
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2358 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2359 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
2360 Lisp_Object frob, Lisp_Object class,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
2361 Error_Behavior errb)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2362 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2363 /* Optimization: */
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2364 if (ERRB_EQ (errb, ERROR_ME_NOT))
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2365 return Qnil;
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2366 return maybe_signal_continuable_error_1 (type,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2367 build_error_data (reason, frob),
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2368 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
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2372 /****************** Error functions class 3 ******************/
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2373
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2374 /* 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
2375 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
2376 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
2377 (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
2378 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
2379
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2380 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2381 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
2382 Lisp_Object frob0, Lisp_Object frob1)
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2383 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2384 signal_error_1 (type, list3 (build_translated_string (reason), frob0,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2385 frob1));
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2386 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2387
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2388 void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2389 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
2390 Lisp_Object frob0, Lisp_Object frob1,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
2391 Lisp_Object class, Error_Behavior errb)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2392 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2393 /* Optimization: */
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2394 if (ERRB_EQ (errb, ERROR_ME_NOT))
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2395 return;
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2396 maybe_signal_error_1 (type, list3 (build_translated_string (reason), frob0,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2397 frob1), class, errb);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2398 }
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 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2401 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
2402 Lisp_Object frob0, Lisp_Object frob1)
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2403 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2404 return Fsignal (type, list3 (build_translated_string (reason), frob0,
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 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2409 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
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 Qnil;
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2416 return maybe_signal_continuable_error_1
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2417 (type, list3 (build_translated_string (reason), frob0, frob1),
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2418 class, errb);
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
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2421
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2422 /****************** Error functions class 4 ******************/
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2423
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2424 /* Class 4: Printf-like functions that signal an error.
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2425 These functions signal an error of a specified type, whose data
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2426 is a single string, created using the arguments. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2427
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2428 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2429 signal_ferror (Lisp_Object type, const CIntbyte *fmt, ...)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2430 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2431 Lisp_Object obj;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2432 va_list args;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2433
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2434 va_start (args, fmt);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2435 obj = emacs_doprnt_string_va ((const Intbyte *) GETTEXT (fmt), Qnil, -1,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2436 args);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2437 va_end (args);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2438
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2439 /* Fsignal GC-protects its args */
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2440 signal_error (type, 0, obj);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2441 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2443 void
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
2444 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
2445 const CIntbyte *fmt, ...)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2446 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2447 Lisp_Object obj;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2448 va_list args;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2449
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2450 /* Optimization: */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2451 if (ERRB_EQ (errb, ERROR_ME_NOT))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2452 return;
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);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2455 obj = emacs_doprnt_string_va ((const Intbyte *) GETTEXT (fmt), Qnil, -1,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2456 args);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2457 va_end (args);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2458
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2459 /* Fsignal GC-protects its args */
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2460 maybe_signal_error (type, 0, obj, class, errb);
442
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
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2463 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2464 signal_continuable_ferror (Lisp_Object type, const CIntbyte *fmt, ...)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2465 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2466 Lisp_Object obj;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2467 va_list args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2468
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2469 va_start (args, fmt);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2470 obj = emacs_doprnt_string_va ((const Intbyte *) GETTEXT (fmt), Qnil, -1,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2471 args);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2472 va_end (args);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2473
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2474 /* Fsignal GC-protects its args */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2475 return Fsignal (type, list1 (obj));
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
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2478 Lisp_Object
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2479 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
2480 Error_Behavior errb, const CIntbyte *fmt, ...)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2481 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2482 Lisp_Object obj;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2483 va_list args;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2484
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2485 /* Optimization: */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2486 if (ERRB_EQ (errb, ERROR_ME_NOT))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2487 return Qnil;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2488
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2489 va_start (args, fmt);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2490 obj = emacs_doprnt_string_va ((const Intbyte *) GETTEXT (fmt), Qnil, -1,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2491 args);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2492 va_end (args);
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 /* Fsignal GC-protects its args */
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2495 return maybe_signal_continuable_error (type, 0, obj, class, errb);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2496 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2497
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 /****************** Error functions class 5 ******************/
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2500
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2501 /* Class 5: Printf-like functions that signal an error.
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2502 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
2503 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
2504 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
2505 is the same as for class 2.)
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2506
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2507 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
2508 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
2509 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
2510 not commonly used.
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2511 */
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 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2514 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
2515 ...)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2516 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2517 Lisp_Object obj;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2518 va_list args;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2519
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2520 va_start (args, fmt);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2521 obj = emacs_doprnt_string_va ((const Intbyte *) GETTEXT (fmt), Qnil, -1,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2522 args);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2523 va_end (args);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2524
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2525 /* Fsignal GC-protects its args */
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2526 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
2527 }
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 void
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2530 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
2531 Lisp_Object class, Error_Behavior errb,
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2532 const CIntbyte *fmt, ...)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2533 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2534 Lisp_Object obj;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2535 va_list args;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2536
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2537 /* Optimization: */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2538 if (ERRB_EQ (errb, ERROR_ME_NOT))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2539 return;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2540
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2541 va_start (args, fmt);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2542 obj = emacs_doprnt_string_va ((const Intbyte *) GETTEXT (fmt), Qnil, -1,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2543 args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2544 va_end (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2545
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2546 /* Fsignal GC-protects its args */
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2547 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
2548 errb);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2549 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2550
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2551 Lisp_Object
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2552 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
2553 const CIntbyte *fmt, ...)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2554 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2555 Lisp_Object obj;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2556 va_list args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2557
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2558 va_start (args, fmt);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2559 obj = emacs_doprnt_string_va ((const Intbyte *) GETTEXT (fmt), Qnil, -1,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2560 args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2561 va_end (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2562
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2563 /* Fsignal GC-protects its args */
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2564 return Fsignal (type, Fcons (obj, build_error_data (0, frob)));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2565 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2566
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2567 Lisp_Object
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2568 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
2569 Lisp_Object class,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
2570 Error_Behavior errb,
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2571 const CIntbyte *fmt, ...)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2572 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2573 Lisp_Object obj;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2574 va_list 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 /* Optimization: */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2577 if (ERRB_EQ (errb, ERROR_ME_NOT))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2578 return Qnil;
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 va_start (args, fmt);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2581 obj = emacs_doprnt_string_va ((const Intbyte *) GETTEXT (fmt), Qnil, -1,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2582 args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2583 va_end (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2584
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2585 /* Fsignal GC-protects its args */
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2586 return maybe_signal_continuable_error_1 (type,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2587 Fcons (obj,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2588 build_error_data (0, frob)),
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2589 class, errb);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2590 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2591
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 /* This is what the QUIT macro calls to signal a quit */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2594 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2595 signal_quit (void)
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 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2598 if (EQ (Vquit_flag, Qcritical))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2599 debug_on_quit |= 2; /* set critical bit. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2600 Vquit_flag = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2601 /* note that this is continuable. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2602 Fsignal (Qquit, Qnil);
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
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2606 /************************ convenience error functions ***********************/
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2607
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
2608 Lisp_Object
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2609 signal_void_function_error (Lisp_Object function)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2610 {
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
2611 return Fsignal (Qvoid_function, list1 (function));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2612 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2613
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
2614 Lisp_Object
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2615 signal_invalid_function_error (Lisp_Object function)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2616 {
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
2617 return Fsignal (Qinvalid_function, list1 (function));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2618 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
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_wrong_number_of_arguments_error (Lisp_Object function, int nargs)
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 (Qwrong_number_of_arguments,
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
2624 list2 (function, make_int (nargs)));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2625 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2626
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2627 /* Used in list traversal macros for efficiency. */
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
2628 DOESNT_RETURN
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2629 signal_malformed_list_error (Lisp_Object list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2630 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2631 signal_error (Qmalformed_list, 0, list);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2632 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2633
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
2634 DOESNT_RETURN
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2635 signal_malformed_property_list_error (Lisp_Object list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2636 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2637 signal_error (Qmalformed_property_list, 0, list);
428
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
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_circular_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 (Qcircular_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_circular_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 (Qcircular_property_list, 0, list);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2650 }
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2651
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2652 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2653 syntax_error (const CIntbyte *reason, Lisp_Object frob)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2654 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2655 signal_error (Qsyntax_error, reason, frob);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2656 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2657
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2658 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2659 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
2660 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2661 signal_error_2 (Qsyntax_error, reason, frob1, frob2);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2662 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2663
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2664 void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2665 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
2666 Lisp_Object class, Error_Behavior errb)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2667 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2668 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
2669 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2670
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2671 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2672 sferror (const CIntbyte *reason, Lisp_Object frob)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2673 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2674 signal_error (Qstructure_formation_error, reason, frob);
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
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2677 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2678 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
2679 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2680 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
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 void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2684 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
2685 Lisp_Object class, Error_Behavior errb)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2686 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2687 maybe_signal_error (Qstructure_formation_error, reason, frob, class, errb);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2688 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2689
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2690 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2691 invalid_argument (const CIntbyte *reason, Lisp_Object frob)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2692 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2693 signal_error (Qinvalid_argument, reason, frob);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2694 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2695
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2696 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2697 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
2698 Lisp_Object frob2)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2699 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2700 signal_error_2 (Qinvalid_argument, reason, frob1, frob2);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2701 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2702
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2703 void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2704 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
2705 Lisp_Object class, Error_Behavior errb)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2706 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2707 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
2708 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2709
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2710 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2711 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
2712 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2713 signal_error (Qinvalid_constant, reason, frob);
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
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2716 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2717 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
2718 Lisp_Object frob2)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2719 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2720 signal_error_2 (Qinvalid_constant, reason, frob1, frob2);
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
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2723 void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2724 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
2725 Lisp_Object class, Error_Behavior errb)
563
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 maybe_signal_error (Qinvalid_constant, reason, frob, class, errb);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2728 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2729
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2730 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2731 invalid_operation (const CIntbyte *reason, Lisp_Object frob)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2732 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2733 signal_error (Qinvalid_operation, reason, frob);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2734 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2735
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2736 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2737 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
2738 Lisp_Object frob2)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2739 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2740 signal_error_2 (Qinvalid_operation, reason, frob1, frob2);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2741 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2742
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2743 void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2744 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
2745 Lisp_Object class, Error_Behavior errb)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2746 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2747 maybe_signal_error (Qinvalid_operation, reason, frob, class, errb);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2748 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2749
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2750 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2751 invalid_change (const CIntbyte *reason, Lisp_Object frob)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2752 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2753 signal_error (Qinvalid_change, reason, frob);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2754 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2755
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2756 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2757 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
2758 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2759 signal_error_2 (Qinvalid_change, reason, frob1, frob2);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2760 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2761
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2762 void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2763 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
2764 Lisp_Object class, Error_Behavior errb)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2765 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2766 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
2767 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2768
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2769 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2770 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
2771 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2772 signal_error (Qinvalid_state, reason, frob);
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
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2775 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2776 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
2777 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2778 signal_error_2 (Qinvalid_state, reason, frob1, frob2);
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 void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2782 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
2783 Lisp_Object class, Error_Behavior errb)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2784 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2785 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
2786 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2787
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2788 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2789 wtaerror (const CIntbyte *reason, Lisp_Object frob)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2790 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2791 signal_error (Qwrong_type_argument, reason, frob);
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
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2794 DOESNT_RETURN
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2795 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
2796 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2797 signal_error (Qstack_overflow, reason, frob);
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 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
2802 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2803 signal_error (Qout_of_memory, 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 printing_unreadable_object (const CIntbyte *fmt, ...)
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 Lisp_Object obj;
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2810 va_list args;
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 va_start (args, fmt);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2813 obj = emacs_doprnt_string_va ((const Intbyte *) GETTEXT (fmt), Qnil, -1,
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2814 args);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2815 va_end (args);
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 /* Fsignal GC-protects its args */
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
2818 signal_error (Qprinting_unreadable_object, 0, obj);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2819 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2820
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2821
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2822 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2823 /* User commands */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2824 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2825
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2826 DEFUN ("commandp", Fcommandp, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2827 Return t if FUNCTION makes provisions for interactive calling.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2828 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
2829 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
2830 definition.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2831
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2832 Interactively callable functions include
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 -- strings and vectors (treated as keyboard macros)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2835 -- lambda-expressions that contain a top-level call to `interactive'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2836 -- autoload definitions made by `autoload' with non-nil fourth argument
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2837 (i.e. the interactive flag)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2838 -- compiled-function objects with a non-nil `compiled-function-interactive'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2839 value
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2840 -- subrs (built-in functions) that are interactively callable
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2841
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2842 Also, a symbol satisfies `commandp' if its function definition does so.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2843 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2844 (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2845 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2846 Lisp_Object fun = indirect_function (function, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2847
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2848 if (COMPILED_FUNCTIONP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2849 return XCOMPILED_FUNCTION (fun)->flags.interactivep ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2850
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2851 /* Lists may represent commands. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2852 if (CONSP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2853 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2854 Lisp_Object funcar = XCAR (fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2855 if (EQ (funcar, Qlambda))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2856 return Fassq (Qinteractive, Fcdr (Fcdr (fun)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2857 if (EQ (funcar, Qautoload))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2858 return Fcar (Fcdr (Fcdr (Fcdr (fun))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2859 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2860 return 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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2863 /* Emacs primitives are interactive if their DEFUN specifies an
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2864 interactive spec. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2865 if (SUBRP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2866 return XSUBR (fun)->prompt ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2867
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2868 /* Strings and vectors are keyboard macros. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2869 if (VECTORP (fun) || STRINGP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2870 return Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2871
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2872 /* Everything else (including Qunbound) is not a command. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2873 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2874 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2875
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2876 DEFUN ("command-execute", Fcommand_execute, 1, 3, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2877 Execute CMD as an editor command.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2878 CMD must be an object that satisfies the `commandp' predicate.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2879 Optional second arg RECORD-FLAG is as in `call-interactively'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2880 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
2881 when reading the arguments.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2882 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2883 (cmd, record_flag, keys))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2884 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2885 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2886 Lisp_Object prefixarg;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2887 Lisp_Object final = cmd;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2888 struct backtrace backtrace;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2889 struct console *con = XCONSOLE (Vselected_console);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2890
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2891 prefixarg = con->prefix_arg;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2892 con->prefix_arg = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2893 Vcurrent_prefix_arg = prefixarg;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2894 debug_on_next_call = 0; /* #### from FSFmacs; correct? */
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 if (SYMBOLP (cmd) && !NILP (Fget (cmd, Qdisabled, Qnil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2897 return run_hook (Vdisabled_command_hook);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2898
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2899 for (;;)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2900 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2901 final = indirect_function (cmd, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2902 if (CONSP (final) && EQ (Fcar (final), Qautoload))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2903 do_autoload (final, cmd);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2904 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2905 break;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2908 if (CONSP (final) || SUBRP (final) || COMPILED_FUNCTIONP (final))
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 backtrace.function = &Qcall_interactively;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2911 backtrace.args = &cmd;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2912 backtrace.nargs = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2913 backtrace.evalargs = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2914 backtrace.pdlcount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2915 backtrace.debug_on_exit = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2916 PUSH_BACKTRACE (backtrace);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2917
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2918 final = Fcall_interactively (cmd, record_flag, keys);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2919
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2920 POP_BACKTRACE (backtrace);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2921 return final;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2922 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2923 else if (STRINGP (final) || VECTORP (final))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2924 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2925 return Fexecute_kbd_macro (final, prefixarg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2926 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2927 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2928 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2929 Fsignal (Qwrong_type_argument,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2930 Fcons (Qcommandp,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2931 (EQ (cmd, final)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2932 ? list1 (cmd)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2933 : list2 (cmd, final))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2934 return Qnil;
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 }
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 DEFUN ("interactive-p", Finteractive_p, 0, 0, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2939 Return t if function in which this appears was called interactively.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2940 This means that the function was called with call-interactively (which
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2941 includes being called as the binding of a key)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2942 and input is currently coming from the keyboard (not in keyboard macro).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2943 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2944 ())
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2945 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2946 REGISTER struct backtrace *btp;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2947 REGISTER Lisp_Object fun;
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 if (!INTERACTIVE)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2950 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2951
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2952 /* Unless the object was compiled, skip the frame of interactive-p itself
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2953 (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
2954 function). Note that *btp->function may be a symbol pointing at a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2955 compiled function. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2956 btp = backtrace_list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2957
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2958 #if 0 /* FSFmacs */
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 /* #### FSFmacs does the following instead. I can't figure
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2961 out which one is more correct. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2962 /* 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
2963 the top for Finteractive_p itself. If so, skip it. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2964 fun = Findirect_function (*btp->function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2965 if (SUBRP (fun) && XSUBR (fun) == &Sinteractive_p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2966 btp = btp->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2967
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2968 /* If we're running an Emacs 18-style byte-compiled function, there
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2969 may be a frame for Fbyte_code. Now, given the strictest
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2970 definition, this function isn't really being called
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2971 interactively, but because that's the way Emacs 18 always builds
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2972 byte-compiled functions, we'll accept it for now. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2973 if (EQ (*btp->function, Qbyte_code))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2974 btp = btp->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2975
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2976 /* 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
2977 looking at several frames for special forms. Skip past them. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2978 while (btp &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2979 btp->nargs == UNEVALLED)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2980 btp = btp->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2981
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2982 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2983
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2984 if (! (COMPILED_FUNCTIONP (Findirect_function (*btp->function))))
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 for (;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2987 btp && (btp->nargs == UNEVALLED
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2988 || EQ (*btp->function, Qbyte_code));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2989 btp = btp->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2990 {}
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2991 /* btp now points at the frame of the innermost function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2992 that DOES eval its args.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2993 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
2994 return nil. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2995 /* Beats me why this is necessary, but it is */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2996 if (btp && EQ (*btp->function, Qcall_interactively))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2997 return Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2998
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2999 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3001 fun = Findirect_function (*btp->function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3002 if (SUBRP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3003 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3004 /* 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
3005 Return t if that function was called interactively. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3006 if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3007 return Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3008 return Qnil;
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
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 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3013 /* Autoloading */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3014 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3015
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3016 DEFUN ("autoload", Fautoload, 2, 5, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3017 Define FUNCTION to autoload from FILENAME.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3018 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
3019 The remaining optional arguments provide additional info about the
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3020 real definition.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3021 DOCSTRING is documentation for FUNCTION.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3022 INTERACTIVE, if non-nil, says FUNCTION can be called interactively.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3023 TYPE indicates the type of the object:
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3024 nil or omitted says FUNCTION is a function,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3025 `keymap' says FUNCTION is really a keymap, and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3026 `macro' or t says FUNCTION is really a macro.
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3027 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
3028 autoload object, this function does nothing and returns nil.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3029 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3030 (function, filename, docstring, interactive, type))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3031 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3032 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3033 CHECK_SYMBOL (function);
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3034 CHECK_STRING (filename);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3035
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3036 /* If function is defined and not as an autoload, don't override */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3037 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3038 Lisp_Object f = XSYMBOL (function)->function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3039 if (!UNBOUNDP (f) && !(CONSP (f) && EQ (XCAR (f), Qautoload)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3040 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3041 }
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 if (purify_flag)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3044 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3045 /* Attempt to avoid consing identical (string=) pure strings. */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3046 filename = Fsymbol_name (Fintern (filename, Qnil));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3047 }
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3048
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3049 return Ffset (function, Fcons (Qautoload, list4 (filename,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3050 docstring,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3051 interactive,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3052 type)));
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3055 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3056 un_autoload (Lisp_Object oldqueue)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3057 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3058 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3059 REGISTER Lisp_Object queue, first, second;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3060
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3061 /* Queue to unwind is current value of Vautoload_queue.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3062 oldqueue is the shadowed value to leave in Vautoload_queue. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3063 queue = Vautoload_queue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3064 Vautoload_queue = oldqueue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3065 while (CONSP (queue))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3066 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3067 first = XCAR (queue);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3068 second = Fcdr (first);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3069 first = Fcar (first);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3070 if (NILP (second))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3071 Vfeatures = first;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3072 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3073 Ffset (first, second);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3074 queue = Fcdr (queue);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3075 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3076 return Qnil;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3079 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3080 do_autoload (Lisp_Object fundef,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3081 Lisp_Object funname)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3082 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3083 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3084 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3085 Lisp_Object fun = funname;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3086 struct gcpro gcpro1, gcpro2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3087
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3088 CHECK_SYMBOL (funname);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3089 GCPRO2 (fun, funname);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3090
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3091 /* Value saved here is to be restored into Vautoload_queue */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3092 record_unwind_protect (un_autoload, Vautoload_queue);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3093 Vautoload_queue = Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3094 call4 (Qload, Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3095
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3096 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3097 Lisp_Object queue;
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 /* Save the old autoloads, in case we ever do an unload. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3100 for (queue = Vautoload_queue; CONSP (queue); queue = XCDR (queue))
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 Lisp_Object first = XCAR (queue);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3103 Lisp_Object second = Fcdr (first);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3104
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3105 first = Fcar (first);
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 /* Note: This test is subtle. The cdr of an autoload-queue entry
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3108 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
3109 or fset. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3110 if (CONSP (second))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3111 Fput (first, Qautoload, (XCDR (second)));
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3114
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3115 /* Once loading finishes, don't undo it. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3116 Vautoload_queue = Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3117 unbind_to (speccount, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3118
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3119 fun = indirect_function (fun, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3120
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3121 #if 0 /* FSFmacs */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3122 if (!NILP (Fequal (fun, fundef)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3123 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3124 if (UNBOUNDP (fun)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3125 || (CONSP (fun)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3126 && EQ (XCAR (fun), Qautoload)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3127 #endif
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
3128 invalid_state ("Autoloading failed to define function", funname);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3129 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3130 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3133 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3134 /* eval, funcall, apply */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3135 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3136
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3137 static Lisp_Object funcall_lambda (Lisp_Object fun,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3138 int nargs, Lisp_Object args[]);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3139 static int in_warnings;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3140
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3141 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3142 in_warnings_restore (Lisp_Object minimus)
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 in_warnings = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3145 return Qnil;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3148 DEFUN ("eval", Feval, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3149 Evaluate FORM and return its value.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3150 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3151 (form))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3152 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3153 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3154 Lisp_Object fun, val, original_fun, original_args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3155 int nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3156 struct backtrace backtrace;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3157
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3158 /* 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
3159 while (!in_warnings && !NILP (Vpending_warnings))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3160 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3161 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3162 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3163 Lisp_Object this_warning_cons, this_warning, class, level, messij;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3164
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3165 record_unwind_protect (in_warnings_restore, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3166 in_warnings = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3167 this_warning_cons = Vpending_warnings;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3168 this_warning = XCAR (this_warning_cons);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3169 /* in case an error occurs in the warn function, at least
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3170 it won't happen infinitely */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3171 Vpending_warnings = XCDR (Vpending_warnings);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3172 free_cons (XCONS (this_warning_cons));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3173 class = XCAR (this_warning);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3174 level = XCAR (XCDR (this_warning));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3175 messij = XCAR (XCDR (XCDR (this_warning)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3176 free_list (this_warning);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3177
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3178 if (NILP (Vpending_warnings))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3179 Vpending_warnings_tail = Qnil; /* perhaps not strictly necessary,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3180 but safer */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3181
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3182 GCPRO4 (form, class, level, messij);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3183 if (!STRINGP (messij))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3184 messij = Fprin1_to_string (messij, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3185 call3 (Qdisplay_warning, class, messij, level);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3186 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3187 unbind_to (speccount, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3188 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3189
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3190 if (!CONSP (form))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3191 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3192 if (SYMBOLP (form))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3193 return Fsymbol_value (form);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3194 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3195 return form;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3196 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3197
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3198 QUIT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3199 if ((consing_since_gc > gc_cons_threshold) || always_gc)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3200 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3201 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3202 GCPRO1 (form);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3203 garbage_collect_1 ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3204 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3205 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3206
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3207 if (++lisp_eval_depth > max_lisp_eval_depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3208 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3209 if (max_lisp_eval_depth < 100)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3210 max_lisp_eval_depth = 100;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3211 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
3212 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
3213 Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3214 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3215
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3216 /* We guaranteed CONSP (form) above */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3217 original_fun = XCAR (form);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3218 original_args = XCDR (form);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3219
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3220 GET_EXTERNAL_LIST_LENGTH (original_args, nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3221
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3222 backtrace.pdlcount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3223 backtrace.function = &original_fun; /* This also protects them from gc */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3224 backtrace.args = &original_args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3225 backtrace.nargs = UNEVALLED;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3226 backtrace.evalargs = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3227 backtrace.debug_on_exit = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3228 PUSH_BACKTRACE (backtrace);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3229
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3230 if (debug_on_next_call)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3231 do_debug_on_call (Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3232
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3233 if (profiling_active)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3234 profile_increase_call_count (original_fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3235
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3236 /* At this point, only original_fun and original_args
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3237 have values that will be used below. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3238 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3239 fun = indirect_function (original_fun, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3240
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3241 if (SUBRP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3242 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3243 Lisp_Subr *subr = XSUBR (fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3244 int max_args = subr->max_args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3245
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3246 if (nargs < subr->min_args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3247 goto wrong_number_of_arguments;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3248
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3249 if (max_args == UNEVALLED) /* Optimize for the common case */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3250 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3251 backtrace.evalargs = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3252 val = (((Lisp_Object (*) (Lisp_Object)) subr_function (subr))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3253 (original_args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3254 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3255 else if (nargs <= max_args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3256 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3257 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3258 Lisp_Object args[SUBR_MAX_ARGS];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3259 REGISTER Lisp_Object *p = args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3260
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3261 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3262 gcpro1.nvars = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3263
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3264 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3265 LIST_LOOP_2 (arg, original_args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3266 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3267 *p++ = Feval (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3268 gcpro1.nvars++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3269 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3270 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3271
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3272 /* &optional args default to nil. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3273 while (p - args < max_args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3274 *p++ = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3275
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3276 backtrace.args = args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3277 backtrace.nargs = nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3278
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3279 FUNCALL_SUBR (val, subr, args, max_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3280
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3281 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3282 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3283 else if (max_args == MANY)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3284 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3285 /* Pass a vector of evaluated arguments */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3286 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3287 Lisp_Object *args = alloca_array (Lisp_Object, nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3288 REGISTER Lisp_Object *p = args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3289
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3290 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3291 gcpro1.nvars = 0;
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 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3294 LIST_LOOP_2 (arg, original_args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3295 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3296 *p++ = Feval (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3297 gcpro1.nvars++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3298 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3301 backtrace.args = args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3302 backtrace.nargs = nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3303
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3304 val = (((Lisp_Object (*) (int, Lisp_Object *)) subr_function (subr))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3305 (nargs, args));
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 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3308 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3309 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3310 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3311 wrong_number_of_arguments:
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3312 val = signal_wrong_number_of_arguments_error (original_fun, nargs);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3313 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3314 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3315 else if (COMPILED_FUNCTIONP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3316 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3317 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3318 Lisp_Object *args = alloca_array (Lisp_Object, nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3319 REGISTER Lisp_Object *p = args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3320
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3321 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3322 gcpro1.nvars = 0;
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 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3325 LIST_LOOP_2 (arg, original_args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3326 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3327 *p++ = Feval (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3328 gcpro1.nvars++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3329 }
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 backtrace.args = args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3333 backtrace.nargs = nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3334 backtrace.evalargs = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3335
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3336 val = funcall_compiled_function (fun, nargs, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3337
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3338 /* Do the debug-on-exit now, while args is still GCPROed. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3339 if (backtrace.debug_on_exit)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3340 val = do_debug_on_exit (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3341 /* Don't do it again when we return to eval. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3342 backtrace.debug_on_exit = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3343
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3344 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3345 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3346 else if (CONSP (fun))
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 Lisp_Object funcar = XCAR (fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3349
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3350 if (EQ (funcar, Qautoload))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3351 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3352 do_autoload (fun, original_fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3353 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3354 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3355 else if (EQ (funcar, Qmacro))
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 val = Feval (apply1 (XCDR (fun), original_args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3358 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3359 else if (EQ (funcar, Qlambda))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3360 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3361 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3362 Lisp_Object *args = alloca_array (Lisp_Object, nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3363 REGISTER Lisp_Object *p = args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3364
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3365 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3366 gcpro1.nvars = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3367
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3368 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3369 LIST_LOOP_2 (arg, original_args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3370 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3371 *p++ = Feval (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3372 gcpro1.nvars++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3373 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3376 UNGCPRO;
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 backtrace.args = args; /* this also GCPROs `args' */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3379 backtrace.nargs = nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3380 backtrace.evalargs = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3381
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3382 val = funcall_lambda (fun, nargs, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3383
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3384 /* Do the debug-on-exit now, while args is still GCPROed. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3385 if (backtrace.debug_on_exit)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3386 val = do_debug_on_exit (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3387 /* Don't do it again when we return to eval. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3388 backtrace.debug_on_exit = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3389 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3390 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3391 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3392 goto invalid_function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3393 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3394 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3395 else /* ! (SUBRP (fun) || COMPILED_FUNCTIONP (fun) || CONSP (fun)) */
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 invalid_function:
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
3398 val = signal_invalid_function_error (fun);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3399 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3400
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3401 lisp_eval_depth--;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3402 if (backtrace.debug_on_exit)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3403 val = do_debug_on_exit (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3404 POP_BACKTRACE (backtrace);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3405 return val;
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
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 DEFUN ("funcall", Ffuncall, 1, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3410 Call first argument as a function, passing the remaining arguments to it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3411 Thus, (funcall 'cons 'x 'y) returns (x . y).
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 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3414 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3415 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3416 Lisp_Object fun;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3417 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3418 struct backtrace backtrace;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3419 int fun_nargs = nargs - 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3420 Lisp_Object *fun_args = args + 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3421
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3422 QUIT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3423 if ((consing_since_gc > gc_cons_threshold) || always_gc)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3424 /* Callers should gcpro lexpr args */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3425 garbage_collect_1 ();
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 if (++lisp_eval_depth > max_lisp_eval_depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3428 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3429 if (max_lisp_eval_depth < 100)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3430 max_lisp_eval_depth = 100;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3431 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
3432 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
3433 Qunbound);
428
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 backtrace.pdlcount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3437 backtrace.function = &args[0];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3438 backtrace.args = fun_args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3439 backtrace.nargs = fun_nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3440 backtrace.evalargs = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3441 backtrace.debug_on_exit = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3442 PUSH_BACKTRACE (backtrace);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3443
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3444 if (debug_on_next_call)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3445 do_debug_on_call (Qlambda);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3446
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3447 retry:
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 fun = args[0];
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 /* It might be useful to place this *after* all the checks. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3452 if (profiling_active)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3453 profile_increase_call_count (fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3454
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3455 /* We could call indirect_function directly, but profiling shows
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3456 this is worth optimizing by partially unrolling the loop. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3457 if (SYMBOLP (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 fun = XSYMBOL (fun)->function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3460 if (SYMBOLP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3461 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3462 fun = XSYMBOL (fun)->function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3463 if (SYMBOLP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3464 fun = indirect_function (fun, 1);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3468 if (SUBRP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3469 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3470 Lisp_Subr *subr = XSUBR (fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3471 int max_args = subr->max_args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3472 Lisp_Object spacious_args[SUBR_MAX_ARGS];
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 if (fun_nargs == max_args) /* Optimize for the common case */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3475 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3476 funcall_subr:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3477 FUNCALL_SUBR (val, subr, fun_args, max_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3478 }
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
3479 else if (fun_nargs < subr->min_args)
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
3480 {
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
3481 goto wrong_number_of_arguments;
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
3482 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3483 else if (fun_nargs < max_args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3484 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3485 Lisp_Object *p = spacious_args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3486
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3487 /* Default optionals to nil */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3488 while (fun_nargs--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3489 *p++ = *fun_args++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3490 while (p - spacious_args < max_args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3491 *p++ = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3492
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3493 fun_args = spacious_args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3494 goto funcall_subr;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3495 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3496 else if (max_args == MANY)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3497 {
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
3498 val = SUBR_FUNCTION (subr, MANY) (fun_nargs, fun_args);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3499 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3500 else if (max_args == UNEVALLED) /* Can't funcall a special form */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3501 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3502 goto invalid_function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3503 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3504 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3505 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3506 wrong_number_of_arguments:
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
3507 val = signal_wrong_number_of_arguments_error (fun, fun_nargs);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3508 }
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 else if (COMPILED_FUNCTIONP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3511 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3512 val = funcall_compiled_function (fun, fun_nargs, fun_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3513 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3514 else if (CONSP (fun))
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 Lisp_Object funcar = XCAR (fun);
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 if (EQ (funcar, Qlambda))
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 val = funcall_lambda (fun, fun_nargs, fun_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3521 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3522 else if (EQ (funcar, Qautoload))
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 do_autoload (fun, args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3525 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3526 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3527 else /* Can't funcall a macro */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3528 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3529 goto invalid_function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3530 }
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 if (UNBOUNDP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3533 {
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
3534 val = signal_void_function_error (args[0]);
428
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 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3537 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3538 invalid_function:
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
3539 val = signal_invalid_function_error (fun);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3540 }
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 lisp_eval_depth--;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3543 if (backtrace.debug_on_exit)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3544 val = do_debug_on_exit (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3545 POP_BACKTRACE (backtrace);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3546 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3547 }
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 DEFUN ("functionp", Ffunctionp, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3550 Return t if OBJECT can be called as a function, else nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3551 A function is an object that can be applied to arguments,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3552 using for example `funcall' or `apply'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3553 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3554 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3555 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3556 if (SYMBOLP (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3557 object = indirect_function (object, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3558
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3559 return
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3560 (SUBRP (object) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3561 COMPILED_FUNCTIONP (object) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3562 (CONSP (object) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3563 (EQ (XCAR (object), Qlambda) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3564 EQ (XCAR (object), Qautoload))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3565 ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3566 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3567
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3568 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3569 function_argcount (Lisp_Object function, int function_min_args_p)
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 Lisp_Object orig_function = function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3572 Lisp_Object arglist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3573
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3574 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3575
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3576 if (SYMBOLP (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3577 function = indirect_function (function, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3578
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3579 if (SUBRP (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3580 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3581 /* Using return with the ?: operator tickles a DEC CC compiler bug. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3582 if (function_min_args_p)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3583 return Fsubr_min_args (function);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3584 else
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3585 return Fsubr_max_args (function);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3586 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3587 else if (COMPILED_FUNCTIONP (function))
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 arglist = compiled_function_arglist (XCOMPILED_FUNCTION (function));
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 else if (CONSP (function))
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 Lisp_Object funcar = XCAR (function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3594
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3595 if (EQ (funcar, Qmacro))
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 function = XCDR (function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3598 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3599 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3600 else if (EQ (funcar, Qautoload))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3601 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3602 struct gcpro gcpro1;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3603
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3604 GCPRO1 (function);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3605 do_autoload (function, orig_function);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3606 UNGCPRO;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3607 function = orig_function;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3608 goto retry;
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 else if (EQ (funcar, Qlambda))
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 arglist = Fcar (XCDR (function));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3613 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3614 else
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 goto invalid_function;
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3619 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3620 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3621 invalid_function:
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3622 return signal_invalid_function_error (orig_function);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3623 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3624
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3625 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3626 int argcount = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3627
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3628 EXTERNAL_LIST_LOOP_2 (arg, arglist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3629 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3630 if (EQ (arg, Qand_optional))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3631 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3632 if (function_min_args_p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3633 break;
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 else if (EQ (arg, Qand_rest))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3636 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3637 if (function_min_args_p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3638 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3639 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3640 return Qnil;
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
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 argcount++;
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 }
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 return make_int (argcount);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3649 }
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 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
3653 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
3654 The function may be any form that can be passed to `funcall',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3655 any special form, or any macro.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3656 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3657 (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3658 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3659 return function_argcount (function, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3660 }
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 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
3663 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
3664 The function may be any form that can be passed to `funcall',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3665 any special form, or any macro.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3666 If the function takes an arbitrary number of arguments or is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3667 a built-in special form, nil is returned.
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 (function))
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 return function_argcount (function, 0);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3675 DEFUN ("apply", Fapply, 2, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3676 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
3677 Thus, (apply '+ 1 2 '(3 4)) returns 10.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3678 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3679 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3680 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3681 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3682 Lisp_Object fun = args[0];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3683 Lisp_Object spread_arg = args [nargs - 1];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3684 int numargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3685 int funcall_nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3686
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3687 GET_EXTERNAL_LIST_LENGTH (spread_arg, numargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3688
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3689 if (numargs == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3690 /* (apply foo 0 1 '()) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3691 return Ffuncall (nargs - 1, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3692 else if (numargs == 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3693 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3694 /* (apply foo 0 1 '(2)) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3695 args [nargs - 1] = XCAR (spread_arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3696 return Ffuncall (nargs, args);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3699 /* -1 for function, -1 for spread arg */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3700 numargs = nargs - 2 + numargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3701 /* +1 for function */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3702 funcall_nargs = 1 + numargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3703
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3704 if (SYMBOLP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3705 fun = indirect_function (fun, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3706
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3707 if (SUBRP (fun))
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 Lisp_Subr *subr = XSUBR (fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3710 int max_args = subr->max_args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3711
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3712 if (numargs < subr->min_args
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3713 || (max_args >= 0 && max_args < numargs))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3714 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3715 /* Let funcall get the error */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3716 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3717 else if (max_args > numargs)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3718 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3719 /* Avoid having funcall cons up yet another new vector of arguments
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3720 by explicitly supplying nil's for optional values */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3721 funcall_nargs += (max_args - numargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3722 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3723 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3724 else if (UNBOUNDP (fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3725 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3726 /* Let funcall get the error */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3727 fun = args[0];
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3730 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3731 REGISTER int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3732 Lisp_Object *funcall_args = alloca_array (Lisp_Object, funcall_nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3733 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3734
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3735 GCPRO1 (*funcall_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3736 gcpro1.nvars = funcall_nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3737
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3738 /* Copy in the unspread args */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3739 memcpy (funcall_args, args, (nargs - 1) * sizeof (Lisp_Object));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3740 /* Spread the last arg we got. Its first element goes in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3741 the slot that it used to occupy, hence this value of I. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3742 for (i = nargs - 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3743 !NILP (spread_arg); /* i < 1 + numargs */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3744 i++, spread_arg = XCDR (spread_arg))
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 funcall_args [i] = XCAR (spread_arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3747 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3748 /* Supply nil for optional args (to subrs) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3749 for (; i < funcall_nargs; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3750 funcall_args[i] = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3751
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3752
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3753 RETURN_UNGCPRO (Ffuncall (funcall_nargs, funcall_args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3754 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3755 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3756
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3757
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3758 /* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3759 return the result of evaluation. */
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 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3762 funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object args[])
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3763 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3764 /* This function can GC */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3765 Lisp_Object arglist, body, tail;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3766 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3767 REGISTER int i = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3768
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3769 tail = XCDR (fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3770
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3771 if (!CONSP (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3772 goto invalid_function;
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 arglist = XCAR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3775 body = XCDR (tail);
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 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3778 int optional = 0, rest = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3779
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3780 EXTERNAL_LIST_LOOP_2 (symbol, arglist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3781 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3782 if (!SYMBOLP (symbol))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3783 goto invalid_function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3784 if (EQ (symbol, Qand_rest))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3785 rest = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3786 else if (EQ (symbol, Qand_optional))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3787 optional = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3788 else if (rest)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3789 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3790 specbind (symbol, Flist (nargs - i, &args[i]));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3791 i = nargs;
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 else if (i < nargs)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3794 specbind (symbol, args[i++]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3795 else if (!optional)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3796 goto wrong_number_of_arguments;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3797 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3798 specbind (symbol, Qnil);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3802 if (i < nargs)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3803 goto wrong_number_of_arguments;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3804
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3805 return unbind_to (speccount, Fprogn (body));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3806
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3807 wrong_number_of_arguments:
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
3808 return signal_wrong_number_of_arguments_error (fun, nargs);
428
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 invalid_function:
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
3811 return signal_invalid_function_error (fun);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3812 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3813
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3814
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3815 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3816 /* Run hook variables in various ways. */
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3819 DEFUN ("run-hooks", Frun_hooks, 1, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3820 Run each hook in HOOKS. Major mode functions use this.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3821 Each argument should be a symbol, a hook variable.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3822 These symbols are processed in the order specified.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3823 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
3824 or a list of functions to be called to run the hook.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3825 If the value is a function, it is called with no arguments.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3826 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
3827
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3828 To make a hook variable buffer-local, use `make-local-hook',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3829 not `make-local-variable'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3830 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3831 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3832 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3833 REGISTER int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3834
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3835 for (i = 0; i < nargs; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3836 run_hook_with_args (1, args + i, RUN_HOOKS_TO_COMPLETION);
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 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3839 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3840
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3841 DEFUN ("run-hook-with-args", Frun_hook_with_args, 1, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3842 Run HOOK with the specified arguments ARGS.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3843 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
3844 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
3845 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
3846 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
3847 of functions, those functions are called, in order,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3848 with the given arguments ARGS.
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3849 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
3850 as that may change.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3851
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3852 To make a hook variable buffer-local, use `make-local-hook',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3853 not `make-local-variable'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3854 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3855 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3856 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3857 return run_hook_with_args (nargs, args, RUN_HOOKS_TO_COMPLETION);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3858 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3859
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3860 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
3861 Run HOOK with the specified arguments ARGS.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3862 HOOK should be a symbol, a hook variable. Its value should
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3863 be a list of functions. We call those functions, one by one,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3864 passing arguments ARGS to each of them, until one of them
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3865 returns a non-nil value. Then we return that value.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3866 If all the functions return nil, we return nil.
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 To make a hook variable buffer-local, use `make-local-hook',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3869 not `make-local-variable'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3870 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3871 (int nargs, Lisp_Object *args))
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 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_SUCCESS);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3876 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
3877 Run HOOK with the specified arguments ARGS.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3878 HOOK should be a symbol, a hook variable. Its value should
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3879 be a list of functions. We call those functions, one by one,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3880 passing arguments ARGS to each of them, until one of them
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3881 returns nil. Then we return nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3882 If all the functions return non-nil, we return non-nil.
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 To make a hook variable buffer-local, use `make-local-hook',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3885 not `make-local-variable'.
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 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3888 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3889 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_FAILURE);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3890 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3891
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3892 /* ARGS[0] should be a hook symbol.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3893 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
3894 as arguments all the rest of ARGS (all NARGS - 1 elements).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3895 COND specifies a condition to test after each call
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3896 to decide whether to stop.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3897 The caller (or its caller, etc) must gcpro all of ARGS,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3898 except that it isn't necessary to gcpro ARGS[0]. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3899
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3900 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3901 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
3902 enum run_hooks_condition cond)
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 Lisp_Object sym, val, ret;
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 if (!initialized || preparing_for_armageddon)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3907 /* We need to bail out of here pronto. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3908 return Qnil;
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 /* Whenever gc_in_progress is true, preparing_for_armageddon
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3911 will also be true unless something is really hosed. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3912 assert (!gc_in_progress);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3913
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3914 sym = args[0];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3915 val = symbol_value_in_buffer (sym, make_buffer (buf));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3916 ret = (cond == RUN_HOOKS_UNTIL_FAILURE ? Qt : Qnil);
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 if (UNBOUNDP (val) || NILP (val))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3919 return ret;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3920 else if (!CONSP (val) || EQ (XCAR (val), Qlambda))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3921 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3922 args[0] = val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3923 return Ffuncall (nargs, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3924 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3925 else
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 struct gcpro gcpro1, gcpro2, gcpro3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3928 Lisp_Object globals = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3929 GCPRO3 (sym, val, globals);
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 for (;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3932 CONSP (val) && ((cond == RUN_HOOKS_TO_COMPLETION)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3933 || (cond == RUN_HOOKS_UNTIL_SUCCESS ? NILP (ret)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3934 : !NILP (ret)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3935 val = XCDR (val))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3936 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3937 if (EQ (XCAR (val), Qt))
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 /* t indicates this hook has a local binding;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3940 it means to run the global binding too. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3941 globals = Fdefault_value (sym);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3942
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3943 if ((! CONSP (globals) || EQ (XCAR (globals), Qlambda)) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3944 ! NILP (globals))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3945 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3946 args[0] = globals;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3947 ret = Ffuncall (nargs, args);
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 else
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 for (;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3952 CONSP (globals) && ((cond == RUN_HOOKS_TO_COMPLETION)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3953 || (cond == RUN_HOOKS_UNTIL_SUCCESS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3954 ? NILP (ret)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3955 : !NILP (ret)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3956 globals = XCDR (globals))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3957 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3958 args[0] = XCAR (globals);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3959 /* In a global value, t should not occur. If it does, we
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3960 must ignore it to avoid an endless loop. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3961 if (!EQ (args[0], Qt))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3962 ret = Ffuncall (nargs, args);
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3966 else
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 args[0] = XCAR (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3969 ret = Ffuncall (nargs, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3970 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3971 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3972
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3973 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3974 return ret;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3975 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3978 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3979 run_hook_with_args (int nargs, Lisp_Object *args,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3980 enum run_hooks_condition cond)
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 return run_hook_with_args_in_buffer (current_buffer, nargs, args, cond);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3985 #if 0
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 /* From FSF 19.30, not currently used */
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 /* 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
3990 present value of that symbol.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3991 Call each element of FUNLIST,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3992 passing each of them the rest of ARGS.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3993 The caller (or its caller, etc) must gcpro all of ARGS,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3994 except that it isn't necessary to gcpro ARGS[0]. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3995
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3996 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3997 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
3998 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3999 Lisp_Object sym = args[0];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4000 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4001 struct gcpro gcpro1, gcpro2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4002
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4003 GCPRO2 (sym, val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4004
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4005 for (val = funlist; CONSP (val); val = XCDR (val))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4006 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4007 if (EQ (XCAR (val), Qt))
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 /* t indicates this hook has a local binding;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4010 it means to run the global binding too. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4011 Lisp_Object globals;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4012
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4013 for (globals = Fdefault_value (sym);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4014 CONSP (globals);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4015 globals = XCDR (globals))
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 args[0] = XCAR (globals);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4018 /* In a global value, t should not occur. If it does, we
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4019 must ignore it to avoid an endless loop. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4020 if (!EQ (args[0], Qt))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4021 Ffuncall (nargs, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4022 }
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 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4025 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4026 args[0] = XCAR (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4027 Ffuncall (nargs, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4028 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4029 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4030 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4031 return Qnil;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4034 #endif /* 0 */
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 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4037 va_run_hook_with_args (Lisp_Object hook_var, int nargs, ...)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4038 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4039 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4040 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4041 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4042 va_list vargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4043 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4044
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4045 va_start (vargs, nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4046 funcall_args[0] = hook_var;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4047 for (i = 0; i < nargs; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4048 funcall_args[i + 1] = va_arg (vargs, Lisp_Object);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4049 va_end (vargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4050
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4051 GCPRO1 (*funcall_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4052 gcpro1.nvars = nargs + 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4053 run_hook_with_args (nargs + 1, funcall_args, RUN_HOOKS_TO_COMPLETION);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4054 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4055 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4056
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4057 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4058 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
4059 int nargs, ...)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4060 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4061 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4062 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4063 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4064 va_list vargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4065 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs);
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 va_start (vargs, nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4068 funcall_args[0] = hook_var;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4069 for (i = 0; i < nargs; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4070 funcall_args[i + 1] = va_arg (vargs, Lisp_Object);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4071 va_end (vargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4072
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4073 GCPRO1 (*funcall_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4074 gcpro1.nvars = nargs + 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4075 run_hook_with_args_in_buffer (buf, nargs + 1, funcall_args,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4076 RUN_HOOKS_TO_COMPLETION);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4077 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4078 }
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 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4081 run_hook (Lisp_Object hook)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4082 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4083 Frun_hooks (1, &hook);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4084 return Qnil;
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
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 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4089 /* Front-ends to eval, funcall, apply */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4090 /************************************************************************/
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 /* Apply fn to arg */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4093 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4094 apply1 (Lisp_Object fn, Lisp_Object arg)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4095 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4096 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4097 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4098 Lisp_Object args[2];
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 if (NILP (arg))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4101 return Ffuncall (1, &fn);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4102 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4103 gcpro1.nvars = 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4104 args[0] = fn;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4105 args[1] = arg;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4106 RETURN_UNGCPRO (Fapply (2, args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4107 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4108
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4109 /* Call function fn on no arguments */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4110 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4111 call0 (Lisp_Object fn)
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 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4114 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4115
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4116 GCPRO1 (fn);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4117 RETURN_UNGCPRO (Ffuncall (1, &fn));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4118 }
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 /* Call function fn with argument arg0 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4121 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4122 call1 (Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4123 Lisp_Object arg0)
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 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4126 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4127 Lisp_Object args[2];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4128 args[0] = fn;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4129 args[1] = arg0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4130 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4131 gcpro1.nvars = 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4132 RETURN_UNGCPRO (Ffuncall (2, args));
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4135 /* Call function fn with arguments arg0, arg1 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4136 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4137 call2 (Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4138 Lisp_Object arg0, Lisp_Object arg1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4139 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4140 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4141 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4142 Lisp_Object args[3];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4143 args[0] = fn;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4144 args[1] = arg0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4145 args[2] = arg1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4146 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4147 gcpro1.nvars = 3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4148 RETURN_UNGCPRO (Ffuncall (3, args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4149 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4150
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4151 /* Call function fn with arguments arg0, arg1, arg2 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4152 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4153 call3 (Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4154 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2)
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 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4157 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4158 Lisp_Object args[4];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4159 args[0] = fn;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4160 args[1] = arg0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4161 args[2] = arg1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4162 args[3] = arg2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4163 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4164 gcpro1.nvars = 4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4165 RETURN_UNGCPRO (Ffuncall (4, args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4166 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4167
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4168 /* Call function fn with arguments arg0, arg1, arg2, arg3 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4169 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4170 call4 (Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4171 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4172 Lisp_Object arg3)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4173 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4174 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4175 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4176 Lisp_Object args[5];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4177 args[0] = fn;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4178 args[1] = arg0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4179 args[2] = arg1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4180 args[3] = arg2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4181 args[4] = arg3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4182 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4183 gcpro1.nvars = 5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4184 RETURN_UNGCPRO (Ffuncall (5, args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4185 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4186
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4187 /* Call function fn with arguments arg0, arg1, arg2, arg3, arg4 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4188 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4189 call5 (Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4190 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4191 Lisp_Object arg3, Lisp_Object arg4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4192 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4193 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4194 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4195 Lisp_Object args[6];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4196 args[0] = fn;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4197 args[1] = arg0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4198 args[2] = arg1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4199 args[3] = arg2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4200 args[4] = arg3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4201 args[5] = arg4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4202 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4203 gcpro1.nvars = 6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4204 RETURN_UNGCPRO (Ffuncall (6, args));
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4207 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4208 call6 (Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4209 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4210 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4211 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4212 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4213 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4214 Lisp_Object args[7];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4215 args[0] = fn;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4216 args[1] = arg0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4217 args[2] = arg1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4218 args[3] = arg2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4219 args[4] = arg3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4220 args[5] = arg4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4221 args[6] = arg5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4222 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4223 gcpro1.nvars = 7;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4224 RETURN_UNGCPRO (Ffuncall (7, args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4225 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4226
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4227 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4228 call7 (Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4229 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4230 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4231 Lisp_Object arg6)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4232 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4233 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4234 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4235 Lisp_Object args[8];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4236 args[0] = fn;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4237 args[1] = arg0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4238 args[2] = arg1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4239 args[3] = arg2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4240 args[4] = arg3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4241 args[5] = arg4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4242 args[6] = arg5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4243 args[7] = arg6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4244 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4245 gcpro1.nvars = 8;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4246 RETURN_UNGCPRO (Ffuncall (8, args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4247 }
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 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4250 call8 (Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4251 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4252 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4253 Lisp_Object arg6, Lisp_Object arg7)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4254 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4255 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4256 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4257 Lisp_Object args[9];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4258 args[0] = fn;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4259 args[1] = arg0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4260 args[2] = arg1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4261 args[3] = arg2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4262 args[4] = arg3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4263 args[5] = arg4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4264 args[6] = arg5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4265 args[7] = arg6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4266 args[8] = arg7;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4267 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4268 gcpro1.nvars = 9;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4269 RETURN_UNGCPRO (Ffuncall (9, args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4270 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4271
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4272 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4273 call0_in_buffer (struct buffer *buf, Lisp_Object fn)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4274 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4275 if (current_buffer == buf)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4276 return call0 (fn);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4277 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4278 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4279 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4280 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4281 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4282 set_buffer_internal (buf);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4283 val = call0 (fn);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4284 unbind_to (speccount, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4285 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4286 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4287 }
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 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4290 call1_in_buffer (struct buffer *buf, Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4291 Lisp_Object arg0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4292 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4293 if (current_buffer == buf)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4294 return call1 (fn, arg0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4295 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4296 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4297 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4298 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4299 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4300 set_buffer_internal (buf);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4301 val = call1 (fn, arg0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4302 unbind_to (speccount, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4303 return val;
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4306
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4307 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4308 call2_in_buffer (struct buffer *buf, Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4309 Lisp_Object arg0, Lisp_Object arg1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4310 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4311 if (current_buffer == buf)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4312 return call2 (fn, arg0, arg1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4313 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4314 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4315 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4316 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4317 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4318 set_buffer_internal (buf);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4319 val = call2 (fn, arg0, arg1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4320 unbind_to (speccount, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4321 return val;
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4324
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4325 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4326 call3_in_buffer (struct buffer *buf, Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4327 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4328 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4329 if (current_buffer == buf)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4330 return call3 (fn, arg0, arg1, arg2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4331 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4332 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4333 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4334 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4335 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4336 set_buffer_internal (buf);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4337 val = call3 (fn, arg0, arg1, arg2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4338 unbind_to (speccount, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4339 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4340 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4343 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4344 call4_in_buffer (struct buffer *buf, Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4345 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4346 Lisp_Object arg3)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4347 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4348 if (current_buffer == buf)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4349 return call4 (fn, arg0, arg1, arg2, arg3);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4350 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4351 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4352 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4353 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4354 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4355 set_buffer_internal (buf);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4356 val = call4 (fn, arg0, arg1, arg2, arg3);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4357 unbind_to (speccount, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4358 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4359 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4362 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4363 eval_in_buffer (struct buffer *buf, Lisp_Object form)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4364 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4365 if (current_buffer == buf)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4366 return Feval (form);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4367 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4368 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4369 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4370 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4371 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4372 set_buffer_internal (buf);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4373 val = Feval (form);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4374 unbind_to (speccount, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4375 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4376 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4377 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4378
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4379
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4380 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4381 /* Error-catching front-ends to eval, funcall, apply */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4382 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4383
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4384 /* Call function fn on no arguments, with condition handler */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4385 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4386 call0_with_handler (Lisp_Object handler, Lisp_Object fn)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4387 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4388 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4389 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4390 Lisp_Object args[2];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4391 args[0] = handler;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4392 args[1] = fn;
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 = 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4395 RETURN_UNGCPRO (Fcall_with_condition_handler (2, 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 /* Call function fn with argument arg0, with condition handler */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4399 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4400 call1_with_handler (Lisp_Object handler, Lisp_Object fn,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4401 Lisp_Object arg0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4402 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4403 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4404 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4405 Lisp_Object args[3];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4406 args[0] = handler;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4407 args[1] = fn;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4408 args[2] = arg0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4409 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4410 gcpro1.nvars = 3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4411 RETURN_UNGCPRO (Fcall_with_condition_handler (3, args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4412 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4413
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4414
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4415 /* The following functions provide you with error-trapping versions
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4416 of the various front-ends above. They take an additional
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4417 "warning_string" argument; if non-zero, a warning with this
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4418 string and the actual error that occurred will be displayed
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4419 in the *Warnings* buffer if an error occurs. In all cases,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4420 QUIT is inhibited while these functions are running, and if
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4421 an error occurs, Qunbound is returned instead of the normal
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4422 return value.
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4425 /* #### This stuff needs to catch throws as well. We need to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4426 improve internal_catch() so it can take a "catch anything"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4427 argument similar to Qt or Qerror for condition_case_1(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4429 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4430 caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4431 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4432 if (!NILP (errordata))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4433 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4434 Lisp_Object args[2];
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 if (!NILP (arg))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4437 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4438 CIntbyte *str = (CIntbyte *) get_opaque_ptr (arg);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4439 args[0] = build_string (str);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4440 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4441 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4442 args[0] = build_string ("error");
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4443 /* #### This should call
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4444 (with-output-to-string (display-error errordata))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4445 but that stuff is all in Lisp currently. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4446 args[1] = errordata;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4447 warn_when_safe_lispobj
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4448 (Qerror, Qwarning,
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4449 emacs_doprnt_string_lisp ((const Intbyte *) "%s: %s",
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4450 Qnil, -1, 2, args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4451 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4452 return Qunbound;
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 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4456 allow_quit_caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4457 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4458 if (CONSP (errordata) && EQ (XCAR (errordata), Qquit))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4459 return Fsignal (Qquit, XCDR (errordata));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4460 return caught_a_squirmer (errordata, arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4461 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4462
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4463 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4464 safe_run_hook_caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4465 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4466 Lisp_Object hook = Fcar (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4467 arg = Fcdr (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4468 /* Clear out the hook. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4469 Fset (hook, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4470 return caught_a_squirmer (errordata, arg);
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 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4474 allow_quit_safe_run_hook_caught_a_squirmer (Lisp_Object errordata,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4475 Lisp_Object arg)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4476 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4477 Lisp_Object hook = Fcar (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4478 arg = Fcdr (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4479 if (!CONSP (errordata) || !EQ (XCAR (errordata), Qquit))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4480 /* Clear out the hook. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4481 Fset (hook, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4482 return allow_quit_caught_a_squirmer (errordata, arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4483 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4484
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4485 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4486 catch_them_squirmers_eval_in_buffer (Lisp_Object cons)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4487 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4488 return eval_in_buffer (XBUFFER (XCAR (cons)), XCDR (cons));
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 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4492 eval_in_buffer_trapping_errors (const CIntbyte *warning_string,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4493 struct buffer *buf, Lisp_Object form)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4494 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4495 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4496 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4497 Lisp_Object buffer;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4498 Lisp_Object cons;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4499 Lisp_Object opaque;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4500 struct gcpro gcpro1, gcpro2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4501
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4502 XSETBUFFER (buffer, buf);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4503
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4504 specbind (Qinhibit_quit, Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4505 /* gc_currently_forbidden = 1; Currently no reason to do this; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4506
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4507 cons = noseeum_cons (buffer, form);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4508 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4509 GCPRO2 (cons, opaque);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4510 /* Qerror not Qt, so you can get a backtrace */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4511 tem = condition_case_1 (Qerror,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4512 catch_them_squirmers_eval_in_buffer, cons,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4513 caught_a_squirmer, opaque);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4514 free_cons (XCONS (cons));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4515 if (OPAQUE_PTRP (opaque))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4516 free_opaque_ptr (opaque);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4517 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4518
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4519 /* gc_currently_forbidden = 0; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4520 return unbind_to (speccount, tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4521 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4522
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4523 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4524 catch_them_squirmers_run_hook (Lisp_Object hook_symbol)
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 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4527 run_hook (hook_symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4528 return Qnil;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4531 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4532 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
4533 Lisp_Object hook_symbol)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4534 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4535 int speccount;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4536 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4537 Lisp_Object opaque;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4540 if (!initialized || preparing_for_armageddon)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4541 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4542 tem = find_symbol_value (hook_symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4543 if (NILP (tem) || UNBOUNDP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4544 return Qnil;
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 speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4547 specbind (Qinhibit_quit, Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4548
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4549 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4550 GCPRO1 (opaque);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4551 /* Qerror not Qt, so you can get a backtrace */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4552 tem = condition_case_1 (Qerror,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4553 catch_them_squirmers_run_hook, hook_symbol,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4554 caught_a_squirmer, opaque);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4555 if (OPAQUE_PTRP (opaque))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4556 free_opaque_ptr (opaque);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4557 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4558
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4559 return unbind_to (speccount, tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4560 }
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 /* 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
4563 if an error occurs. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4564
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4565 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4566 safe_run_hook_trapping_errors (const CIntbyte *warning_string,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4567 Lisp_Object hook_symbol,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4568 int allow_quit)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4569 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4570 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4571 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4572 Lisp_Object cons = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4573 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4574
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4575 if (!initialized || preparing_for_armageddon)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4576 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4577 tem = find_symbol_value (hook_symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4578 if (NILP (tem) || UNBOUNDP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4579 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4580
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4581 if (!allow_quit)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4582 specbind (Qinhibit_quit, Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4583
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4584 cons = noseeum_cons (hook_symbol,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4585 warning_string ? make_opaque_ptr ((void *)warning_string)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4586 : Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4587 GCPRO1 (cons);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4588 /* Qerror not Qt, so you can get a backtrace */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4589 tem = condition_case_1 (Qerror,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4590 catch_them_squirmers_run_hook,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4591 hook_symbol,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4592 allow_quit ?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4593 allow_quit_safe_run_hook_caught_a_squirmer :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4594 safe_run_hook_caught_a_squirmer,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4595 cons);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4596 if (OPAQUE_PTRP (XCDR (cons)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4597 free_opaque_ptr (XCDR (cons));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4598 free_cons (XCONS (cons));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4599 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4600
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4601 return unbind_to (speccount, tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4602 }
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 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4605 catch_them_squirmers_call0 (Lisp_Object function)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4606 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4607 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4608 return call0 (function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4609 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4610
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4611 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4612 call0_trapping_errors (const CIntbyte *warning_string, Lisp_Object function)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4613 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4614 int speccount;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4615 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4616 Lisp_Object opaque = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4617 struct gcpro gcpro1, gcpro2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4618
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4619 if (SYMBOLP (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4620 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4621 tem = XSYMBOL (function)->function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4622 if (NILP (tem) || UNBOUNDP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4623 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4624 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4625
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4626 GCPRO2 (opaque, function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4627 speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4628 specbind (Qinhibit_quit, Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4629 /* gc_currently_forbidden = 1; Currently no reason to do this; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4630
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4631 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4632 /* Qerror not Qt, so you can get a backtrace */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4633 tem = condition_case_1 (Qerror,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4634 catch_them_squirmers_call0, function,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4635 caught_a_squirmer, opaque);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4636 if (OPAQUE_PTRP (opaque))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4637 free_opaque_ptr (opaque);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4638 UNGCPRO;
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 /* gc_currently_forbidden = 0; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4641 return unbind_to (speccount, tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4642 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4643
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4644 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4645 catch_them_squirmers_call1 (Lisp_Object cons)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4646 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4647 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4648 return call1 (XCAR (cons), XCDR (cons));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4649 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4650
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4651 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4652 catch_them_squirmers_call2 (Lisp_Object cons)
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 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4655 return call2 (XCAR (cons), XCAR (XCDR (cons)), XCAR (XCDR (XCDR (cons))));
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4658 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4659 call1_trapping_errors (const CIntbyte *warning_string, Lisp_Object function,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4660 Lisp_Object object)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4661 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4662 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4663 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4664 Lisp_Object cons = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4665 Lisp_Object opaque = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4666 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4667
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4668 if (SYMBOLP (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4669 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4670 tem = XSYMBOL (function)->function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4671 if (NILP (tem) || UNBOUNDP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4672 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4673 }
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 GCPRO4 (cons, opaque, function, object);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4676
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4677 specbind (Qinhibit_quit, Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4678 /* gc_currently_forbidden = 1; Currently no reason to do this; */
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 cons = noseeum_cons (function, object);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4681 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4682 /* Qerror not Qt, so you can get a backtrace */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4683 tem = condition_case_1 (Qerror,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4684 catch_them_squirmers_call1, cons,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4685 caught_a_squirmer, opaque);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4686 if (OPAQUE_PTRP (opaque))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4687 free_opaque_ptr (opaque);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4688 free_cons (XCONS (cons));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4689 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4690
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4691 /* gc_currently_forbidden = 0; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4692 return unbind_to (speccount, tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4693 }
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 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4696 call2_trapping_errors (const CIntbyte *warning_string, Lisp_Object function,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4697 Lisp_Object object1, Lisp_Object object2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4698 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4699 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4700 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4701 Lisp_Object cons = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4702 Lisp_Object opaque = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4703 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4704
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4705 if (SYMBOLP (function))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4706 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4707 tem = XSYMBOL (function)->function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4708 if (NILP (tem) || UNBOUNDP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4709 return Qnil;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4712 GCPRO5 (cons, opaque, function, object1, object2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4713 specbind (Qinhibit_quit, Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4714 /* gc_currently_forbidden = 1; Currently no reason to do this; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4715
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4716 cons = list3 (function, object1, object2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4717 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4718 /* Qerror not Qt, so you can get a backtrace */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4719 tem = condition_case_1 (Qerror,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4720 catch_them_squirmers_call2, cons,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4721 caught_a_squirmer, opaque);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4722 if (OPAQUE_PTRP (opaque))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4723 free_opaque_ptr (opaque);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4724 free_list (cons);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4725 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4726
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4727 /* gc_currently_forbidden = 0; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4728 return unbind_to (speccount, tem);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4731
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 /* The special binding stack */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4734 /* Most C code should simply use specbind() and unbind_to(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4735 /* When performance is critical, use the macros in backtrace.h. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4736 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4737
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4738 #define min_max_specpdl_size 400
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4739
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4740 void
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
4741 grow_specpdl (EMACS_INT reserved)
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
4742 {
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
4743 EMACS_INT size_needed = specpdl_depth() + reserved;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4744 if (size_needed >= max_specpdl_size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4745 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4746 if (max_specpdl_size < min_max_specpdl_size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4747 max_specpdl_size = min_max_specpdl_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4748 if (size_needed >= max_specpdl_size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4749 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4750 if (!NILP (Vdebug_on_error) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4751 !NILP (Vdebug_on_signal))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4752 /* Leave room for some specpdl in the debugger. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4753 max_specpdl_size = size_needed + 100;
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
4754 signal_continuable_error
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
4755 (Qstack_overflow,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
4756 "Variable binding depth exceeds max-specpdl-size", Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4757 }
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 while (specpdl_size < size_needed)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4760 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4761 specpdl_size *= 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4762 if (specpdl_size > max_specpdl_size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4763 specpdl_size = max_specpdl_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4764 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4765 XREALLOC_ARRAY (specpdl, struct specbinding, specpdl_size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4766 specpdl_ptr = specpdl + specpdl_depth();
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
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 /* Handle unbinding buffer-local variables */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4771 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4772 specbind_unwind_local (Lisp_Object ovalue)
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 Lisp_Object current = Fcurrent_buffer ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4775 Lisp_Object symbol = specpdl_ptr->symbol;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
4776 Lisp_Cons *victim = XCONS (ovalue);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4777 Lisp_Object buf = get_buffer (victim->car, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4778 ovalue = victim->cdr;
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 free_cons (victim);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4781
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4782 if (NILP (buf))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4783 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4784 /* Deleted buffer -- do nothing */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4785 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4786 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buf)) == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4787 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4788 /* Was buffer-local when binding was made, now no longer is.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4789 * (kill-local-variable can do this.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4790 * Do nothing in this case.
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4793 else if (EQ (buf, current))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4794 Fset (symbol, ovalue);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4795 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4796 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4797 /* Urk! Somebody switched buffers */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4798 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4799 GCPRO1 (current);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4800 Fset_buffer (buf);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4801 Fset (symbol, ovalue);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4802 Fset_buffer (current);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4803 UNGCPRO;
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 return symbol;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4806 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4807
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4808 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4809 specbind_unwind_wasnt_local (Lisp_Object buffer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4810 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4811 Lisp_Object current = Fcurrent_buffer ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4812 Lisp_Object symbol = specpdl_ptr->symbol;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4813
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4814 buffer = get_buffer (buffer, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4815 if (NILP (buffer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4816 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4817 /* Deleted buffer -- do nothing */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4818 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4819 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buffer)) == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4820 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4821 /* Was buffer-local when binding was made, now no longer is.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4822 * (kill-local-variable can do this.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4823 * Do nothing in this case.
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4826 else if (EQ (buffer, current))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4827 Fkill_local_variable (symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4828 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4829 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4830 /* Urk! Somebody switched buffers */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4831 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4832 GCPRO1 (current);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4833 Fset_buffer (buffer);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4834 Fkill_local_variable (symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4835 Fset_buffer (current);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4836 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4837 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4838 return symbol;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4839 }
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 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4843 specbind (Lisp_Object symbol, Lisp_Object value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4844 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4845 SPECBIND (symbol, value);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4846 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4847
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4848 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4849 specbind_magic (Lisp_Object symbol, Lisp_Object value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4850 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4851 int buffer_local =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4852 symbol_value_buffer_local_info (symbol, current_buffer);
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 if (buffer_local == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4855 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4856 specpdl_ptr->old_value = find_symbol_value (symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4857 specpdl_ptr->func = 0; /* Handled specially by unbind_to */
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 else if (buffer_local > 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4860 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4861 /* Already buffer-local */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4862 specpdl_ptr->old_value = noseeum_cons (Fcurrent_buffer (),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4863 find_symbol_value (symbol));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4864 specpdl_ptr->func = specbind_unwind_local;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4865 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4866 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4867 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4868 /* About to become buffer-local */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4869 specpdl_ptr->old_value = Fcurrent_buffer ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4870 specpdl_ptr->func = specbind_unwind_wasnt_local;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4871 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4872
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4873 specpdl_ptr->symbol = symbol;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4874 specpdl_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4875 specpdl_depth_counter++;
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 Fset (symbol, value);
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
546
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 458
diff changeset
4880 /* Note: As long as the unwind-protect exists, its arg is automatically
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 458
diff changeset
4881 GCPRO'd. */
666d73d6ac56 [xemacs-hg @ 2001-05-20 01:17:07 by ben]
ben
parents: 458
diff changeset
4882
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4883 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4884 record_unwind_protect (Lisp_Object (*function) (Lisp_Object arg),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4885 Lisp_Object arg)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4886 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4887 SPECPDL_RESERVE (1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4888 specpdl_ptr->func = function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4889 specpdl_ptr->symbol = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4890 specpdl_ptr->old_value = arg;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4891 specpdl_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4892 specpdl_depth_counter++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4893 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4894
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4895 extern int check_sigio (void);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4896
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4897 /* Unwind the stack till specpdl_depth() == COUNT.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4898 VALUE is not used, except that, purely as a convenience to the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4899 caller, it is protected from garbage-protection. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4900 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4901 unbind_to (int count, Lisp_Object value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4902 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4903 UNBIND_TO_GCPRO (count, value);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4904 return value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4905 }
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 /* Don't call this directly.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4908 Only for use by UNBIND_TO* macros in backtrace.h */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4909 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4910 unbind_to_hairy (int count)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4911 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4912 int quitf;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4913
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4914 ++specpdl_ptr;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4915 ++specpdl_depth_counter;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4916
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4917 check_quit (); /* make Vquit_flag accurate */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4918 quitf = !NILP (Vquit_flag);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4919 Vquit_flag = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4920
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4921 while (specpdl_depth_counter != count)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4922 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4923 --specpdl_ptr;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4924 --specpdl_depth_counter;
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 if (specpdl_ptr->func != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4927 /* An unwind-protect */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4928 (*specpdl_ptr->func) (specpdl_ptr->old_value);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4929 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4930 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4931 /* We checked symbol for validity when we specbound it,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4932 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
4933 Lisp_Symbol *sym = XSYMBOL (specpdl_ptr->symbol);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4934 if (!SYMBOL_VALUE_MAGIC_P (sym->value))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4935 sym->value = specpdl_ptr->old_value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4936 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4937 Fset (specpdl_ptr->symbol, specpdl_ptr->old_value);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4940 #if 0 /* martin */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4941 #ifndef EXCEEDINGLY_QUESTIONABLE_CODE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4942 /* There should never be anything here for us to remove.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4943 If so, it indicates a logic error in Emacs. Catches
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4944 should get removed when a throw or signal occurs, or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4945 when a catch or condition-case exits normally. But
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4946 it's too dangerous to just remove this code. --ben */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4947
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4948 /* Furthermore, this code is not in FSFmacs!!!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4949 Braino on mly's part? */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4950 /* If we're unwound past the pdlcount of a catch frame,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4951 that catch can't possibly still be valid. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4952 while (catchlist && catchlist->pdlcount > specpdl_depth_counter)
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 catchlist = catchlist->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4955 /* Don't mess with gcprolist, backtrace_list here */
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 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4958 #endif
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 if (quitf)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4961 Vquit_flag = Qt;
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
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4966 /* 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
4967 not now dynamically visible. May return Qunbound or magic values. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4968
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4969 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4970 top_level_value (Lisp_Object symbol)
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 REGISTER struct specbinding *ptr = specpdl;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4973
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4974 CHECK_SYMBOL (symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4975 for (; ptr != specpdl_ptr; ptr++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4976 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4977 if (EQ (ptr->symbol, symbol))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4978 return ptr->old_value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4979 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4980 return XSYMBOL (symbol)->value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4981 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4982
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4983 #if 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4984
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4985 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4986 top_level_set (Lisp_Object symbol, Lisp_Object newval)
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 REGISTER struct specbinding *ptr = specpdl;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4989
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4990 CHECK_SYMBOL (symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4991 for (; ptr != specpdl_ptr; ptr++)
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 if (EQ (ptr->symbol, symbol))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4994 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4995 ptr->old_value = newval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4996 return newval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4997 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4998 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4999 return Fset (symbol, newval);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5000 }
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 #endif /* 0 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5003
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 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5006 /* Backtraces */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5007 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5008
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5009 DEFUN ("backtrace-debug", Fbacktrace_debug, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5010 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
5011 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
5012 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5013 (level, flag))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5014 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5015 REGISTER struct backtrace *backlist = backtrace_list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5016 REGISTER int i;
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 CHECK_INT (level);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5019
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5020 for (i = 0; backlist && i < XINT (level); i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5021 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5022 backlist = backlist->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5023 }
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 if (backlist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5026 backlist->debug_on_exit = !NILP (flag);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5027
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5028 return flag;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5029 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5030
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5031 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5032 backtrace_specials (int speccount, int speclimit, Lisp_Object stream)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5033 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5034 int printing_bindings = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5035
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5036 for (; speccount > speclimit; speccount--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5037 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5038 if (specpdl[speccount - 1].func == 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5039 || specpdl[speccount - 1].func == specbind_unwind_local
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5040 || specpdl[speccount - 1].func == specbind_unwind_wasnt_local)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5041 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5042 write_c_string (((!printing_bindings) ? " # bind (" : " "),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5043 stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5044 Fprin1 (specpdl[speccount - 1].symbol, stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5045 printing_bindings = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5046 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5047 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5048 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5049 if (printing_bindings) write_c_string (")\n", stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5050 write_c_string (" # (unwind-protect ...)\n", stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5051 printing_bindings = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5052 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5053 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5054 if (printing_bindings) write_c_string (")\n", stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5055 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5056
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5057 DEFUN ("backtrace", Fbacktrace, 0, 2, "", /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5058 Print a trace of Lisp function calls currently active.
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 436
diff changeset
5059 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
5060 and defaults to the value of `standard-output'.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
5061 Optional second arg DETAILED non-nil means show places where currently
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
5062 active variable bindings, catches, condition-cases, and
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
5063 unwind-protects, as well as function calls, were made.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5064 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5065 (stream, detailed))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5066 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5067 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5068 struct backtrace *backlist = backtrace_list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5069 struct catchtag *catches = catchlist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5070 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5071
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5072 int old_nl = print_escape_newlines;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5073 int old_pr = print_readably;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5074 Lisp_Object old_level = Vprint_level;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5075 Lisp_Object oiq = Vinhibit_quit;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5076 struct gcpro gcpro1, gcpro2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5077
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5078 /* 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
5079 of print_readably and print_escape_newlines to get screwed up.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5080 Normally we would use a record_unwind_protect but that would
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5081 screw up the functioning of this function. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5082 Vinhibit_quit = Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5083
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5084 entering_debugger = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5085
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5086 Vprint_level = make_int (3);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5087 print_readably = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5088 print_escape_newlines = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5089
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5090 GCPRO2 (stream, old_level);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5091
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5092 if (NILP (stream))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5093 stream = Vstandard_output;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5094 if (!noninteractive && (NILP (stream) || EQ (stream, Qt)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5095 stream = Fselected_frame (Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5096
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5097 for (;;)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5098 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5099 if (!NILP (detailed) && catches && catches->backlist == backlist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5100 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5101 int catchpdl = catches->pdlcount;
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 436
diff changeset
5102 if (speccount > catchpdl
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 436
diff changeset
5103 && specpdl[catchpdl].func == condition_case_unwind)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5104 /* This is a condition-case catchpoint */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5105 catchpdl = catchpdl + 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5106
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5107 backtrace_specials (speccount, catchpdl, stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5108
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5109 speccount = catches->pdlcount;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5110 if (catchpdl == speccount)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5111 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5112 write_c_string (" # (catch ", stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5113 Fprin1 (catches->tag, stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5114 write_c_string (" ...)\n", stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5115 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5116 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5117 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5118 write_c_string (" # (condition-case ... . ", stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5119 Fprin1 (Fcdr (Fcar (catches->tag)), stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5120 write_c_string (")\n", stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5121 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5122 catches = catches->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5123 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5124 else if (!backlist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5125 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5126 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5127 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5128 if (!NILP (detailed) && backlist->pdlcount < speccount)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5129 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5130 backtrace_specials (speccount, backlist->pdlcount, stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5131 speccount = backlist->pdlcount;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5132 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5133 write_c_string (((backlist->debug_on_exit) ? "* " : " "),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5134 stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5135 if (backlist->nargs == UNEVALLED)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5136 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5137 Fprin1 (Fcons (*backlist->function, *backlist->args), stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5138 write_c_string ("\n", stream); /* from FSFmacs 19.30 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5139 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5140 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5141 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5142 Lisp_Object tem = *backlist->function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5143 Fprin1 (tem, stream); /* This can QUIT */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5144 write_c_string ("(", stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5145 if (backlist->nargs == MANY)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5146 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5147 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5148 Lisp_Object tail = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5149 struct gcpro ngcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5150
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5151 NGCPRO1 (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5152 for (tail = *backlist->args, i = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5153 !NILP (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5154 tail = Fcdr (tail), i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5155 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5156 if (i != 0) write_c_string (" ", stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5157 Fprin1 (Fcar (tail), stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5158 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5159 NUNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5160 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5161 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5162 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5163 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5164 for (i = 0; i < backlist->nargs; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5165 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5166 if (!i && EQ(tem, Qbyte_code)) {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5167 write_c_string("\"...\"", stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5168 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5169 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5170 if (i != 0) write_c_string (" ", stream);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5171 Fprin1 (backlist->args[i], stream);
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 }
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5174 write_c_string (")\n", stream);
428
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 backlist = backlist->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5177 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5178 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5179 Vprint_level = old_level;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5180 print_readably = old_pr;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5181 print_escape_newlines = old_nl;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5182 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5183 Vinhibit_quit = oiq;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5184 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5185 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5186
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5187
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
5188 DEFUN ("backtrace-frame", Fbacktrace_frame, 1, 1, 0, /*
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
5189 Return the function and arguments NFRAMES up from current execution point.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5190 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
5191 the value is (nil FUNCTION ARG-FORMS...).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5192 If that frame has evaluated its arguments and called its function already,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5193 the value is (t FUNCTION ARG-VALUES...).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5194 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
5195 FUNCTION is whatever was supplied as car of evaluated list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5196 or a lambda expression for macro calls.
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
5197 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
5198 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5199 (nframes))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5200 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5201 REGISTER struct backtrace *backlist = backtrace_list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5202 REGISTER int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5203 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5204
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5205 CHECK_NATNUM (nframes);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5206
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5207 /* Find the frame requested. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5208 for (i = XINT (nframes); backlist && (i-- > 0);)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5209 backlist = backlist->next;
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 if (!backlist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5212 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5213 if (backlist->nargs == UNEVALLED)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5214 return Fcons (Qnil, Fcons (*backlist->function, *backlist->args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5215 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5216 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5217 if (backlist->nargs == MANY)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5218 tem = *backlist->args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5219 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5220 tem = Flist (backlist->nargs, backlist->args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5221
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5222 return Fcons (Qt, Fcons (*backlist->function, tem));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5223 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5224 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5227 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5228 /* Warnings */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5229 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5230
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5231 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5232 warn_when_safe_lispobj (Lisp_Object class, Lisp_Object level,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5233 Lisp_Object obj)
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 obj = list1 (list3 (class, level, obj));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5236 if (NILP (Vpending_warnings))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5237 Vpending_warnings = Vpending_warnings_tail = obj;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5238 else
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 Fsetcdr (Vpending_warnings_tail, obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5241 Vpending_warnings_tail = obj;
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 }
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 /* #### This should probably accept Lisp objects; but then we have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5246 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
5247
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5248 An alternative approach is to just pass some non-string type of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5249 Lisp_Object to warn_when_safe_lispobj(); `prin1-to-string' will
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5250 automatically be called when it is safe to do so. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5251
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5252 void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
5253 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
5254 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5255 Lisp_Object obj;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5256 va_list args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5257
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5258 va_start (args, fmt);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
5259 obj = emacs_doprnt_string_va ((const Intbyte *) GETTEXT (fmt),
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5260 Qnil, -1, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5261 va_end (args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5262
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5263 warn_when_safe_lispobj (class, level, obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5264 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5267
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 /* Initialization */
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 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5274 syms_of_eval (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5275 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5276 INIT_LRECORD_IMPLEMENTATION (subr);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5277
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5278 DEFSYMBOL (Qinhibit_quit);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5279 DEFSYMBOL (Qautoload);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5280 DEFSYMBOL (Qdebug_on_error);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5281 DEFSYMBOL (Qstack_trace_on_error);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5282 DEFSYMBOL (Qdebug_on_signal);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5283 DEFSYMBOL (Qstack_trace_on_signal);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5284 DEFSYMBOL (Qdebugger);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5285 DEFSYMBOL (Qmacro);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5286 defsymbol (&Qand_rest, "&rest");
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5287 defsymbol (&Qand_optional, "&optional");
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5288 /* 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
5289 DEFSYMBOL (Qexit);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5290 DEFSYMBOL (Qsetq);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5291 DEFSYMBOL (Qinteractive);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5292 DEFSYMBOL (Qcommandp);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5293 DEFSYMBOL (Qdefun);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5294 DEFSYMBOL (Qprogn);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5295 DEFSYMBOL (Qvalues);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5296 DEFSYMBOL (Qdisplay_warning);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5297 DEFSYMBOL (Qrun_hooks);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 546
diff changeset
5298 DEFSYMBOL (Qif);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5299
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5300 DEFSUBR (For);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5301 DEFSUBR (Fand);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5302 DEFSUBR (Fif);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5303 DEFSUBR_MACRO (Fwhen);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5304 DEFSUBR_MACRO (Funless);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5305 DEFSUBR (Fcond);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5306 DEFSUBR (Fprogn);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5307 DEFSUBR (Fprog1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5308 DEFSUBR (Fprog2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5309 DEFSUBR (Fsetq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5310 DEFSUBR (Fquote);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5311 DEFSUBR (Ffunction);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5312 DEFSUBR (Fdefun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5313 DEFSUBR (Fdefmacro);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5314 DEFSUBR (Fdefvar);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5315 DEFSUBR (Fdefconst);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5316 DEFSUBR (Fuser_variable_p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5317 DEFSUBR (Flet);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5318 DEFSUBR (FletX);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5319 DEFSUBR (Fwhile);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5320 DEFSUBR (Fmacroexpand_internal);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5321 DEFSUBR (Fcatch);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5322 DEFSUBR (Fthrow);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5323 DEFSUBR (Funwind_protect);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5324 DEFSUBR (Fcondition_case);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5325 DEFSUBR (Fcall_with_condition_handler);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5326 DEFSUBR (Fsignal);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5327 DEFSUBR (Finteractive_p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5328 DEFSUBR (Fcommandp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5329 DEFSUBR (Fcommand_execute);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5330 DEFSUBR (Fautoload);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5331 DEFSUBR (Feval);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5332 DEFSUBR (Fapply);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5333 DEFSUBR (Ffuncall);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5334 DEFSUBR (Ffunctionp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5335 DEFSUBR (Ffunction_min_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5336 DEFSUBR (Ffunction_max_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5337 DEFSUBR (Frun_hooks);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5338 DEFSUBR (Frun_hook_with_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5339 DEFSUBR (Frun_hook_with_args_until_success);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5340 DEFSUBR (Frun_hook_with_args_until_failure);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5341 DEFSUBR (Fbacktrace_debug);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5342 DEFSUBR (Fbacktrace);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5343 DEFSUBR (Fbacktrace_frame);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5344 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5345
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5346 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5347 reinit_eval (void)
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 specpdl_ptr = specpdl;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5350 specpdl_depth_counter = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5351 catchlist = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5352 Vcondition_handlers = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5353 backtrace_list = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5354 Vquit_flag = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5355 debug_on_next_call = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5356 lisp_eval_depth = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5357 entering_debugger = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5358 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5359
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5360 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5361 reinit_vars_of_eval (void)
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 preparing_for_armageddon = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5364 in_warnings = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5365 Qunbound_suspended_errors_tag = make_opaque_ptr (&Qunbound_suspended_errors_tag);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5366 staticpro_nodump (&Qunbound_suspended_errors_tag);
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 specpdl_size = 50;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5369 specpdl = xnew_array (struct specbinding, specpdl_size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5370 /* XEmacs change: increase these values. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5371 max_specpdl_size = 3000;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5372 max_lisp_eval_depth = 1000;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5373 #ifdef DEFEND_AGAINST_THROW_RECURSION
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5374 throw_level = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5375 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5376 }
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 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5379 vars_of_eval (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5380 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5381 reinit_vars_of_eval ();
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 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5384 Limit on number of Lisp variable bindings & unwind-protects before error.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5385 */ );
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 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5388 Limit on depth in `eval', `apply' and `funcall' before error.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5389 This limit is to catch infinite recursions for you before they cause
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5390 actual stack overflow in C, which would be fatal for Emacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5391 You can safely make it considerably larger than its default value,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5392 if that proves inconveniently small.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5393 */ );
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 DEFVAR_LISP ("quit-flag", &Vquit_flag /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5396 Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5397 Typing C-G sets `quit-flag' non-nil, regardless of `inhibit-quit'.
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 Vquit_flag = Qnil;
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 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5402 Non-nil inhibits C-g quitting from happening immediately.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5403 Note that `quit-flag' will still be set by typing C-g,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5404 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
5405 To prevent this happening, set `quit-flag' to nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5406 before making `inhibit-quit' nil. The value of `inhibit-quit' is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5407 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
5408 an X frame.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5409 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5410 Vinhibit_quit = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5411
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5412 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5413 *Non-nil means automatically display a backtrace buffer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5414 after any error that is not handled by a `condition-case'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5415 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
5416 if one of its condition symbols appears in the list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5417 See also variable `stack-trace-on-signal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5418 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5419 Vstack_trace_on_error = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5420
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5421 DEFVAR_LISP ("stack-trace-on-signal", &Vstack_trace_on_signal /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5422 *Non-nil means automatically display a backtrace buffer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5423 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
5424 a `condition-case'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5425 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
5426 if one of its condition symbols appears in the list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5427 See also variable `stack-trace-on-error'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5428 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5429 Vstack_trace_on_signal = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5430
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5431 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5432 *List of errors for which the debugger should not be called.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5433 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
5434 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
5435 and just returns to top level.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5436 This overrides the variable `debug-on-error'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5437 It does not apply to errors handled by `condition-case'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5438 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5439 Vdebug_ignored_errors = Qnil;
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 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5442 *Non-nil means enter debugger if an unhandled error is signalled.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5443 The debugger will not be entered if the error is handled by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5444 a `condition-case'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5445 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
5446 if one of its condition symbols appears in the list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5447 This variable is overridden by `debug-ignored-errors'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5448 See also variables `debug-on-quit' and `debug-on-signal'.
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 Vdebug_on_error = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5451
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5452 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5453 *Non-nil means enter debugger if an error is signalled.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5454 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
5455 a `condition-case'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5456 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
5457 if one of its condition symbols appears in the list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5458 See also variable `debug-on-quit'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5459 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5460 Vdebug_on_signal = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5461
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5462 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5463 *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
5464 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
5465 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
5466 control-shift-G to signal a critical quit.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5467 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5468 debug_on_quit = 0;
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 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5471 Non-nil means enter debugger before next `eval', `apply' or `funcall'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5472 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5473
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5474 DEFVAR_LISP ("debugger", &Vdebugger /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5475 Function to call to invoke debugger.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5476 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
5477 this function's value will be returned instead of that.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5478 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
5479 If due to `apply' or `funcall' entry, one arg, `lambda'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5480 If due to `eval' entry, one arg, t.
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 Vdebugger = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5483
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5484 staticpro (&Vpending_warnings);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5485 Vpending_warnings = Qnil;
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 444
diff changeset
5486 dump_add_root_object (&Vpending_warnings_tail);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5487 Vpending_warnings_tail = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5488
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5489 staticpro (&Vautoload_queue);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5490 Vautoload_queue = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5491
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5492 staticpro (&Vcondition_handlers);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5493
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5494 staticpro (&Vcurrent_warning_class);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5495 Vcurrent_warning_class = Qnil;
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 staticpro (&Vcurrent_error_state);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5498 Vcurrent_error_state = Qnil; /* errors as normal */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5499
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5500 reinit_eval ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5501 }