Mercurial > hg > xemacs-beta
annotate src/eval.c @ 5887:6eca500211f4
Prototype for X509_check_host() has changed, detect this in configure.ac
ChangeLog addition:
2015-04-09 Aidan Kehoe <kehoea@parhasard.net>
* configure.ac:
If X509_check_host() is available, check the number of arguments
it takes. Don't use it if it takes any number of arguments other
than five. Also don't use it if <openssl/x509v3.h> does not
declare it, since if that is so there is no portable way to tell
how many arguments it should take, and so we would end up smashing
the stack.
* configure: Regenerate.
src/ChangeLog addition:
2015-04-09 Aidan Kehoe <kehoea@parhasard.net>
* tls.c:
#include <openssl/x509v3.h> for its prototype for
X509_check_host().
* tls.c (tls_open):
Pass the new fifth argument to X509_check_host().
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Thu, 09 Apr 2015 14:27:02 +0100 |
| parents | 3192994c49ca |
| children |
| rev | line source |
|---|---|
| 428 | 1 /* Evaluator for XEmacs Lisp interpreter. |
| 2 Copyright (C) 1985-1987, 1992-1994 Free Software Foundation, Inc. | |
| 3 Copyright (C) 1995 Sun Microsystems, Inc. | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
4 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2010 Ben Wing. |
| 428 | 5 |
| 6 This file is part of XEmacs. | |
| 7 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5265
diff
changeset
|
8 XEmacs is free software: you can redistribute it and/or modify it |
| 428 | 9 under the terms of the GNU General Public License as published by the |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5265
diff
changeset
|
10 Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5265
diff
changeset
|
11 option) any later version. |
| 428 | 12 |
| 13 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 16 for more details. | |
| 17 | |
| 18 You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5265
diff
changeset
|
19 along with XEmacs. If not, see <http://www.gnu.org/licenses/>. */ |
| 428 | 20 |
| 21 /* Synched up with: FSF 19.30 (except for Fsignal), Mule 2.0. */ | |
| 22 | |
| 853 | 23 /* Authorship: |
| 24 | |
| 25 Based on code from pre-release FSF 19, c. 1991. | |
| 26 Some work by Richard Mlynarik long ago (c. 1993?) -- | |
| 27 added call-with-condition-handler; synch. up to released FSF 19.7 | |
| 28 for lemacs 19.8. some signal changes. | |
| 29 Various work by Ben Wing, 1995-1996: | |
| 30 added all stuff dealing with trapping errors, suspended-errors, etc. | |
| 31 added most Fsignal front ends. | |
| 32 added warning code. | |
| 33 reworked the Fsignal code and synched the rest up to FSF 19.30. | |
| 34 Some changes by Martin Buchholz c. 1999? | |
| 35 e.g. PRIMITIVE_FUNCALL macros. | |
| 36 New call_trapping_problems code and large comments below | |
| 37 by Ben Wing, Mar-Apr 2000. | |
| 38 */ | |
| 39 | |
| 40 /* This file has been Mule-ized. */ | |
| 41 | |
| 42 /* What is in this file? | |
| 43 | |
| 44 This file contains the engine for the ELisp interpreter in XEmacs. | |
| 45 The engine does the actual work of implementing function calls, | |
| 46 form evaluation, non-local exits (catch, throw, signal, | |
| 47 condition-case, call-with-condition-handler), unwind-protects, | |
| 48 dynamic bindings, let constructs, backtraces, etc. You might say | |
| 49 that this module is the very heart of XEmacs, and everything else | |
| 50 in XEmacs is merely an auxiliary module implementing some specific | |
| 51 functionality that may be called from the heart at an appropriate | |
| 52 time. | |
| 53 | |
| 54 The only exception is the alloc.c module, which implements the | |
| 55 framework upon which this module (eval.c) works. alloc.c works | |
| 56 with creating the actual Lisp objects themselves and garbage | |
| 1960 | 57 collecting them as necessary, presenting a nice, high-level |
| 853 | 58 interface for object creation, deletion, access, and modification. |
| 59 | |
| 60 The only other exception that could be cited is the event-handling | |
| 61 module in event-stream.c. From its perspective, it is also the | |
| 62 heart of XEmacs, and controls exactly what gets done at what time. | |
| 63 From its perspective, eval.c is merely one of the auxiliary modules | |
| 64 out there that can be invoked by event-stream.c. | |
| 65 | |
| 66 Although the event-stream-centric view is a convenient fiction that | |
| 67 makes sense particularly from the user's perspective and from the | |
| 68 perspective of time, the engine-centric view is actually closest to | |
| 69 the truth, because anywhere within the event-stream module, you are | |
| 70 still somewhere in a Lisp backtrace, and event-loops are begun by | |
| 71 functions such as `command-loop-1', a Lisp function. | |
| 72 | |
| 73 As the Lisp engine is doing its thing, it maintains the state of | |
| 1960 | 74 the engine primarily in five list-like items, which are: |
| 853 | 75 |
| 76 -- the backtrace list | |
| 77 -- the catchtag list | |
| 78 -- the condition-handler list | |
| 79 -- the specbind list | |
| 80 -- the GCPRO list. | |
| 81 | |
| 82 These are described in detail in the next comment. | |
| 83 | |
| 84 --ben | |
| 85 */ | |
| 86 | |
| 87 /* Note that there are five separate lists used to maintain state in | |
| 88 the evaluator. All of them conceptually are stacks (last-in, | |
| 89 first-out). All non-local exits happen ultimately through the | |
| 90 catch/throw mechanism, which uses one of the five lists (the | |
| 91 catchtag list) and records the current state of the others in each | |
| 92 frame of the list (some other information is recorded and restored | |
| 93 as well, such as the current eval depth), so that all the state of | |
| 94 the evaluator is restored properly when a non-local exit occurs. | |
| 95 (Note that the current state of the condition-handler list is not | |
| 96 recorded in the catchtag list. Instead, when a condition-case or | |
| 97 call-with-condition-handler is set up, it installs an | |
| 98 unwind-protect on the specbind list to restore the appropriate | |
| 99 setting for the condition-handler list. During the course of | |
| 100 handling the non-local exit, all entries on the specbind list that | |
| 101 are past the location stored in the catch frame are "unwound" | |
| 102 (i.e. variable bindings are restored and unwind-protects are | |
| 103 executed), so the condition-handler list gets reset properly. | |
| 104 | |
| 105 The five lists are | |
| 106 | |
| 107 1. The backtrace list, which is chained through `struct backtrace's | |
| 108 declared in the stack frames of various primitives, and keeps | |
| 109 track of all Lisp function call entries and exits. | |
| 110 2. The catchtag list, which is chained through `struct catchtag's | |
| 111 declared in the stack frames of internal_catch and condition_case_1, | |
| 112 and keeps track of information needed to reset the internal state | |
| 113 of the evaluator to the state that was current when the catch or | |
| 114 condition-case were established, in the event of a non-local exit. | |
| 115 3. The condition-handler list, which is a simple Lisp list with new | |
| 116 entries consed onto the front of the list. It records condition-cases | |
| 117 and call-with-condition-handlers established either from C or from | |
| 118 Lisp. Unlike with the other lists (but similar to everything else | |
| 119 of a similar nature in the rest of the C and Lisp code), it takes care | |
| 120 of restoring itself appropriately in the event of a non-local exit | |
| 121 through the use of the unwind-protect mechanism. | |
| 122 4. The specbind list, which is a contiguous array of `struct specbinding's, | |
| 123 expanded as necessary using realloc(). It holds dynamic variable | |
| 124 bindings (the only kind we currently have in ELisp) and unwind-protects. | |
| 125 5. The GCPRO list, which is chained through `struct gcpro's declared in | |
| 126 the stack frames of any functions that need to GC-protect Lisp_Objects | |
| 127 declared on the stack. This is one of the most fragile areas of the | |
| 128 entire scheme -- you must not forget to UNGCPRO at the end of your | |
| 129 function, you must make sure you GCPRO in many circumstances you don't | |
| 130 think you have to, etc. See the internals manual for more information | |
| 131 about this. | |
| 132 | |
| 133 --ben | |
| 134 */ | |
| 135 | |
| 428 | 136 #include <config.h> |
| 137 #include "lisp.h" | |
| 138 | |
| 139 #include "commands.h" | |
| 140 #include "backtrace.h" | |
| 141 #include "bytecode.h" | |
| 142 #include "buffer.h" | |
| 872 | 143 #include "console-impl.h" |
| 853 | 144 #include "device.h" |
| 145 #include "frame.h" | |
| 146 #include "lstream.h" | |
| 428 | 147 #include "opaque.h" |
| 1292 | 148 #include "profile.h" |
| 853 | 149 #include "window.h" |
| 428 | 150 |
| 151 struct backtrace *backtrace_list; | |
| 152 | |
| 153 /* Macros for calling subrs with an argument list whose length is only | |
| 154 known at runtime. See EXFUN and DEFUN for similar hackery. */ | |
| 155 | |
| 156 #define AV_0(av) | |
| 157 #define AV_1(av) av[0] | |
| 158 #define AV_2(av) AV_1(av), av[1] | |
| 159 #define AV_3(av) AV_2(av), av[2] | |
| 160 #define AV_4(av) AV_3(av), av[3] | |
| 161 #define AV_5(av) AV_4(av), av[4] | |
| 162 #define AV_6(av) AV_5(av), av[5] | |
| 163 #define AV_7(av) AV_6(av), av[6] | |
| 164 #define AV_8(av) AV_7(av), av[7] | |
| 165 | |
| 166 #define PRIMITIVE_FUNCALL_1(fn, av, ac) \ | |
| 444 | 167 (((Lisp_Object (*)(EXFUN_##ac)) (fn)) (AV_##ac (av))) |
| 428 | 168 |
| 169 /* If subrs take more than 8 arguments, more cases need to be added | |
| 170 to this switch. (But wait - don't do it - if you really need | |
| 171 a SUBR with more than 8 arguments, use max_args == MANY. | |
| 853 | 172 Or better, considering using a property list as one of your args. |
| 428 | 173 See the DEFUN macro in lisp.h) */ |
| 174 #define PRIMITIVE_FUNCALL(rv, fn, av, ac) do { \ | |
| 175 void (*PF_fn)(void) = (void (*)(void)) fn; \ | |
| 176 Lisp_Object *PF_av = (av); \ | |
| 177 switch (ac) \ | |
| 178 { \ | |
| 436 | 179 default:rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 0); break; \ |
| 428 | 180 case 1: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 1); break; \ |
| 181 case 2: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 2); break; \ | |
| 182 case 3: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 3); break; \ | |
| 183 case 4: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 4); break; \ | |
| 184 case 5: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 5); break; \ | |
| 185 case 6: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 6); break; \ | |
| 186 case 7: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 7); break; \ | |
| 187 case 8: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 8); break; \ | |
| 188 } \ | |
| 189 } while (0) | |
| 190 | |
| 191 #define FUNCALL_SUBR(rv, subr, av, ac) \ | |
| 192 PRIMITIVE_FUNCALL (rv, subr_function (subr), av, ac); | |
| 193 | |
| 194 | |
| 195 /* This is the list of current catches (and also condition-cases). | |
| 853 | 196 This is a stack: the most recent catch is at the head of the list. |
| 197 The list is threaded through the stack frames of the C functions | |
| 198 that set up the catches; this is similar to the way the GCPRO list | |
| 199 is handled, but different from the condition-handler list (which is | |
| 200 a simple Lisp list) and the specbind stack, which is a contiguous | |
| 201 array of `struct specbinding's, grown (using realloc()) as | |
| 202 necessary. (Note that all four of these lists behave as a stacks.) | |
| 203 | |
| 3025 | 204 Catches are created by declaring a `struct catchtag' locally, |
| 853 | 205 filling the .TAG field in with the tag, and doing a setjmp() on |
| 206 .JMP. Fthrow() will store the value passed to it in .VAL and | |
| 207 longjmp() back to .JMP, back to the function that established the | |
| 208 catch. This will always be either internal_catch() (catches | |
| 209 established internally or through `catch') or condition_case_1 | |
| 210 (condition-cases established internally or through | |
| 211 `condition-case'). | |
| 428 | 212 |
| 213 The catchtag also records the current position in the | |
| 214 call stack (stored in BACKTRACE_LIST), the current position | |
| 215 in the specpdl stack (used for variable bindings and | |
| 216 unwind-protects), the value of LISP_EVAL_DEPTH, and the | |
| 217 current position in the GCPRO stack. All of these are | |
| 218 restored by Fthrow(). | |
| 853 | 219 */ |
| 428 | 220 |
| 221 struct catchtag *catchlist; | |
| 222 | |
| 853 | 223 /* A special tag that can be used internally from C code to catch |
| 224 every attempt to throw past this level. */ | |
| 225 Lisp_Object Vcatch_everything_tag; | |
| 226 | |
|
5506
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
227 Lisp_Object Qautoload, Qmacro, Qexit, Qdeclare; |
| 428 | 228 Lisp_Object Qinteractive, Qcommandp, Qdefun, Qprogn, Qvalues; |
| 229 Lisp_Object Vquit_flag, Vinhibit_quit; | |
| 230 Lisp_Object Qand_rest, Qand_optional; | |
| 231 Lisp_Object Qdebug_on_error, Qstack_trace_on_error; | |
| 232 Lisp_Object Qdebug_on_signal, Qstack_trace_on_signal; | |
|
5615
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
233 Lisp_Object Qdebugger, Qbyte_compile_macro_environment; |
| 428 | 234 Lisp_Object Qinhibit_quit; |
| 887 | 235 Lisp_Object Qfinalize_list; |
| 428 | 236 Lisp_Object Qrun_hooks; |
| 237 Lisp_Object Qsetq; | |
| 238 Lisp_Object Qdisplay_warning; | |
| 239 Lisp_Object Vpending_warnings, Vpending_warnings_tail; | |
| 240 Lisp_Object Qif; | |
| 241 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
242 Lisp_Object Qthrow; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
243 Lisp_Object Qobsolete_throw; |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
244 Lisp_Object Qmultiple_value_list_internal; |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
245 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
246 static int first_desired_multiple_value; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
247 /* Used outside this file, somewhat uncleanly, in the IGNORE_MULTIPLE_VALUES |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
248 macro: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
249 int multiple_value_current_limit; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
250 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
251 Fixnum Vmultiple_values_limit; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
252 |
| 853 | 253 /* Flags specifying which operations are currently inhibited. */ |
| 254 int inhibit_flags; | |
| 255 | |
| 256 /* Buffers, frames, windows, devices, and consoles created since most | |
| 257 recent active | |
| 258 call_trapping_problems (INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION). | |
| 259 */ | |
| 260 Lisp_Object Vdeletable_permanent_display_objects; | |
| 261 | |
| 262 /* Buffers created since most recent active | |
| 263 call_trapping_problems (INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION). */ | |
| 264 Lisp_Object Vmodifiable_buffers; | |
| 793 | 265 |
| 266 /* Minimum level at which warnings are logged. Below this, they're ignored | |
| 267 entirely -- not even generated. */ | |
| 268 Lisp_Object Vlog_warning_minimum_level; | |
| 269 | |
| 428 | 270 /* Non-nil means record all fset's and provide's, to be undone |
| 271 if the file being autoloaded is not fully loaded. | |
| 272 They are recorded by being consed onto the front of Vautoload_queue: | |
| 273 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */ | |
| 274 Lisp_Object Vautoload_queue; | |
| 275 | |
|
5615
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
276 Lisp_Object Vmacro_declaration_function, Vbyte_compile_macro_environment; |
|
5506
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
277 |
| 428 | 278 /* Current number of specbindings allocated in specpdl. */ |
| 279 int specpdl_size; | |
| 280 | |
| 281 /* Pointer to beginning of specpdl. */ | |
| 282 struct specbinding *specpdl; | |
| 283 | |
| 284 /* Pointer to first unused element in specpdl. */ | |
| 285 struct specbinding *specpdl_ptr; | |
| 286 | |
| 287 /* specpdl_ptr - specpdl */ | |
| 288 int specpdl_depth_counter; | |
| 289 | |
| 290 /* Maximum size allowed for specpdl allocation */ | |
| 458 | 291 Fixnum max_specpdl_size; |
| 428 | 292 |
| 293 /* Depth in Lisp evaluations and function calls. */ | |
| 1292 | 294 int lisp_eval_depth; |
| 428 | 295 |
| 296 /* Maximum allowed depth in Lisp evaluations and function calls. */ | |
| 458 | 297 Fixnum max_lisp_eval_depth; |
| 428 | 298 |
| 299 /* Nonzero means enter debugger before next function call */ | |
| 300 static int debug_on_next_call; | |
| 301 | |
| 1292 | 302 int backtrace_with_internal_sections; |
| 303 | |
| 428 | 304 /* List of conditions (non-nil atom means all) which cause a backtrace |
| 305 if an error is handled by the command loop's error handler. */ | |
| 306 Lisp_Object Vstack_trace_on_error; | |
| 307 | |
| 308 /* List of conditions (non-nil atom means all) which enter the debugger | |
| 309 if an error is handled by the command loop's error handler. */ | |
| 310 Lisp_Object Vdebug_on_error; | |
| 311 | |
| 312 /* List of conditions and regexps specifying error messages which | |
| 313 do not enter the debugger even if Vdebug_on_error says they should. */ | |
| 314 Lisp_Object Vdebug_ignored_errors; | |
| 315 | |
| 316 /* List of conditions (non-nil atom means all) which cause a backtrace | |
| 317 if any error is signalled. */ | |
| 318 Lisp_Object Vstack_trace_on_signal; | |
| 319 | |
| 320 /* List of conditions (non-nil atom means all) which enter the debugger | |
| 321 if any error is signalled. */ | |
| 322 Lisp_Object Vdebug_on_signal; | |
| 323 | |
| 324 /* Nonzero means enter debugger if a quit signal | |
| 325 is handled by the command loop's error handler. | |
| 326 | |
| 327 From lisp, this is a boolean variable and may have the values 0 and 1. | |
| 328 But, eval.c temporarily uses the second bit of this variable to indicate | |
| 329 that a critical_quit is in progress. The second bit is reset immediately | |
| 330 after it is processed in signal_call_debugger(). */ | |
| 331 int debug_on_quit; | |
| 332 | |
| 333 #if 0 /* FSFmacs */ | |
| 334 /* entering_debugger is basically equivalent */ | |
| 335 /* The value of num_nonmacro_input_chars as of the last time we | |
| 336 started to enter the debugger. If we decide to enter the debugger | |
| 337 again when this is still equal to num_nonmacro_input_chars, then we | |
| 338 know that the debugger itself has an error, and we should just | |
| 339 signal the error instead of entering an infinite loop of debugger | |
| 340 invocations. */ | |
| 341 int when_entered_debugger; | |
| 342 #endif | |
| 343 | |
| 344 /* Nonzero means we are trying to enter the debugger. | |
| 345 This is to prevent recursive attempts. | |
| 346 Cleared by the debugger calling Fbacktrace */ | |
| 347 static int entering_debugger; | |
| 348 | |
| 349 /* Function to call to invoke the debugger */ | |
| 350 Lisp_Object Vdebugger; | |
| 351 | |
| 853 | 352 /* List of condition handlers currently in effect. |
| 353 The elements of this lists were at one point in the past | |
| 354 threaded through the stack frames of Fcondition_case and | |
| 355 related functions, but now are stored separately in a normal | |
| 356 stack. When an error is signaled (by calling Fsignal, below), | |
| 357 this list is searched for an element that applies. | |
| 428 | 358 |
| 359 Each element of this list is one of the following: | |
| 360 | |
| 853 | 361 -- A list of a handler function and possibly args to pass to the |
| 362 function. This is a handler established with the Lisp primitive | |
| 363 `call-with-condition-handler' or related C function | |
| 364 call_with_condition_handler(): | |
| 365 | |
| 366 If the handler function is an opaque ptr object, it is a handler | |
| 367 that was established in C using call_with_condition_handler(), | |
| 368 and the contents of the object are a function pointer which takes | |
| 369 three arguments, the signal name and signal data (same arguments | |
| 370 passed to `signal') and a third Lisp_Object argument, specified | |
| 371 in the call to call_with_condition_handler() and stored as the | |
| 372 second element of the list containing the handler functionl. | |
| 373 | |
| 374 If the handler function is a regular Lisp_Object, it is a handler | |
| 375 that was established using `call-with-condition-handler'. | |
| 376 Currently there are no more arguments in the list containing the | |
| 377 handler function, and only one argument is passed to the handler | |
| 378 function: a cons of the signal name and signal data arguments | |
| 379 passed to `signal'. | |
| 380 | |
| 381 -- A list whose car is Qunbound and whose cdr is Qt. This is a | |
| 382 special condition-case handler established by C code with | |
| 383 condition_case_1(). All errors are trapped; the debugger is not | |
| 384 invoked even if `debug-on-error' was set. | |
| 385 | |
| 386 -- A list whose car is Qunbound and whose cdr is Qerror. This is a | |
| 387 special condition-case handler established by C code with | |
| 388 condition_case_1(). It is like Qt except that the debugger is | |
| 389 invoked normally if it is called for. | |
| 390 | |
| 391 -- A list whose car is Qunbound and whose cdr is a list of lists | |
| 392 (CONDITION-NAME BODY ...) exactly as in `condition-case'. This is | |
| 393 a normal `condition-case' handler. | |
| 394 | |
| 395 Note that in all cases *except* the first, there is a corresponding | |
| 396 catch, whose TAG is the value of Vcondition_handlers just after the | |
| 397 handler data just described is pushed onto it. The reason is that | |
| 398 `condition-case' handlers need to throw back to the place where the | |
| 399 handler was installed before invoking it, while | |
| 400 `call-with-condition-handler' handlers are invoked in the | |
| 401 environment that `signal' was invoked in. */ | |
| 402 | |
| 403 | |
| 428 | 404 static Lisp_Object Vcondition_handlers; |
| 405 | |
| 853 | 406 /* I think we should keep this enabled all the time, not just when |
| 407 error checking is enabled, because if one of these puppies pops up, | |
| 408 it will trash the stack if not caught, making it that much harder to | |
| 409 debug. It doesn't cause speed loss. */ | |
| 442 | 410 #define DEFEND_AGAINST_THROW_RECURSION |
| 411 | |
| 412 #ifdef DEFEND_AGAINST_THROW_RECURSION | |
| 428 | 413 /* Used for error catching purposes by throw_or_bomb_out */ |
| 414 static int throw_level; | |
| 442 | 415 #endif |
| 416 | |
| 1123 | 417 static int warning_will_be_discarded (Lisp_Object level); |
| 2532 | 418 static Lisp_Object maybe_get_trapping_problems_backtrace (void); |
| 1123 | 419 |
| 428 | 420 |
|
5084
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
421 |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
422 /* When parsing keyword arguments; is some element of NARGS |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
423 :allow-other-keys, and is that element followed by a non-nil Lisp |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
424 object? */ |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
425 |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
426 Boolint |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
427 non_nil_allow_other_keys_p (Elemcount offset, int nargs, Lisp_Object *args) |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
428 { |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
429 Lisp_Object key, value; |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
430 while (offset + 1 < nargs) |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
431 { |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
432 key = args[offset++]; |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
433 value = args[offset++]; |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
434 if (EQ (key, Q_allow_other_keys)) |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
435 { |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
436 /* The ANSI Common Lisp standard says the first value for a given |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
437 keyword overrides. */ |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
438 return !NILP (value); |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
439 } |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
440 } |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
441 return 0; |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
442 } |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
443 |
| 428 | 444 /************************************************************************/ |
| 445 /* The subr object type */ | |
| 446 /************************************************************************/ | |
| 447 | |
| 448 static void | |
| 2286 | 449 print_subr (Lisp_Object obj, Lisp_Object printcharfun, int UNUSED (escapeflag)) |
| 428 | 450 { |
| 451 Lisp_Subr *subr = XSUBR (obj); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
452 const Ascbyte *header = |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
453 (subr->max_args == UNEVALLED) ? "#<special-operator " : "#<subr "; |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
454 const Ascbyte *name = subr_name (subr); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
455 const Ascbyte *trailer = subr->prompt ? " (interactive)>" : ">"; |
| 428 | 456 |
| 457 if (print_readably) | |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
458 printing_unreadable_object_fmt ("%s%s%s", header, name, trailer); |
| 428 | 459 |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
460 write_ascstring (printcharfun, header); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
461 write_ascstring (printcharfun, name); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
462 write_ascstring (printcharfun, trailer); |
| 428 | 463 } |
| 464 | |
| 1204 | 465 static const struct memory_description subr_description[] = { |
| 2551 | 466 { XD_DOC_STRING, offsetof (Lisp_Subr, doc), 0, { 0 }, XD_FLAG_NO_KKCC }, |
| 428 | 467 { XD_END } |
| 468 }; | |
| 469 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
470 DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("subr", subr, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
471 0, print_subr, 0, 0, 0, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
472 subr_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
473 Lisp_Subr); |
| 428 | 474 |
| 475 /************************************************************************/ | |
| 476 /* Entering the debugger */ | |
| 477 /************************************************************************/ | |
| 478 | |
| 853 | 479 static Lisp_Object |
| 480 current_warning_level (void) | |
| 481 { | |
| 482 if (inhibit_flags & ISSUE_WARNINGS_AT_DEBUG_LEVEL) | |
| 483 return Qdebug; | |
| 484 else | |
| 485 return Qwarning; | |
| 486 } | |
| 487 | |
| 428 | 488 /* Actually call the debugger. ARG is a list of args that will be |
| 489 passed to the debugger function, as follows; | |
| 490 | |
| 491 If due to frame exit, args are `exit' and the value being returned; | |
| 492 this function's value will be returned instead of that. | |
| 493 If due to error, args are `error' and a list of the args to `signal'. | |
| 494 If due to `apply' or `funcall' entry, one arg, `lambda'. | |
| 495 If due to `eval' entry, one arg, t. | |
| 496 | |
| 497 */ | |
| 498 | |
| 499 static Lisp_Object | |
| 500 call_debugger_259 (Lisp_Object arg) | |
| 501 { | |
| 502 return apply1 (Vdebugger, arg); | |
| 503 } | |
| 504 | |
| 505 /* Call the debugger, doing some encapsulation. We make sure we have | |
| 506 some room on the eval and specpdl stacks, and bind entering_debugger | |
| 507 to 1 during this call. This is used to trap errors that may occur | |
| 508 when entering the debugger (e.g. the value of `debugger' is invalid), | |
| 509 so that the debugger will not be recursively entered if debug-on-error | |
| 510 is set. (Otherwise, XEmacs would infinitely recurse, attempting to | |
| 511 enter the debugger.) entering_debugger gets reset to 0 as soon | |
| 512 as a backtrace is displayed, so that further errors can indeed be | |
| 513 handled normally. | |
| 514 | |
| 3025 | 515 We also establish a catch for `debugger'. If the debugger function |
| 428 | 516 throws to this instead of returning a value, it means that the user |
| 517 pressed 'c' (pretend like the debugger was never entered). The | |
| 518 function then returns Qunbound. (If the user pressed 'r', for | |
| 519 return a value, then the debugger function returns normally with | |
| 520 this value.) | |
| 521 | |
| 522 The difference between 'c' and 'r' is as follows: | |
| 523 | |
| 524 debug-on-call: | |
| 525 No difference. The call proceeds as normal. | |
| 526 debug-on-exit: | |
| 527 With 'r', the specified value is returned as the function's | |
| 528 return value. With 'c', the value that would normally be | |
| 529 returned is returned. | |
| 530 signal: | |
| 531 With 'r', the specified value is returned as the return | |
| 532 value of `signal'. (This is the only time that `signal' | |
| 533 can return, instead of making a non-local exit.) With `c', | |
| 534 `signal' will continue looking for handlers as if the | |
| 535 debugger was never entered, and will probably end up | |
| 536 throwing to a handler or to top-level. | |
| 537 */ | |
| 538 | |
| 539 static Lisp_Object | |
| 540 call_debugger (Lisp_Object arg) | |
| 541 { | |
| 542 int threw; | |
| 543 Lisp_Object val; | |
| 544 int speccount; | |
| 545 | |
| 853 | 546 debug_on_next_call = 0; |
| 547 | |
| 548 if (inhibit_flags & INHIBIT_ENTERING_DEBUGGER) | |
| 549 { | |
| 550 if (!(inhibit_flags & INHIBIT_WARNING_ISSUE)) | |
| 551 warn_when_safe | |
| 552 (Qdebugger, current_warning_level (), | |
| 553 "Unable to enter debugger within critical section"); | |
| 554 return Qunbound; | |
| 555 } | |
| 556 | |
| 428 | 557 if (lisp_eval_depth + 20 > max_lisp_eval_depth) |
| 558 max_lisp_eval_depth = lisp_eval_depth + 20; | |
| 559 if (specpdl_size + 40 > max_specpdl_size) | |
| 560 max_specpdl_size = specpdl_size + 40; | |
| 853 | 561 |
| 562 speccount = internal_bind_int (&entering_debugger, 1); | |
| 2532 | 563 val = internal_catch (Qdebugger, call_debugger_259, arg, &threw, 0, 0); |
| 428 | 564 |
| 771 | 565 return unbind_to_1 (speccount, ((threw) |
| 428 | 566 ? Qunbound /* Not returning a value */ |
| 567 : val)); | |
| 568 } | |
| 569 | |
| 570 /* Called when debug-on-exit behavior is called for. Enter the debugger | |
| 571 with the appropriate args for this. VAL is the exit value that is | |
| 572 about to be returned. */ | |
| 573 | |
| 574 static Lisp_Object | |
| 575 do_debug_on_exit (Lisp_Object val) | |
| 576 { | |
| 577 /* This is falsified by call_debugger */ | |
| 578 Lisp_Object v = call_debugger (list2 (Qexit, val)); | |
| 579 | |
| 580 return !UNBOUNDP (v) ? v : val; | |
| 581 } | |
| 582 | |
| 583 /* Called when debug-on-call behavior is called for. Enter the debugger | |
| 584 with the appropriate args for this. VAL is either t for a call | |
| 3025 | 585 through `eval' or `lambda' for a call through `funcall'. |
| 428 | 586 |
| 587 #### The differentiation here between EVAL and FUNCALL is bogus. | |
| 588 FUNCALL can be defined as | |
| 589 | |
| 590 (defmacro func (fun &rest args) | |
| 591 (cons (eval fun) args)) | |
| 592 | |
| 593 and should be treated as such. | |
| 594 */ | |
| 595 | |
| 596 static void | |
| 597 do_debug_on_call (Lisp_Object code) | |
| 598 { | |
| 599 debug_on_next_call = 0; | |
| 600 backtrace_list->debug_on_exit = 1; | |
| 601 call_debugger (list1 (code)); | |
| 602 } | |
| 603 | |
| 604 /* LIST is the value of one of the variables `debug-on-error', | |
| 605 `debug-on-signal', `stack-trace-on-error', or `stack-trace-on-signal', | |
| 606 and CONDITIONS is the list of error conditions associated with | |
| 607 the error being signalled. This returns non-nil if LIST | |
| 608 matches CONDITIONS. (A nil value for LIST does not match | |
| 609 CONDITIONS. A non-list value for LIST does match CONDITIONS. | |
| 610 A list matches CONDITIONS when one of the symbols in LIST is the | |
| 611 same as one of the symbols in CONDITIONS.) */ | |
| 612 | |
| 613 static int | |
| 614 wants_debugger (Lisp_Object list, Lisp_Object conditions) | |
| 615 { | |
| 616 if (NILP (list)) | |
| 617 return 0; | |
| 618 if (! CONSP (list)) | |
| 619 return 1; | |
| 620 | |
| 621 while (CONSP (conditions)) | |
| 622 { | |
| 2552 | 623 Lisp_Object curr, tail; |
| 624 curr = XCAR (conditions); | |
| 428 | 625 for (tail = list; CONSP (tail); tail = XCDR (tail)) |
| 2552 | 626 if (EQ (XCAR (tail), curr)) |
| 428 | 627 return 1; |
| 628 conditions = XCDR (conditions); | |
| 629 } | |
| 630 return 0; | |
| 631 } | |
| 632 | |
| 633 | |
| 634 /* Return 1 if an error with condition-symbols CONDITIONS, | |
| 635 and described by SIGNAL-DATA, should skip the debugger | |
|
4624
9dd42cb187ed
Fix typo in comment on skip_debugger.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4535
diff
changeset
|
636 according to debug-ignored-errors. */ |
| 428 | 637 |
| 638 static int | |
| 639 skip_debugger (Lisp_Object conditions, Lisp_Object data) | |
| 640 { | |
| 641 /* This function can GC */ | |
| 642 Lisp_Object tail; | |
| 643 int first_string = 1; | |
| 644 Lisp_Object error_message = Qnil; | |
| 645 | |
| 646 for (tail = Vdebug_ignored_errors; CONSP (tail); tail = XCDR (tail)) | |
| 647 { | |
| 648 if (STRINGP (XCAR (tail))) | |
| 649 { | |
| 650 if (first_string) | |
| 651 { | |
| 652 error_message = Ferror_message_string (data); | |
| 653 first_string = 0; | |
| 654 } | |
| 655 if (fast_lisp_string_match (XCAR (tail), error_message) >= 0) | |
| 656 return 1; | |
| 657 } | |
| 658 else | |
| 659 { | |
| 660 Lisp_Object contail; | |
| 661 | |
| 662 for (contail = conditions; CONSP (contail); contail = XCDR (contail)) | |
| 663 if (EQ (XCAR (tail), XCAR (contail))) | |
| 664 return 1; | |
| 665 } | |
| 666 } | |
| 667 | |
| 668 return 0; | |
| 669 } | |
| 670 | |
| 671 /* Actually generate a backtrace on STREAM. */ | |
| 672 | |
| 673 static Lisp_Object | |
| 674 backtrace_259 (Lisp_Object stream) | |
| 675 { | |
| 676 return Fbacktrace (stream, Qt); | |
| 677 } | |
| 678 | |
| 1130 | 679 #ifdef DEBUG_XEMACS |
| 680 | |
| 681 static void | |
| 682 trace_out_and_die (Lisp_Object err) | |
| 683 { | |
| 684 Fdisplay_error (err, Qt); | |
| 685 backtrace_259 (Qnil); | |
| 686 stderr_out ("XEmacs exiting to debugger.\n"); | |
| 687 Fforce_debugging_signal (Qt); | |
| 688 /* Unlikely to be reached */ | |
| 689 } | |
| 690 | |
| 691 #endif | |
| 692 | |
| 428 | 693 /* An error was signaled. Maybe call the debugger, if the `debug-on-error' |
| 694 etc. variables call for this. CONDITIONS is the list of conditions | |
| 695 associated with the error being signalled. SIG is the actual error | |
| 696 being signalled, and DATA is the associated data (these are exactly | |
| 697 the same as the arguments to `signal'). ACTIVE_HANDLERS is the | |
| 698 list of error handlers that are to be put in place while the debugger | |
| 699 is called. This is generally the remaining handlers that are | |
| 700 outside of the innermost handler trapping this error. This way, | |
| 701 if the same error occurs inside of the debugger, you usually don't get | |
| 702 the debugger entered recursively. | |
| 703 | |
| 704 This function returns Qunbound if it didn't call the debugger or if | |
| 705 the user asked (through 'c') that XEmacs should pretend like the | |
| 706 debugger was never entered. Otherwise, it returns the value | |
| 707 that the user specified with `r'. (Note that much of the time, | |
| 708 the user will abort with C-], and we will never have a chance to | |
| 709 return anything at all.) | |
| 710 | |
| 711 SIGNAL_VARS_ONLY means we should only look at debug-on-signal | |
| 712 and stack-trace-on-signal to control whether we do anything. | |
| 713 This is so that debug-on-error doesn't make handled errors | |
| 714 cause the debugger to get invoked. | |
| 715 | |
| 716 STACK_TRACE_DISPLAYED and DEBUGGER_ENTERED are used so that | |
| 717 those functions aren't done more than once in a single `signal' | |
| 718 session. */ | |
| 719 | |
| 720 static Lisp_Object | |
| 721 signal_call_debugger (Lisp_Object conditions, | |
| 722 Lisp_Object sig, Lisp_Object data, | |
| 723 Lisp_Object active_handlers, | |
| 724 int signal_vars_only, | |
| 725 int *stack_trace_displayed, | |
| 726 int *debugger_entered) | |
| 727 { | |
| 853 | 728 #ifdef PIGS_FLY_AND_ALL_C_CODE_CAN_HANDLE_GC_OCCURRING_ALMOST_ANYWHERE |
| 428 | 729 /* This function can GC */ |
| 853 | 730 #else /* reality check */ |
| 731 /* This function cannot GC because it inhibits GC during its operation */ | |
| 732 #endif | |
| 733 | |
| 428 | 734 Lisp_Object val = Qunbound; |
| 735 Lisp_Object all_handlers = Vcondition_handlers; | |
| 736 Lisp_Object temp_data = Qnil; | |
| 853 | 737 int outer_speccount = specpdl_depth(); |
| 738 int speccount; | |
| 739 | |
| 740 #ifdef PIGS_FLY_AND_ALL_C_CODE_CAN_HANDLE_GC_OCCURRING_ALMOST_ANYWHERE | |
| 428 | 741 struct gcpro gcpro1, gcpro2; |
| 742 GCPRO2 (all_handlers, temp_data); | |
| 853 | 743 #else |
| 744 begin_gc_forbidden (); | |
| 745 #endif | |
| 746 | |
| 747 speccount = specpdl_depth(); | |
| 428 | 748 |
| 749 Vcondition_handlers = active_handlers; | |
| 750 | |
| 751 temp_data = Fcons (sig, data); /* needed for skip_debugger */ | |
| 752 | |
| 753 if (!entering_debugger && !*stack_trace_displayed && !signal_vars_only | |
| 754 && wants_debugger (Vstack_trace_on_error, conditions) | |
| 755 && !skip_debugger (conditions, temp_data)) | |
| 756 { | |
| 757 specbind (Qdebug_on_error, Qnil); | |
| 758 specbind (Qstack_trace_on_error, Qnil); | |
| 759 specbind (Qdebug_on_signal, Qnil); | |
| 760 specbind (Qstack_trace_on_signal, Qnil); | |
| 761 | |
| 442 | 762 if (!noninteractive) |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
763 internal_with_output_to_temp_buffer (build_ascstring ("*Backtrace*"), |
| 442 | 764 backtrace_259, |
| 765 Qnil, | |
| 766 Qnil); | |
| 767 else /* in batch mode, we want this going to stderr. */ | |
| 768 backtrace_259 (Qnil); | |
| 771 | 769 unbind_to (speccount); |
| 428 | 770 *stack_trace_displayed = 1; |
| 771 } | |
| 772 | |
| 773 if (!entering_debugger && !*debugger_entered && !signal_vars_only | |
| 774 && (EQ (sig, Qquit) | |
| 775 ? debug_on_quit | |
| 776 : wants_debugger (Vdebug_on_error, conditions)) | |
| 777 && !skip_debugger (conditions, temp_data)) | |
| 778 { | |
| 779 debug_on_quit &= ~2; /* reset critical bit */ | |
| 1123 | 780 |
| 428 | 781 specbind (Qdebug_on_error, Qnil); |
| 782 specbind (Qstack_trace_on_error, Qnil); | |
| 783 specbind (Qdebug_on_signal, Qnil); | |
| 784 specbind (Qstack_trace_on_signal, Qnil); | |
| 785 | |
| 1130 | 786 #ifdef DEBUG_XEMACS |
| 787 if (noninteractive) | |
| 788 trace_out_and_die (Fcons (sig, data)); | |
| 789 #endif | |
| 790 | |
| 428 | 791 val = call_debugger (list2 (Qerror, (Fcons (sig, data)))); |
| 853 | 792 unbind_to (speccount); |
| 428 | 793 *debugger_entered = 1; |
| 794 } | |
| 795 | |
| 796 if (!entering_debugger && !*stack_trace_displayed | |
| 797 && wants_debugger (Vstack_trace_on_signal, conditions)) | |
| 798 { | |
| 799 specbind (Qdebug_on_error, Qnil); | |
| 800 specbind (Qstack_trace_on_error, Qnil); | |
| 801 specbind (Qdebug_on_signal, Qnil); | |
| 802 specbind (Qstack_trace_on_signal, Qnil); | |
| 803 | |
| 442 | 804 if (!noninteractive) |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
805 internal_with_output_to_temp_buffer (build_ascstring ("*Backtrace*"), |
| 442 | 806 backtrace_259, |
| 807 Qnil, | |
| 808 Qnil); | |
| 809 else /* in batch mode, we want this going to stderr. */ | |
| 810 backtrace_259 (Qnil); | |
| 771 | 811 unbind_to (speccount); |
| 428 | 812 *stack_trace_displayed = 1; |
| 813 } | |
| 814 | |
| 815 if (!entering_debugger && !*debugger_entered | |
| 816 && (EQ (sig, Qquit) | |
| 817 ? debug_on_quit | |
| 818 : wants_debugger (Vdebug_on_signal, conditions))) | |
| 819 { | |
| 820 debug_on_quit &= ~2; /* reset critical bit */ | |
| 1123 | 821 |
| 428 | 822 specbind (Qdebug_on_error, Qnil); |
| 823 specbind (Qstack_trace_on_error, Qnil); | |
| 824 specbind (Qdebug_on_signal, Qnil); | |
| 825 specbind (Qstack_trace_on_signal, Qnil); | |
| 826 | |
| 1130 | 827 #ifdef DEBUG_XEMACS |
| 828 if (noninteractive) | |
| 829 trace_out_and_die (Fcons (sig, data)); | |
| 830 #endif | |
| 831 | |
| 428 | 832 val = call_debugger (list2 (Qerror, (Fcons (sig, data)))); |
| 833 *debugger_entered = 1; | |
| 834 } | |
| 835 | |
| 853 | 836 #ifdef PIGS_FLY_AND_ALL_C_CODE_CAN_HANDLE_GC_OCCURRING_ALMOST_ANYWHERE |
| 428 | 837 UNGCPRO; |
| 853 | 838 #endif |
| 428 | 839 Vcondition_handlers = all_handlers; |
| 853 | 840 return unbind_to_1 (outer_speccount, val); |
| 428 | 841 } |
| 842 | |
| 843 | |
| 844 /************************************************************************/ | |
| 845 /* The basic special forms */ | |
| 846 /************************************************************************/ | |
| 847 | |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
848 /* Except for Fprogn(), the basic special operators below are only called |
| 428 | 849 from interpreted code. The byte compiler turns them into bytecodes. */ |
| 850 | |
| 851 DEFUN ("or", For, 0, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
852 Eval ARGS until one of them yields non-nil, then return that value. |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
853 The remaining ARGS are not evalled at all. |
| 428 | 854 If all args return nil, return nil. |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
855 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
856 Any multiple values from the last form, and only from the last form, are |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
857 passed back. See `values' and `multiple-value-bind'. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
858 |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
859 arguments: (&rest ARGS) |
| 428 | 860 */ |
| 861 (args)) | |
| 862 { | |
| 863 /* This function can GC */ | |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
864 Lisp_Object val = Qnil; |
| 428 | 865 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
866 LIST_LOOP_3 (arg, args, tail) |
| 428 | 867 { |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
868 if (!NILP (IGNORE_MULTIPLE_VALUES (val = Feval (arg)))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
869 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
870 if (NILP (XCDR (tail))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
871 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
872 /* Pass back multiple values if this is the last one: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
873 return val; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
874 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
875 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
876 return IGNORE_MULTIPLE_VALUES (val); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
877 } |
| 428 | 878 } |
| 879 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
880 return val; |
| 428 | 881 } |
| 882 | |
| 883 DEFUN ("and", Fand, 0, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
884 Eval ARGS until one of them yields nil, then return nil. |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
885 The remaining ARGS are not evalled at all. |
| 428 | 886 If no arg yields nil, return the last arg's value. |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
887 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
888 Any multiple values from the last form, and only from the last form, are |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
889 passed back. See `values' and `multiple-value-bind'. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
890 |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
891 arguments: (&rest ARGS) |
| 428 | 892 */ |
| 893 (args)) | |
| 894 { | |
| 895 /* This function can GC */ | |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
896 Lisp_Object val = Qt; |
| 428 | 897 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
898 LIST_LOOP_3 (arg, args, tail) |
| 428 | 899 { |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
900 if (NILP (IGNORE_MULTIPLE_VALUES (val = Feval (arg)))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
901 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
902 if (NILP (XCDR (tail))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
903 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
904 /* Pass back any multiple values for the last form: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
905 return val; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
906 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
907 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
908 return Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
909 } |
| 428 | 910 } |
| 911 | |
| 912 return val; | |
| 913 } | |
| 914 | |
| 915 DEFUN ("if", Fif, 2, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
916 If COND yields non-nil, do THEN, else do ELSE. |
| 428 | 917 Returns the value of THEN or the value of the last of the ELSE's. |
| 918 THEN must be one expression, but ELSE... can be zero or more expressions. | |
| 919 If COND yields nil, and there are no ELSE's, the value is nil. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
920 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
921 arguments: (COND THEN &rest ELSE) |
| 428 | 922 */ |
| 923 (args)) | |
| 924 { | |
| 925 /* This function can GC */ | |
| 926 Lisp_Object condition = XCAR (args); | |
| 927 Lisp_Object then_form = XCAR (XCDR (args)); | |
| 928 Lisp_Object else_forms = XCDR (XCDR (args)); | |
| 929 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
930 if (!NILP (IGNORE_MULTIPLE_VALUES (Feval (condition)))) |
| 428 | 931 return Feval (then_form); |
| 932 else | |
| 933 return Fprogn (else_forms); | |
| 934 } | |
| 935 | |
| 936 /* Macros `when' and `unless' are trivially defined in Lisp, | |
| 937 but it helps for bootstrapping to have them ALWAYS defined. */ | |
| 938 | |
| 939 DEFUN ("when", Fwhen, 1, MANY, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
940 If COND yields non-nil, do BODY, else return nil. |
| 428 | 941 BODY can be zero or more expressions. If BODY is nil, return nil. |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
942 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
943 arguments: (COND &rest BODY) |
| 428 | 944 */ |
| 945 (int nargs, Lisp_Object *args)) | |
| 946 { | |
| 947 Lisp_Object cond = args[0]; | |
| 948 Lisp_Object body; | |
| 853 | 949 |
| 428 | 950 switch (nargs) |
| 951 { | |
| 952 case 1: body = Qnil; break; | |
| 953 case 2: body = args[1]; break; | |
| 954 default: body = Fcons (Qprogn, Flist (nargs-1, args+1)); break; | |
| 955 } | |
| 956 | |
| 957 return list3 (Qif, cond, body); | |
| 958 } | |
| 959 | |
| 960 DEFUN ("unless", Funless, 1, MANY, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
961 If COND yields nil, do BODY, else return nil. |
| 428 | 962 BODY can be zero or more expressions. If BODY is nil, return nil. |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
963 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
964 arguments: (COND &rest BODY) |
| 428 | 965 */ |
| 966 (int nargs, Lisp_Object *args)) | |
| 967 { | |
| 968 Lisp_Object cond = args[0]; | |
| 969 Lisp_Object body = Flist (nargs-1, args+1); | |
| 970 return Fcons (Qif, Fcons (cond, Fcons (Qnil, body))); | |
| 971 } | |
| 972 | |
| 973 DEFUN ("cond", Fcond, 0, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
974 Try each clause until one succeeds. |
| 428 | 975 Each clause looks like (CONDITION BODY...). CONDITION is evaluated |
| 976 and, if the value is non-nil, this clause succeeds: | |
| 977 then the expressions in BODY are evaluated and the last one's | |
| 978 value is the value of the cond-form. | |
| 979 If no clause succeeds, cond returns nil. | |
| 980 If a clause has one element, as in (CONDITION), | |
| 981 CONDITION's value if non-nil is returned from the cond-form. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
982 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
983 arguments: (&rest CLAUSES) |
| 428 | 984 */ |
| 985 (args)) | |
| 986 { | |
| 987 /* This function can GC */ | |
| 442 | 988 REGISTER Lisp_Object val; |
| 428 | 989 |
| 990 LIST_LOOP_2 (clause, args) | |
| 991 { | |
| 992 CHECK_CONS (clause); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
993 if (!NILP (val = IGNORE_MULTIPLE_VALUES (Feval (XCAR (clause))))) |
| 428 | 994 { |
| 995 if (!NILP (clause = XCDR (clause))) | |
| 996 { | |
| 997 CHECK_TRUE_LIST (clause); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
998 /* Pass back any multiple values here: */ |
| 428 | 999 val = Fprogn (clause); |
| 1000 } | |
| 1001 return val; | |
| 1002 } | |
| 1003 } | |
| 1004 | |
| 1005 return Qnil; | |
| 1006 } | |
| 1007 | |
| 1008 DEFUN ("progn", Fprogn, 0, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1009 Eval BODY forms sequentially and return value of last one. |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1010 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1011 arguments: (&rest BODY) |
| 428 | 1012 */ |
| 1013 (args)) | |
| 1014 { | |
| 1015 /* This function can GC */ | |
| 1016 /* Caller must provide a true list in ARGS */ | |
| 442 | 1017 REGISTER Lisp_Object val = Qnil; |
| 428 | 1018 struct gcpro gcpro1; |
| 1019 | |
| 1020 GCPRO1 (args); | |
| 1021 | |
| 1022 { | |
| 1023 LIST_LOOP_2 (form, args) | |
| 1024 val = Feval (form); | |
| 1025 } | |
| 1026 | |
| 1027 UNGCPRO; | |
| 1028 return val; | |
| 1029 } | |
| 1030 | |
| 1031 /* Fprog1() is the canonical example of a function that must GCPRO a | |
| 1032 Lisp_Object across calls to Feval(). */ | |
| 1033 | |
| 1034 DEFUN ("prog1", Fprog1, 1, UNEVALLED, 0, /* | |
| 1035 Similar to `progn', but the value of the first form is returned. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1036 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1037 All the arguments are evaluated sequentially. The value of FIRST is saved |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1038 during evaluation of the remaining args, whose values are discarded. |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1039 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1040 arguments: (FIRST &rest BODY) |
| 428 | 1041 */ |
| 1042 (args)) | |
| 1043 { | |
| 1849 | 1044 Lisp_Object val; |
| 428 | 1045 struct gcpro gcpro1; |
| 1046 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1047 val = IGNORE_MULTIPLE_VALUES (Feval (Fcar (args))); |
| 428 | 1048 |
| 1049 GCPRO1 (val); | |
| 1050 | |
| 1051 { | |
| 1052 LIST_LOOP_2 (form, XCDR (args)) | |
| 1053 Feval (form); | |
| 1054 } | |
| 1055 | |
| 1056 UNGCPRO; | |
| 1057 return val; | |
| 1058 } | |
| 1059 | |
| 1060 DEFUN ("prog2", Fprog2, 2, UNEVALLED, 0, /* | |
| 1061 Similar to `progn', but the value of the second form is returned. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1062 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1063 All the arguments are evaluated sequentially. The value of SECOND is saved |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1064 during evaluation of the remaining args, whose values are discarded. |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1065 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1066 arguments: (FIRST SECOND &rest BODY) |
| 428 | 1067 */ |
| 1068 (args)) | |
| 1069 { | |
| 1070 /* This function can GC */ | |
| 1849 | 1071 Lisp_Object val; |
| 428 | 1072 struct gcpro gcpro1; |
| 1073 | |
| 1074 Feval (XCAR (args)); | |
| 1075 args = XCDR (args); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1076 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1077 val = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1078 |
| 428 | 1079 args = XCDR (args); |
| 1080 | |
| 1081 GCPRO1 (val); | |
| 1082 | |
| 442 | 1083 { |
| 1084 LIST_LOOP_2 (form, args) | |
| 1085 Feval (form); | |
| 1086 } | |
| 428 | 1087 |
| 1088 UNGCPRO; | |
| 1089 return val; | |
| 1090 } | |
| 1091 | |
| 1092 DEFUN ("let*", FletX, 1, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1093 Bind variables according to VARLIST then eval BODY. |
| 428 | 1094 The value of the last form in BODY is returned. |
| 1095 Each element of VARLIST is a symbol (which is bound to nil) | |
| 1096 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM). | |
| 1097 Each VALUEFORM can refer to the symbols already bound by this VARLIST. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1098 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1099 arguments: (VARLIST &rest BODY) |
| 428 | 1100 */ |
| 1101 (args)) | |
| 1102 { | |
| 1103 /* This function can GC */ | |
| 1104 Lisp_Object varlist = XCAR (args); | |
| 1105 Lisp_Object body = XCDR (args); | |
| 1106 int speccount = specpdl_depth(); | |
| 1107 | |
| 1108 EXTERNAL_LIST_LOOP_3 (var, varlist, tail) | |
| 1109 { | |
| 1110 Lisp_Object symbol, value, tem; | |
| 1111 if (SYMBOLP (var)) | |
| 1112 symbol = var, value = Qnil; | |
| 1113 else | |
| 1114 { | |
| 1115 CHECK_CONS (var); | |
| 1116 symbol = XCAR (var); | |
| 1117 tem = XCDR (var); | |
| 1118 if (NILP (tem)) | |
| 1119 value = Qnil; | |
| 1120 else | |
| 1121 { | |
| 1122 CHECK_CONS (tem); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1123 value = IGNORE_MULTIPLE_VALUES (Feval (XCAR (tem))); |
| 428 | 1124 if (!NILP (XCDR (tem))) |
| 563 | 1125 sferror |
| 428 | 1126 ("`let' bindings can have only one value-form", var); |
| 1127 } | |
| 1128 } | |
| 1129 specbind (symbol, value); | |
| 1130 } | |
| 771 | 1131 return unbind_to_1 (speccount, Fprogn (body)); |
| 428 | 1132 } |
| 1133 | |
| 1134 DEFUN ("let", Flet, 1, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1135 Bind variables according to VARLIST then eval BODY. |
| 428 | 1136 The value of the last form in BODY is returned. |
| 1137 Each element of VARLIST is a symbol (which is bound to nil) | |
| 1138 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM). | |
| 1139 All the VALUEFORMs are evalled before any symbols are bound. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1140 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1141 arguments: (VARLIST &rest BODY) |
| 428 | 1142 */ |
| 1143 (args)) | |
| 1144 { | |
| 1145 /* This function can GC */ | |
| 1146 Lisp_Object varlist = XCAR (args); | |
| 1147 Lisp_Object body = XCDR (args); | |
| 1148 int speccount = specpdl_depth(); | |
| 1149 Lisp_Object *temps; | |
| 1150 int idx; | |
| 1151 struct gcpro gcpro1; | |
| 1152 | |
| 1153 /* Make space to hold the values to give the bound variables. */ | |
| 1154 { | |
| 1155 int varcount; | |
| 1156 GET_EXTERNAL_LIST_LENGTH (varlist, varcount); | |
| 1157 temps = alloca_array (Lisp_Object, varcount); | |
| 1158 } | |
| 1159 | |
| 1160 /* Compute the values and store them in `temps' */ | |
| 1161 GCPRO1 (*temps); | |
| 1162 gcpro1.nvars = 0; | |
| 1163 | |
| 1164 idx = 0; | |
| 442 | 1165 { |
| 1166 LIST_LOOP_2 (var, varlist) | |
| 1167 { | |
| 1168 Lisp_Object *value = &temps[idx++]; | |
| 1169 if (SYMBOLP (var)) | |
| 1170 *value = Qnil; | |
| 1171 else | |
| 1172 { | |
| 1173 Lisp_Object tem; | |
| 1174 CHECK_CONS (var); | |
| 1175 tem = XCDR (var); | |
| 1176 if (NILP (tem)) | |
| 1177 *value = Qnil; | |
| 1178 else | |
| 1179 { | |
| 1180 CHECK_CONS (tem); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1181 *value = IGNORE_MULTIPLE_VALUES (Feval (XCAR (tem))); |
| 442 | 1182 gcpro1.nvars = idx; |
| 1183 | |
| 1184 if (!NILP (XCDR (tem))) | |
| 563 | 1185 sferror |
| 442 | 1186 ("`let' bindings can have only one value-form", var); |
| 1187 } | |
| 1188 } | |
| 1189 } | |
| 1190 } | |
| 428 | 1191 |
| 1192 idx = 0; | |
| 442 | 1193 { |
| 1194 LIST_LOOP_2 (var, varlist) | |
| 1195 { | |
| 1196 specbind (SYMBOLP (var) ? var : XCAR (var), temps[idx++]); | |
| 1197 } | |
| 1198 } | |
| 428 | 1199 |
| 1200 UNGCPRO; | |
| 1201 | |
| 771 | 1202 return unbind_to_1 (speccount, Fprogn (body)); |
| 428 | 1203 } |
| 1204 | |
| 1205 DEFUN ("while", Fwhile, 1, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1206 If TEST yields non-nil, eval BODY... and repeat. |
| 428 | 1207 The order of execution is thus TEST, BODY, TEST, BODY and so on |
| 1208 until TEST returns nil. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1209 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1210 arguments: (TEST &rest BODY) |
| 428 | 1211 */ |
| 1212 (args)) | |
| 1213 { | |
| 1214 /* This function can GC */ | |
| 1215 Lisp_Object test = XCAR (args); | |
| 1216 Lisp_Object body = XCDR (args); | |
| 1217 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1218 while (!NILP (IGNORE_MULTIPLE_VALUES (Feval (test)))) |
| 428 | 1219 { |
| 1220 QUIT; | |
| 1221 Fprogn (body); | |
| 1222 } | |
| 1223 | |
| 1224 return Qnil; | |
| 1225 } | |
| 1226 | |
| 1227 DEFUN ("setq", Fsetq, 0, UNEVALLED, 0, /* | |
| 1228 \(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL. | |
| 1229 The symbols SYM are variables; they are literal (not evaluated). | |
| 1230 The values VAL are expressions; they are evaluated. | |
| 1231 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'. | |
| 1232 The second VAL is not computed until after the first SYM is set, and so on; | |
| 1233 each VAL can use the new value of variables set earlier in the `setq'. | |
| 1234 The return value of the `setq' form is the value of the last VAL. | |
| 1235 */ | |
| 1236 (args)) | |
| 1237 { | |
| 1238 /* This function can GC */ | |
| 1239 int nargs; | |
| 2421 | 1240 Lisp_Object retval = Qnil; |
| 428 | 1241 |
| 1242 GET_LIST_LENGTH (args, nargs); | |
| 1243 | |
| 1244 if (nargs & 1) /* Odd number of arguments? */ | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
1245 Fsignal (Qwrong_number_of_arguments, list2 (Qsetq, make_fixnum (nargs))); |
| 428 | 1246 |
| 2421 | 1247 GC_PROPERTY_LIST_LOOP_3 (symbol, val, args) |
| 428 | 1248 { |
| 1249 val = Feval (val); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1250 val = IGNORE_MULTIPLE_VALUES (val); |
| 428 | 1251 Fset (symbol, val); |
| 2421 | 1252 retval = val; |
| 428 | 1253 } |
| 1254 | |
| 2421 | 1255 END_GC_PROPERTY_LIST_LOOP (symbol); |
| 1256 | |
| 1257 return retval; | |
| 428 | 1258 } |
| 1259 | |
| 1260 DEFUN ("quote", Fquote, 1, UNEVALLED, 0, /* | |
| 1261 Return the argument, without evaluating it. `(quote x)' yields `x'. | |
| 3794 | 1262 |
| 3842 | 1263 `quote' differs from `function' in that it is a hint that an expression is |
| 1264 data, not a function. In particular, under some circumstances the byte | |
| 1265 compiler will compile an expression quoted with `function', but it will | |
| 1266 never do so for an expression quoted with `quote'. These issues are most | |
| 1267 important for lambda expressions (see `lambda'). | |
| 1268 | |
| 1269 There is an alternative, more readable, reader syntax for `quote': a Lisp | |
| 1270 object preceded by `''. Thus, `'x' is equivalent to `(quote x)', in all | |
| 1271 contexts. A print function may use either. Internally the expression is | |
| 1272 represented as `(quote x)'). | |
|
5265
5663ae9a8989
Warn at compile time, error at runtime, with (quote X Y), (function X Y).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
1273 |
|
5663ae9a8989
Warn at compile time, error at runtime, with (quote X Y), (function X Y).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
1274 arguments: (OBJECT) |
| 428 | 1275 */ |
| 1276 (args)) | |
| 1277 { | |
|
5207
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1278 int nargs; |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1279 |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1280 GET_LIST_LENGTH (args, nargs); |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1281 if (nargs != 1) |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1282 { |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1283 Fsignal (Qwrong_number_of_arguments, |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
1284 list2 (Qquote, make_fixnum (nargs))); |
|
5207
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1285 } |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1286 |
| 428 | 1287 return XCAR (args); |
| 1288 } | |
| 1289 | |
|
4744
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1290 /* Originally, this was just a function -- but `custom' used a garden- |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1291 variety version, so why not make it a subr? */ |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1292 DEFUN ("quote-maybe", Fquote_maybe, 1, 1, 0, /* |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1293 Quote EXPR if it is not self quoting. |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1294 |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1295 In contrast with `quote', this is a function, not a special form; its |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1296 argument is evaluated before `quote-maybe' is called. It returns either |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1297 EXPR (if it is self-quoting) or a list `(quote EXPR)' if it is not |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1298 self-quoting. Lists starting with the symbol `lambda' are regarded as |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1299 self-quoting. |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1300 */ |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1301 (expr)) |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1302 { |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1303 if ((XTYPE (expr)) == Lisp_Type_Record) |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1304 { |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1305 switch (XRECORD_LHEADER (expr)->type) |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1306 { |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1307 case lrecord_type_symbol: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1308 if (NILP (expr) || (EQ (expr, Qt)) || SYMBOL_IS_KEYWORD (expr)) |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1309 { |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1310 return expr; |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1311 } |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1312 break; |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1313 case lrecord_type_cons: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1314 if (EQ (XCAR (expr), Qlambda)) |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1315 { |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1316 return expr; |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1317 } |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1318 break; |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1319 |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1320 case lrecord_type_vector: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1321 case lrecord_type_string: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1322 case lrecord_type_compiled_function: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1323 case lrecord_type_bit_vector: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1324 case lrecord_type_float: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1325 case lrecord_type_hash_table: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1326 case lrecord_type_char_table: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1327 case lrecord_type_range_table: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1328 case lrecord_type_bignum: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1329 case lrecord_type_ratio: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1330 case lrecord_type_bigfloat: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1331 return expr; |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1332 } |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1333 return list2 (Qquote, expr); |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1334 } |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1335 |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1336 /* Fixnums and characters are self-quoting: */ |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1337 return expr; |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1338 } |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1339 |
| 428 | 1340 DEFUN ("function", Ffunction, 1, UNEVALLED, 0, /* |
| 3842 | 1341 Return the argument, without evaluating it. `(function x)' yields `x'. |
| 1342 | |
| 1343 `function' differs from `quote' in that it is a hint that an expression is | |
| 1344 a function, not data. In particular, under some circumstances the byte | |
| 1345 compiler will compile an expression quoted with `function', but it will | |
| 1346 never do so for an expression quoted with `quote'. However, the byte | |
| 1347 compiler will not compile an expression buried in a data structure such as | |
| 1348 a vector or a list which is not syntactically a function. These issues are | |
| 1349 most important for lambda expressions (see `lambda'). | |
| 1350 | |
| 1351 There is an alternative, more readable, reader syntax for `function': a Lisp | |
| 1352 object preceded by `#''. Thus, #'x is equivalent to (function x), in all | |
| 1353 contexts. A print function may use either. Internally the expression is | |
| 1354 represented as `(function x)'). | |
|
5265
5663ae9a8989
Warn at compile time, error at runtime, with (quote X Y), (function X Y).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
1355 |
|
5663ae9a8989
Warn at compile time, error at runtime, with (quote X Y), (function X Y).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5222
diff
changeset
|
1356 arguments: (SYMBOL-OR-LAMBDA) |
| 428 | 1357 */ |
| 1358 (args)) | |
| 1359 { | |
|
5207
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1360 int nargs; |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1361 |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1362 GET_LIST_LENGTH (args, nargs); |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1363 if (nargs != 1) |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1364 { |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1365 Fsignal (Qwrong_number_of_arguments, |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
1366 list2 (Qfunction, make_fixnum (nargs))); |
|
5207
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1367 } |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1368 |
| 428 | 1369 return XCAR (args); |
| 1370 } | |
| 1371 | |
| 1372 | |
| 1373 /************************************************************************/ | |
| 1374 /* Defining functions/variables */ | |
| 1375 /************************************************************************/ | |
| 1376 static Lisp_Object | |
| 1377 define_function (Lisp_Object name, Lisp_Object defn) | |
| 1378 { | |
| 1379 Ffset (name, defn); | |
|
4535
69a1eda3da06
Distinguish vars and functions in #'symbol-file, #'describe-{function,variable}
Aidan Kehoe <kehoea@parhasard.net>
parents:
4502
diff
changeset
|
1380 LOADHIST_ATTACH (Fcons (Qdefun, name)); |
| 428 | 1381 return name; |
| 1382 } | |
| 1383 | |
| 1384 DEFUN ("defun", Fdefun, 2, UNEVALLED, 0, /* | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1385 Define NAME as a function. |
| 428 | 1386 The definition is (lambda ARGLIST [DOCSTRING] BODY...). |
| 1387 See also the function `interactive'. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1388 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1389 arguments: (NAME ARGLIST &optional DOCSTRING &rest BODY) |
| 428 | 1390 */ |
| 1391 (args)) | |
| 1392 { | |
| 1393 /* This function can GC */ | |
| 1394 return define_function (XCAR (args), | |
| 1395 Fcons (Qlambda, XCDR (args))); | |
| 1396 } | |
| 1397 | |
| 1398 DEFUN ("defmacro", Fdefmacro, 2, UNEVALLED, 0, /* | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1399 Define NAME as a macro. |
| 428 | 1400 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...). |
| 1401 When the macro is called, as in (NAME ARGS...), | |
| 1402 the function (lambda ARGLIST BODY...) is applied to | |
| 1403 the list ARGS... as it appears in the expression, | |
| 1404 and the result should be a form to be evaluated instead of the original. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1405 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1406 arguments: (NAME ARGLIST &optional DOCSTRING &rest BODY) |
| 428 | 1407 */ |
| 1408 (args)) | |
| 1409 { | |
| 1410 /* This function can GC */ | |
|
5506
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1411 if (!NILP (Vmacro_declaration_function)) |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1412 { |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
1413 Lisp_Object declare = Fnth (make_fixnum (2), args); |
|
5506
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1414 |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1415 /* Sigh. This GNU interface is incompatible with the CL declare macro, |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1416 and the latter is much older. |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1417 |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1418 GNU describe this syntax in their docstrings. It's sufficiently |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1419 ugly in the XEmacs context (and in general, but ...) that I'm not |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1420 rushing to document it. |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1421 |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1422 The GNU interface accepts multiple (declare ...) sexps at the |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1423 beginning of a macro. Nothing uses this, and the XEmacs byte |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1424 compiler (will) warn(s) if it encounters code that attempts to use |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1425 it. */ |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1426 |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1427 if (STRINGP (declare)) |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1428 { |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
1429 declare = Fnth (make_fixnum (3), args); |
|
5506
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1430 } |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1431 |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1432 if (CONSP (declare) && EQ (Qdeclare, XCAR (declare))) |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1433 { |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1434 call2 (Vmacro_declaration_function, XCAR (args), declare); |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1435 } |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1436 } |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1437 |
| 428 | 1438 return define_function (XCAR (args), |
| 1439 Fcons (Qmacro, Fcons (Qlambda, XCDR (args)))); | |
| 1440 } | |
| 1441 | |
| 1442 DEFUN ("defvar", Fdefvar, 1, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1443 Define SYMBOL as a variable. |
| 428 | 1444 You are not required to define a variable in order to use it, |
| 1445 but the definition can supply documentation and an initial value | |
| 1446 in a way that tags can recognize. | |
| 1447 | |
| 1448 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is | |
| 1449 void. (However, when you evaluate a defvar interactively, it acts like a | |
| 1450 defconst: SYMBOL's value is always set regardless of whether it's currently | |
| 1451 void.) | |
| 1452 If SYMBOL is buffer-local, its default value is what is set; | |
| 1453 buffer-local values are not affected. | |
| 1454 INITVALUE and DOCSTRING are optional. | |
| 1455 If DOCSTRING starts with *, this variable is identified as a user option. | |
| 442 | 1456 This means that M-x set-variable recognizes it. |
| 428 | 1457 If INITVALUE is missing, SYMBOL's value is not set. |
| 1458 | |
| 1459 In lisp-interaction-mode defvar is treated as defconst. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1460 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1461 arguments: (SYMBOL &optional INITVALUE DOCSTRING) |
| 428 | 1462 */ |
| 1463 (args)) | |
| 1464 { | |
| 1465 /* This function can GC */ | |
| 1466 Lisp_Object sym = XCAR (args); | |
| 1467 | |
| 1468 if (!NILP (args = XCDR (args))) | |
| 1469 { | |
| 1470 Lisp_Object val = XCAR (args); | |
| 1471 | |
| 1472 if (NILP (Fdefault_boundp (sym))) | |
| 1473 { | |
| 1474 struct gcpro gcpro1; | |
| 1475 GCPRO1 (val); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1476 val = IGNORE_MULTIPLE_VALUES (Feval (val)); |
| 428 | 1477 Fset_default (sym, val); |
| 1478 UNGCPRO; | |
| 1479 } | |
| 1480 | |
| 1481 if (!NILP (args = XCDR (args))) | |
| 1482 { | |
| 1483 Lisp_Object doc = XCAR (args); | |
| 1484 Fput (sym, Qvariable_documentation, doc); | |
| 1485 if (!NILP (args = XCDR (args))) | |
| 563 | 1486 signal_error (Qwrong_number_of_arguments, "too many arguments", Qunbound); |
| 428 | 1487 } |
| 1488 } | |
| 1489 | |
| 1490 #ifdef I18N3 | |
| 1491 if (!NILP (Vfile_domain)) | |
| 1492 Fput (sym, Qvariable_domain, Vfile_domain); | |
| 1493 #endif | |
| 1494 | |
| 1495 LOADHIST_ATTACH (sym); | |
| 1496 return sym; | |
| 1497 } | |
| 1498 | |
| 1499 DEFUN ("defconst", Fdefconst, 2, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1500 Define SYMBOL as a constant variable. |
| 428 | 1501 The intent is that programs do not change this value, but users may. |
| 1502 Always sets the value of SYMBOL to the result of evalling INITVALUE. | |
| 1503 If SYMBOL is buffer-local, its default value is what is set; | |
| 1504 buffer-local values are not affected. | |
| 1505 DOCSTRING is optional. | |
| 1506 If DOCSTRING starts with *, this variable is identified as a user option. | |
| 442 | 1507 This means that M-x set-variable recognizes it. |
| 428 | 1508 |
| 1509 Note: do not use `defconst' for user options in libraries that are not | |
| 1510 normally loaded, since it is useful for users to be able to specify | |
| 1511 their own values for such variables before loading the library. | |
| 1512 Since `defconst' unconditionally assigns the variable, | |
| 1513 it would override the user's choice. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1514 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1515 arguments: (SYMBOL &optional INITVALUE DOCSTRING) |
| 428 | 1516 */ |
| 1517 (args)) | |
| 1518 { | |
| 1519 /* This function can GC */ | |
| 1520 Lisp_Object sym = XCAR (args); | |
| 1521 Lisp_Object val = Feval (XCAR (args = XCDR (args))); | |
| 1522 struct gcpro gcpro1; | |
| 1523 | |
| 1524 GCPRO1 (val); | |
| 1525 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1526 val = IGNORE_MULTIPLE_VALUES (val); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1527 |
| 428 | 1528 Fset_default (sym, val); |
| 1529 | |
| 1530 UNGCPRO; | |
| 1531 | |
| 1532 if (!NILP (args = XCDR (args))) | |
| 1533 { | |
| 1534 Lisp_Object doc = XCAR (args); | |
| 1535 Fput (sym, Qvariable_documentation, doc); | |
| 1536 if (!NILP (args = XCDR (args))) | |
| 563 | 1537 signal_error (Qwrong_number_of_arguments, "too many arguments", Qunbound); |
| 428 | 1538 } |
| 1539 | |
| 1540 #ifdef I18N3 | |
| 1541 if (!NILP (Vfile_domain)) | |
| 1542 Fput (sym, Qvariable_domain, Vfile_domain); | |
| 1543 #endif | |
| 1544 | |
| 1545 LOADHIST_ATTACH (sym); | |
| 1546 return sym; | |
| 1547 } | |
| 1548 | |
|
4502
8748a3f7ceb4
Handle varalias chains, custom variables in #'user-variable-p.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4162
diff
changeset
|
1549 /* XEmacs: user-variable-p is in symbols.c, since it needs to mess around |
|
8748a3f7ceb4
Handle varalias chains, custom variables in #'user-variable-p.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4162
diff
changeset
|
1550 with the symbol variable aliases. */ |
| 428 | 1551 |
|
5615
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1552 DEFUN ("macroexpand", Fmacroexpand, 1, 2, 0, /* |
| 428 | 1553 Return result of expanding macros at top level of FORM. |
| 1554 If FORM is not a macro call, it is returned unchanged. | |
| 1555 Otherwise, the macro is expanded and the expansion is considered | |
| 1556 in place of FORM. When a non-macro-call results, it is returned. | |
| 1557 | |
| 442 | 1558 The second optional arg ENVIRONMENT specifies an environment of macro |
| 428 | 1559 definitions to shadow the loaded ones for use in file byte-compilation. |
| 1560 */ | |
| 442 | 1561 (form, environment)) |
| 428 | 1562 { |
| 1563 /* This function can GC */ | |
| 1564 /* With cleanups from Hallvard Furuseth. */ | |
| 1565 REGISTER Lisp_Object expander, sym, def, tem; | |
|
5615
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1566 int speccount = specpdl_depth (); |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1567 |
|
5658
289cf21be887
Don't augment ENVIRONMENT when that's not indicated, #'macroexpand.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5630
diff
changeset
|
1568 if (!EQ (environment, Vbyte_compile_macro_environment)) |
|
289cf21be887
Don't augment ENVIRONMENT when that's not indicated, #'macroexpand.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5630
diff
changeset
|
1569 { |
|
289cf21be887
Don't augment ENVIRONMENT when that's not indicated, #'macroexpand.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5630
diff
changeset
|
1570 specbind (Qbyte_compile_macro_environment, environment); |
|
289cf21be887
Don't augment ENVIRONMENT when that's not indicated, #'macroexpand.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5630
diff
changeset
|
1571 } |
|
5630
f5315ccbf005
Cons less, be more careful about always using the environment, #'macroexpand
Aidan Kehoe <kehoea@parhasard.net>
parents:
5615
diff
changeset
|
1572 |
| 428 | 1573 while (1) |
| 1574 { | |
| 1575 /* Come back here each time we expand a macro call, | |
| 1576 in case it expands into another macro call. */ | |
|
5615
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1577 if (SYMBOLP (form)) |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1578 { |
|
5736
3192994c49ca
Convert C (un)signed long long values to bignums properly.
Jerry James <james@xemacs.org>
parents:
5658
diff
changeset
|
1579 Lisp_Object hashed = make_unsigned_integer (LISP_HASH (form)); |
|
5615
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1580 Lisp_Object assocked; |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1581 |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1582 if (BIGNUMP (hashed)) |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1583 { |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1584 struct gcpro gcpro1; |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1585 GCPRO1 (hashed); |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1586 assocked = Fassoc (hashed, environment); |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1587 UNGCPRO; |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1588 } |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1589 else |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1590 { |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1591 assocked = Fassq (hashed, environment); |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1592 } |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1593 |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1594 if (CONSP (assocked) && !NILP (XCDR (assocked))) |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1595 { |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1596 form = Fcar (XCDR (assocked)); |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1597 continue; |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1598 } |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1599 } |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1600 |
| 428 | 1601 if (!CONSP (form)) |
| 1602 break; | |
| 1603 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */ | |
| 1604 def = sym = XCAR (form); | |
| 1605 tem = Qnil; | |
| 1606 /* Trace symbols aliases to other symbols | |
| 1607 until we get a symbol that is not an alias. */ | |
| 1608 while (SYMBOLP (def)) | |
| 1609 { | |
| 1610 QUIT; | |
| 1611 sym = def; | |
| 442 | 1612 tem = Fassq (sym, environment); |
| 428 | 1613 if (NILP (tem)) |
| 1614 { | |
| 1615 def = XSYMBOL (sym)->function; | |
| 1616 if (!UNBOUNDP (def)) | |
| 1617 continue; | |
| 1618 } | |
| 1619 break; | |
| 1620 } | |
| 442 | 1621 /* Right now TEM is the result from SYM in ENVIRONMENT, |
| 428 | 1622 and if TEM is nil then DEF is SYM's function definition. */ |
| 1623 if (NILP (tem)) | |
| 1624 { | |
| 442 | 1625 /* SYM is not mentioned in ENVIRONMENT. |
| 428 | 1626 Look at its function definition. */ |
| 1627 if (UNBOUNDP (def) | |
| 1628 || !CONSP (def)) | |
| 1629 /* Not defined or definition not suitable */ | |
| 1630 break; | |
| 1631 if (EQ (XCAR (def), Qautoload)) | |
| 1632 { | |
| 1633 /* Autoloading function: will it be a macro when loaded? */ | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
1634 tem = Felt (def, make_fixnum (4)); |
| 428 | 1635 if (EQ (tem, Qt) || EQ (tem, Qmacro)) |
| 1636 { | |
| 1637 /* Yes, load it and try again. */ | |
| 970 | 1638 /* do_autoload GCPROs both arguments */ |
| 428 | 1639 do_autoload (def, sym); |
| 1640 continue; | |
| 1641 } | |
| 1642 else | |
| 1643 break; | |
| 1644 } | |
| 1645 else if (!EQ (XCAR (def), Qmacro)) | |
| 1646 break; | |
| 1647 else expander = XCDR (def); | |
| 1648 } | |
| 1649 else | |
| 1650 { | |
| 1651 expander = XCDR (tem); | |
| 1652 if (NILP (expander)) | |
| 1653 break; | |
| 1654 } | |
| 1655 form = apply1 (expander, XCDR (form)); | |
| 1656 } | |
|
5615
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1657 |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1658 unbind_to (speccount); |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
1659 |
| 428 | 1660 return form; |
| 1661 } | |
| 1662 | |
| 1663 | |
| 1664 /************************************************************************/ | |
| 1665 /* Non-local exits */ | |
| 1666 /************************************************************************/ | |
| 1667 | |
| 1318 | 1668 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS |
| 1669 | |
| 1670 int | |
| 1671 proper_redisplay_wrapping_in_place (void) | |
| 1672 { | |
| 1673 return !in_display | |
| 1674 || ((get_inhibit_flags () & INTERNAL_INHIBIT_ERRORS) | |
| 1675 && (get_inhibit_flags () & INTERNAL_INHIBIT_THROWS)); | |
| 1676 } | |
| 1677 | |
| 1678 static void | |
| 1679 check_proper_critical_section_nonlocal_exit_protection (void) | |
| 1680 { | |
| 1681 assert_with_message | |
| 1682 (proper_redisplay_wrapping_in_place (), | |
| 1683 "Attempted non-local exit from within redisplay without being properly wrapped"); | |
| 1684 } | |
| 1685 | |
| 1686 static void | |
| 1687 check_proper_critical_section_lisp_protection (void) | |
| 1688 { | |
| 1689 assert_with_message | |
| 1690 (proper_redisplay_wrapping_in_place (), | |
| 1691 "Attempt to call Lisp code from within redisplay without being properly wrapped"); | |
| 1692 } | |
| 1693 | |
| 1694 #endif /* ERROR_CHECK_TRAPPING_PROBLEMS */ | |
| 1695 | |
| 428 | 1696 DEFUN ("catch", Fcatch, 1, UNEVALLED, 0, /* |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1697 Eval BODY allowing nonlocal exits using `throw'. |
| 428 | 1698 TAG is evalled to get the tag to use. Then the BODY is executed. |
| 3577 | 1699 Within BODY, (throw TAG VAL) with same (`eq') tag exits BODY and this `catch'. |
| 428 | 1700 If no throw happens, `catch' returns the value of the last BODY form. |
| 1701 If a throw happens, it specifies the value to return from `catch'. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1702 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1703 arguments: (TAG &rest BODY) |
| 428 | 1704 */ |
| 1705 (args)) | |
| 1706 { | |
| 1707 /* This function can GC */ | |
| 1708 Lisp_Object tag = Feval (XCAR (args)); | |
| 1709 Lisp_Object body = XCDR (args); | |
| 2532 | 1710 return internal_catch (tag, Fprogn, body, 0, 0, 0); |
| 428 | 1711 } |
| 1712 | |
| 1713 /* Set up a catch, then call C function FUNC on argument ARG. | |
| 1714 FUNC should return a Lisp_Object. | |
| 1715 This is how catches are done from within C code. */ | |
| 1716 | |
| 1717 Lisp_Object | |
| 1718 internal_catch (Lisp_Object tag, | |
| 1719 Lisp_Object (*func) (Lisp_Object arg), | |
| 1720 Lisp_Object arg, | |
| 853 | 1721 int * volatile threw, |
| 2532 | 1722 Lisp_Object * volatile thrown_tag, |
| 1723 Lisp_Object * volatile backtrace_before_throw) | |
| 428 | 1724 { |
| 1725 /* This structure is made part of the chain `catchlist'. */ | |
| 1726 struct catchtag c; | |
| 1727 | |
| 1728 /* Fill in the components of c, and put it on the list. */ | |
| 1729 c.next = catchlist; | |
| 1730 c.tag = tag; | |
| 853 | 1731 c.actual_tag = Qnil; |
| 2532 | 1732 c.backtrace = Qnil; |
| 428 | 1733 c.val = Qnil; |
| 1734 c.backlist = backtrace_list; | |
| 1735 #if 0 /* FSFmacs */ | |
| 1736 /* #### */ | |
| 1737 c.handlerlist = handlerlist; | |
| 1738 #endif | |
| 1739 c.lisp_eval_depth = lisp_eval_depth; | |
| 1740 c.pdlcount = specpdl_depth(); | |
| 1741 #if 0 /* FSFmacs */ | |
| 1742 c.poll_suppress_count = async_timer_suppress_count; | |
| 1743 #endif | |
| 1744 c.gcpro = gcprolist; | |
| 1745 catchlist = &c; | |
| 1746 | |
| 1747 /* Call FUNC. */ | |
| 1748 if (SETJMP (c.jmp)) | |
| 1749 { | |
| 1750 /* Throw works by a longjmp that comes right here. */ | |
| 1751 if (threw) *threw = 1; | |
| 853 | 1752 if (thrown_tag) *thrown_tag = c.actual_tag; |
| 2532 | 1753 if (backtrace_before_throw) *backtrace_before_throw = c.backtrace; |
| 428 | 1754 return c.val; |
| 1755 } | |
| 1756 c.val = (*func) (arg); | |
| 1757 if (threw) *threw = 0; | |
| 853 | 1758 if (thrown_tag) *thrown_tag = Qnil; |
| 428 | 1759 catchlist = c.next; |
| 853 | 1760 check_catchlist_sanity (); |
| 428 | 1761 return c.val; |
| 1762 } | |
| 1763 | |
| 1764 | |
| 1765 /* Unwind the specbind, catch, and handler stacks back to CATCH, and | |
| 1766 jump to that CATCH, returning VALUE as the value of that catch. | |
| 1767 | |
| 2297 | 1768 This is the guts of Fthrow and Fsignal; they differ only in the |
| 1769 way they choose the catch tag to throw to. A catch tag for a | |
| 428 | 1770 condition-case form has a TAG of Qnil. |
| 1771 | |
| 1772 Before each catch is discarded, unbind all special bindings and | |
| 1773 execute all unwind-protect clauses made above that catch. Unwind | |
| 1774 the handler stack as we go, so that the proper handlers are in | |
| 1775 effect for each unwind-protect clause we run. At the end, restore | |
| 1776 some static info saved in CATCH, and longjmp to the location | |
| 1777 specified in the | |
| 1778 | |
| 1779 This is used for correct unwinding in Fthrow and Fsignal. */ | |
| 1780 | |
| 2268 | 1781 static DECLARE_DOESNT_RETURN (unwind_to_catch (struct catchtag *, Lisp_Object, |
| 1782 Lisp_Object)); | |
| 1783 | |
| 1784 static DOESNT_RETURN | |
| 853 | 1785 unwind_to_catch (struct catchtag *c, Lisp_Object val, Lisp_Object tag) |
| 428 | 1786 { |
| 1787 REGISTER int last_time; | |
| 1788 | |
| 1789 /* Unwind the specbind, catch, and handler stacks back to CATCH | |
| 1790 Before each catch is discarded, unbind all special bindings | |
| 1791 and execute all unwind-protect clauses made above that catch. | |
| 1792 At the end, restore some static info saved in CATCH, | |
| 1793 and longjmp to the location specified. | |
| 1794 */ | |
| 1795 | |
| 1796 /* Save the value somewhere it will be GC'ed. | |
| 1797 (Can't overwrite tag slot because an unwind-protect may | |
| 1798 want to throw to this same tag, which isn't yet invalid.) */ | |
| 1799 c->val = val; | |
| 853 | 1800 c->actual_tag = tag; |
| 428 | 1801 |
| 1802 #if 0 /* FSFmacs */ | |
| 1803 /* Restore the polling-suppression count. */ | |
| 1804 set_poll_suppress_count (catch->poll_suppress_count); | |
| 1805 #endif | |
| 1806 | |
| 617 | 1807 #if 1 |
| 428 | 1808 do |
| 1809 { | |
| 1810 last_time = catchlist == c; | |
| 1811 | |
| 1812 /* Unwind the specpdl stack, and then restore the proper set of | |
| 1813 handlers. */ | |
| 771 | 1814 unbind_to (catchlist->pdlcount); |
| 428 | 1815 catchlist = catchlist->next; |
| 853 | 1816 check_catchlist_sanity (); |
| 428 | 1817 } |
| 1818 while (! last_time); | |
| 617 | 1819 #else |
| 1820 /* Former XEmacs code. This is definitely not as correct because | |
| 1821 there may be a number of catches we're unwinding, and a number | |
| 1822 of unwind-protects in the process. By not undoing the catches till | |
| 1823 the end, there may be invalid catches still current. (This would | |
| 1824 be a particular problem with code like this: | |
| 1825 | |
| 1826 (catch 'foo | |
| 1827 (call-some-code-which-does... | |
| 1828 (catch 'bar | |
| 1829 (unwind-protect | |
| 1830 (call-some-code-which-does... | |
| 1831 (catch 'bar | |
| 1832 (call-some-code-which-does... | |
| 1833 (throw 'foo nil)))) | |
| 1834 (throw 'bar nil))))) | |
| 1835 | |
| 1836 This would try to throw to the inner (catch 'bar)! | |
| 1837 | |
| 1838 --ben | |
| 1839 */ | |
| 428 | 1840 /* Unwind the specpdl stack */ |
| 771 | 1841 unbind_to (c->pdlcount); |
| 428 | 1842 catchlist = c->next; |
| 853 | 1843 check_catchlist_sanity (); |
| 617 | 1844 #endif /* Former code */ |
| 428 | 1845 |
| 1204 | 1846 UNWIND_GCPRO_TO (c->gcpro); |
| 1292 | 1847 if (profiling_active) |
| 1848 { | |
| 1849 while (backtrace_list != c->backlist) | |
| 1850 { | |
| 1851 profile_record_unwind (backtrace_list); | |
| 1852 backtrace_list = backtrace_list->next; | |
| 1853 } | |
| 1854 } | |
| 1855 else | |
| 1856 backtrace_list = c->backlist; | |
| 428 | 1857 lisp_eval_depth = c->lisp_eval_depth; |
| 1858 | |
| 442 | 1859 #ifdef DEFEND_AGAINST_THROW_RECURSION |
| 428 | 1860 throw_level = 0; |
| 1861 #endif | |
| 1862 LONGJMP (c->jmp, 1); | |
| 1863 } | |
| 1864 | |
|
5348
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1865 DECLARE_DOESNT_RETURN (throw_or_bomb_out_unsafe (Lisp_Object, Lisp_Object, int, |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1866 Lisp_Object, Lisp_Object)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1867 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1868 DOESNT_RETURN |
|
5348
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1869 throw_or_bomb_out_unsafe (Lisp_Object tag, Lisp_Object val, int bomb_out_p, |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1870 Lisp_Object sig, Lisp_Object data) |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1871 { |
| 428 | 1872 /* If bomb_out_p is t, this is being called from Fsignal as a |
| 1873 "last resort" when there is no handler for this error and | |
| 1874 the debugger couldn't be invoked, so we are throwing to | |
| 3025 | 1875 `top-level'. If this tag doesn't exist (happens during the |
| 428 | 1876 initialization stages) we would get in an infinite recursive |
| 1877 Fsignal/Fthrow loop, so instead we bomb out to the | |
| 1878 really-early-error-handler. | |
| 1879 | |
| 1880 Note that in fact the only time that the "last resort" | |
| 3025 | 1881 occurs is when there's no catch for `top-level' -- the |
| 1882 `top-level' catch and the catch-all error handler are | |
| 428 | 1883 established at the same time, in initial_command_loop/ |
| 1884 top_level_1. | |
| 1885 | |
| 853 | 1886 [[#### Fix this horrifitude!]] |
| 1887 | |
| 1888 I don't think this is horrifitude, just defensive programming. --ben | |
| 428 | 1889 */ |
| 1890 | |
| 1891 while (1) | |
| 1892 { | |
| 1893 REGISTER struct catchtag *c; | |
| 1894 | |
| 1895 #if 0 /* FSFmacs */ | |
| 1896 if (!NILP (tag)) /* #### */ | |
| 1897 #endif | |
| 1898 for (c = catchlist; c; c = c->next) | |
| 1899 { | |
| 2532 | 1900 if (EQ (c->tag, Vcatch_everything_tag)) |
| 1901 c->backtrace = maybe_get_trapping_problems_backtrace (); | |
| 853 | 1902 if (EQ (c->tag, tag) || EQ (c->tag, Vcatch_everything_tag)) |
| 1903 unwind_to_catch (c, val, tag); | |
| 428 | 1904 } |
| 1905 if (!bomb_out_p) | |
| 1906 tag = Fsignal (Qno_catch, list2 (tag, val)); | |
| 1907 else | |
| 1908 call1 (Qreally_early_error_handler, Fcons (sig, data)); | |
| 1909 } | |
| 1910 } | |
|
5348
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1911 |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1912 DECLARE_DOESNT_RETURN (throw_or_bomb_out (Lisp_Object, Lisp_Object, int, |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1913 Lisp_Object, Lisp_Object)); |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1914 |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1915 DOESNT_RETURN |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1916 throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p, |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1917 Lisp_Object sig, Lisp_Object data) |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1918 { |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1919 #ifdef DEFEND_AGAINST_THROW_RECURSION |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1920 /* die if we recurse more than is reasonable */ |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1921 assert (++throw_level <= 20); |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1922 #endif |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1923 |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1924 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1925 check_proper_critical_section_nonlocal_exit_protection (); |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1926 #endif |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1927 throw_or_bomb_out_unsafe (tag, val, bomb_out_p, sig, data); |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1928 } |
| 428 | 1929 |
| 1930 /* See above, where CATCHLIST is defined, for a description of how | |
| 1931 Fthrow() works. | |
| 1932 | |
| 1933 Fthrow() is also called by Fsignal(), to do a non-local jump | |
| 1934 back to the appropriate condition-case handler after (maybe) | |
| 1935 the debugger is entered. In that case, TAG is the value | |
| 1936 of Vcondition_handlers that was in place just after the | |
| 1937 condition-case handler was set up. The car of this will be | |
| 1938 some data referring to the handler: Its car will be Qunbound | |
| 1939 (thus, this tag can never be generated by Lisp code), and | |
| 1940 its CDR will be the HANDLERS argument to condition_case_1() | |
| 1941 (either Qerror, Qt, or a list of handlers as in `condition-case'). | |
| 1942 This works fine because Fthrow() does not care what TAG was | |
| 1943 passed to it: it just looks up the catch list for something | |
| 1944 that is EQ() to TAG. When it finds it, it will longjmp() | |
| 1945 back to the place that established the catch (in this case, | |
| 1946 condition_case_1). See below for more info. | |
| 1947 */ | |
| 1948 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1949 DEFUN_NORETURN ("throw", Fthrow, 2, UNEVALLED, 0, /* |
| 444 | 1950 Throw to the catch for TAG and return VALUE from it. |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1951 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1952 Both TAG and VALUE are evalled, and multiple values in VALUE will be passed |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1953 back. Tags are the same if and only if they are `eq'. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1954 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1955 arguments: (TAG VALUE) |
| 428 | 1956 */ |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1957 (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1958 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1959 int nargs; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1960 Lisp_Object tag, value; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1961 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1962 GET_LIST_LENGTH (args, nargs); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1963 if (nargs != 2) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1964 { |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
1965 Fsignal (Qwrong_number_of_arguments, list2 (Qthrow, make_fixnum (nargs))); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1966 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1967 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1968 tag = IGNORE_MULTIPLE_VALUES (Feval (XCAR(args))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1969 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1970 value = Feval (XCAR (XCDR (args))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1971 |
| 444 | 1972 throw_or_bomb_out (tag, value, 0, Qnil, Qnil); /* Doesn't return */ |
| 2268 | 1973 RETURN_NOT_REACHED (Qnil); |
| 428 | 1974 } |
| 1975 | |
| 1976 DEFUN ("unwind-protect", Funwind_protect, 1, UNEVALLED, 0, /* | |
| 1977 Do BODYFORM, protecting with UNWINDFORMS. | |
| 1978 If BODYFORM completes normally, its value is returned | |
| 1979 after executing the UNWINDFORMS. | |
| 1980 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1981 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1982 arguments: (BODYFORM &rest UNWINDFORMS) |
| 428 | 1983 */ |
| 1984 (args)) | |
| 1985 { | |
| 1986 /* This function can GC */ | |
| 1987 int speccount = specpdl_depth(); | |
| 1988 | |
| 1989 record_unwind_protect (Fprogn, XCDR (args)); | |
| 771 | 1990 return unbind_to_1 (speccount, Feval (XCAR (args))); |
| 428 | 1991 } |
| 1992 | |
| 1993 | |
| 1994 /************************************************************************/ | |
| 1292 | 1995 /* Trapping errors */ |
| 428 | 1996 /************************************************************************/ |
| 1997 | |
| 1998 static Lisp_Object | |
| 1999 condition_bind_unwind (Lisp_Object loser) | |
| 2000 { | |
| 617 | 2001 /* There is no problem freeing stuff here like there is in |
| 2002 condition_case_unwind(), because there are no outside pointers | |
| 2003 (like the tag below in the catchlist) pointing to the objects. */ | |
| 853 | 2004 |
| 428 | 2005 /* ((handler-fun . handler-args) ... other handlers) */ |
| 2006 Lisp_Object tem = XCAR (loser); | |
| 853 | 2007 int first = 1; |
| 428 | 2008 |
| 2009 while (CONSP (tem)) | |
| 2010 { | |
| 853 | 2011 Lisp_Object victim = tem; |
| 2012 if (first && OPAQUE_PTRP (XCAR (victim))) | |
| 2013 free_opaque_ptr (XCAR (victim)); | |
| 2014 first = 0; | |
| 2015 tem = XCDR (victim); | |
| 428 | 2016 free_cons (victim); |
| 2017 } | |
| 2018 | |
| 2019 if (EQ (loser, Vcondition_handlers)) /* may have been rebound to some tail */ | |
| 853 | 2020 Vcondition_handlers = XCDR (loser); |
| 2021 | |
| 2022 free_cons (loser); | |
| 428 | 2023 return Qnil; |
| 2024 } | |
| 2025 | |
| 2026 static Lisp_Object | |
| 2027 condition_case_unwind (Lisp_Object loser) | |
| 2028 { | |
| 2029 /* ((<unbound> . clauses) ... other handlers */ | |
| 617 | 2030 /* NO! Doing this now leaves the tag deleted in a still-active |
| 2031 catch. With the recent changes to unwind_to_catch(), the | |
| 2032 evil situation might not happen any more; it certainly could | |
| 2033 happen before because it did. But it's very precarious to rely | |
| 2034 on something like this. #### Instead we should rewrite, adopting | |
| 2035 the FSF's mechanism with a struct handler instead of | |
| 2036 Vcondition_handlers; then we have NO Lisp-object structures used | |
| 2037 to hold all of the values, and there's no possibility either of | |
| 2038 crashes from freeing objects too quickly, or objects not getting | |
| 2039 freed and hanging around till the next GC. | |
| 2040 | |
| 2041 In practice, the extra consing here should not matter because | |
| 2042 it only happens when we throw past the condition-case, which almost | |
| 2043 always is the result of an error. Most of the time, there will be | |
| 2044 no error, and we will free the objects below in the main function. | |
| 2045 | |
| 2046 --ben | |
| 2047 | |
| 2048 DO NOT DO: free_cons (XCAR (loser)); | |
| 2049 */ | |
| 2050 | |
| 428 | 2051 if (EQ (loser, Vcondition_handlers)) /* may have been rebound to some tail */ |
| 617 | 2052 Vcondition_handlers = XCDR (loser); |
| 2053 | |
| 2054 /* DO NOT DO: free_cons (loser); */ | |
| 428 | 2055 return Qnil; |
| 2056 } | |
| 2057 | |
| 2058 /* Split out from condition_case_3 so that primitive C callers | |
| 2059 don't have to cons up a lisp handler form to be evaluated. */ | |
| 2060 | |
| 2061 /* Call a function BFUN of one argument BARG, trapping errors as | |
| 2062 specified by HANDLERS. If no error occurs that is indicated by | |
| 2063 HANDLERS as something to be caught, the return value of this | |
| 2064 function is the return value from BFUN. If such an error does | |
| 2065 occur, HFUN is called, and its return value becomes the | |
| 2066 return value of condition_case_1(). The second argument passed | |
| 2067 to HFUN will always be HARG. The first argument depends on | |
| 2068 HANDLERS: | |
| 2069 | |
| 2070 If HANDLERS is Qt, all errors (this includes QUIT, but not | |
| 2071 non-local exits with `throw') cause HFUN to be invoked, and VAL | |
| 2072 (the first argument to HFUN) is a cons (SIG . DATA) of the | |
| 2073 arguments passed to `signal'. The debugger is not invoked even if | |
| 2074 `debug-on-error' was set. | |
| 2075 | |
| 2076 A HANDLERS value of Qerror is the same as Qt except that the | |
| 2077 debugger is invoked if `debug-on-error' was set. | |
| 2078 | |
| 2079 Otherwise, HANDLERS should be a list of lists (CONDITION-NAME BODY ...) | |
| 2080 exactly as in `condition-case', and errors will be trapped | |
| 2081 as indicated in HANDLERS. VAL (the first argument to HFUN) will | |
| 2082 be a cons whose car is the cons (SIG . DATA) and whose CDR is the | |
| 2083 list (BODY ...) from the appropriate slot in HANDLERS. | |
| 2084 | |
| 2085 This function pushes HANDLERS onto the front of Vcondition_handlers | |
| 2086 (actually with a Qunbound marker as well -- see Fthrow() above | |
| 2087 for why), establishes a catch whose tag is this new value of | |
| 2088 Vcondition_handlers, and calls BFUN. When Fsignal() is called, | |
| 2089 it calls Fthrow(), setting TAG to this same new value of | |
| 2090 Vcondition_handlers and setting VAL to the same thing that will | |
| 2091 be passed to HFUN, as above. Fthrow() longjmp()s back to the | |
| 2092 jump point we just established, and we in turn just call the | |
| 2093 HFUN and return its value. | |
| 2094 | |
| 2095 For a real condition-case, HFUN will always be | |
| 2096 run_condition_case_handlers() and HARG is the argument VAR | |
| 2097 to condition-case. That function just binds VAR to the cons | |
| 2098 (SIG . DATA) that is the CAR of VAL, and calls the handler | |
| 2099 (BODY ...) that is the CDR of VAL. Note that before calling | |
| 2100 Fthrow(), Fsignal() restored Vcondition_handlers to the value | |
| 2101 it had *before* condition_case_1() was called. This maintains | |
| 2102 consistency (so that the state of things at exit of | |
| 2103 condition_case_1() is the same as at entry), and implies | |
| 2104 that the handler can signal the same error again (possibly | |
| 2105 after processing of its own), without getting in an infinite | |
| 2106 loop. */ | |
| 2107 | |
| 2108 Lisp_Object | |
| 2109 condition_case_1 (Lisp_Object handlers, | |
| 2110 Lisp_Object (*bfun) (Lisp_Object barg), | |
| 2111 Lisp_Object barg, | |
| 2112 Lisp_Object (*hfun) (Lisp_Object val, Lisp_Object harg), | |
| 2113 Lisp_Object harg) | |
| 2114 { | |
| 2115 int speccount = specpdl_depth(); | |
| 2116 struct catchtag c; | |
| 617 | 2117 struct gcpro gcpro1, gcpro2, gcpro3; |
| 428 | 2118 |
| 2119 #if 0 /* FSFmacs */ | |
| 2120 c.tag = Qnil; | |
| 2121 #else | |
| 2122 /* Do consing now so out-of-memory error happens up front */ | |
| 2123 /* (unbound . stuff) is a special condition-case kludge marker | |
| 2124 which is known specially by Fsignal. | |
| 617 | 2125 [[ This is an abomination, but to fix it would require either |
| 428 | 2126 making condition_case cons (a union of the conditions of the clauses) |
| 617 | 2127 or changing the byte-compiler output (no thanks).]] |
| 2128 | |
| 2129 The above comment is clearly wrong. FSF does not do it this way | |
| 2130 and did not change the byte-compiler output. Instead they use a | |
| 2131 `struct handler' to hold the various values (in place of our | |
| 2132 Vcondition_handlers) and chain them together, with pointers from | |
| 2133 the `struct catchtag' to the `struct handler'. We should perhaps | |
| 2134 consider moving to something similar, but not before I merge my | |
| 2135 stderr-proc workspace, which contains changes to these | |
| 2136 functions. --ben */ | |
| 428 | 2137 c.tag = noseeum_cons (noseeum_cons (Qunbound, handlers), |
| 2138 Vcondition_handlers); | |
| 2139 #endif | |
| 2140 c.val = Qnil; | |
| 853 | 2141 c.actual_tag = Qnil; |
| 2532 | 2142 c.backtrace = Qnil; |
| 428 | 2143 c.backlist = backtrace_list; |
| 2144 #if 0 /* FSFmacs */ | |
| 2145 /* #### */ | |
| 2146 c.handlerlist = handlerlist; | |
| 2147 #endif | |
| 2148 c.lisp_eval_depth = lisp_eval_depth; | |
| 2149 c.pdlcount = specpdl_depth(); | |
| 2150 #if 0 /* FSFmacs */ | |
| 2151 c.poll_suppress_count = async_timer_suppress_count; | |
| 2152 #endif | |
| 2153 c.gcpro = gcprolist; | |
| 2154 /* #### FSFmacs does the following statement *after* the setjmp(). */ | |
| 2155 c.next = catchlist; | |
| 2156 | |
| 2157 if (SETJMP (c.jmp)) | |
| 2158 { | |
| 2159 /* throw does ungcpro, etc */ | |
| 2160 return (*hfun) (c.val, harg); | |
| 2161 } | |
| 2162 | |
| 2163 record_unwind_protect (condition_case_unwind, c.tag); | |
| 2164 | |
| 2165 catchlist = &c; | |
| 2166 #if 0 /* FSFmacs */ | |
| 2167 h.handler = handlers; | |
| 2168 h.var = Qnil; | |
| 2169 h.next = handlerlist; | |
| 2170 h.tag = &c; | |
| 2171 handlerlist = &h; | |
| 2172 #else | |
| 2173 Vcondition_handlers = c.tag; | |
| 2174 #endif | |
| 2175 GCPRO1 (harg); /* Somebody has to gc-protect */ | |
| 2176 c.val = ((*bfun) (barg)); | |
| 2177 UNGCPRO; | |
| 617 | 2178 |
| 2179 /* Once we change `catchlist' below, the stuff in c will not be GCPRO'd. */ | |
| 2180 GCPRO3 (harg, c.val, c.tag); | |
| 2181 | |
| 428 | 2182 catchlist = c.next; |
| 853 | 2183 check_catchlist_sanity (); |
| 617 | 2184 /* Note: The unbind also resets Vcondition_handlers. Maybe we should |
| 2185 delete this here. */ | |
| 428 | 2186 Vcondition_handlers = XCDR (c.tag); |
| 771 | 2187 unbind_to (speccount); |
| 617 | 2188 |
| 2189 UNGCPRO; | |
| 2190 /* free the conses *after* the unbind, because the unbind will run | |
| 2191 condition_case_unwind above. */ | |
| 853 | 2192 free_cons (XCAR (c.tag)); |
| 2193 free_cons (c.tag); | |
| 617 | 2194 return c.val; |
| 428 | 2195 } |
| 2196 | |
| 2197 static Lisp_Object | |
| 2198 run_condition_case_handlers (Lisp_Object val, Lisp_Object var) | |
| 2199 { | |
| 2200 /* This function can GC */ | |
| 2201 #if 0 /* FSFmacs */ | |
| 2202 if (!NILP (h.var)) | |
| 2203 specbind (h.var, c.val); | |
| 2204 val = Fprogn (Fcdr (h.chosen_clause)); | |
| 2205 | |
| 2206 /* Note that this just undoes the binding of h.var; whoever | |
| 2207 longjmp()ed to us unwound the stack to c.pdlcount before | |
| 2208 throwing. */ | |
| 771 | 2209 unbind_to (c.pdlcount); |
| 428 | 2210 return val; |
| 2211 #else | |
| 2212 int speccount; | |
| 2213 | |
| 2214 CHECK_TRUE_LIST (val); | |
| 2215 if (NILP (var)) | |
| 2216 return Fprogn (Fcdr (val)); /* tail call */ | |
| 2217 | |
| 2218 speccount = specpdl_depth(); | |
| 2219 specbind (var, Fcar (val)); | |
| 2220 val = Fprogn (Fcdr (val)); | |
| 771 | 2221 return unbind_to_1 (speccount, val); |
| 428 | 2222 #endif |
| 2223 } | |
| 2224 | |
| 2225 /* Here for bytecode to call non-consfully. This is exactly like | |
| 2226 condition-case except that it takes three arguments rather | |
| 2227 than a single list of arguments. */ | |
| 2228 Lisp_Object | |
| 2229 condition_case_3 (Lisp_Object bodyform, Lisp_Object var, Lisp_Object handlers) | |
| 2230 { | |
| 2231 /* This function can GC */ | |
| 2232 EXTERNAL_LIST_LOOP_2 (handler, handlers) | |
| 2233 { | |
| 2234 if (NILP (handler)) | |
| 2235 ; | |
| 2236 else if (CONSP (handler)) | |
| 2237 { | |
| 2238 Lisp_Object conditions = XCAR (handler); | |
| 2239 /* CONDITIONS must a condition name or a list of condition names */ | |
| 2240 if (SYMBOLP (conditions)) | |
| 2241 ; | |
| 2242 else | |
| 2243 { | |
| 2244 EXTERNAL_LIST_LOOP_2 (condition, conditions) | |
| 2245 if (!SYMBOLP (condition)) | |
| 2246 goto invalid_condition_handler; | |
| 2247 } | |
| 2248 } | |
| 2249 else | |
| 2250 { | |
| 2251 invalid_condition_handler: | |
| 563 | 2252 sferror ("Invalid condition handler", handler); |
| 428 | 2253 } |
| 2254 } | |
| 2255 | |
| 2256 CHECK_SYMBOL (var); | |
| 2257 | |
| 2258 return condition_case_1 (handlers, | |
| 2259 Feval, bodyform, | |
| 2260 run_condition_case_handlers, | |
| 2261 var); | |
| 2262 } | |
| 2263 | |
| 2264 DEFUN ("condition-case", Fcondition_case, 2, UNEVALLED, 0, /* | |
| 2265 Regain control when an error is signalled. | |
| 2266 Usage looks like (condition-case VAR BODYFORM HANDLERS...). | |
| 2267 Executes BODYFORM and returns its value if no error happens. | |
| 2268 Each element of HANDLERS looks like (CONDITION-NAME BODY...) | |
| 2269 where the BODY is made of Lisp expressions. | |
| 2270 | |
| 771 | 2271 A typical usage of `condition-case' looks like this: |
| 2272 | |
| 2273 (condition-case nil | |
| 2274 ;; you need a progn here if you want more than one statement ... | |
| 2275 (progn | |
| 2276 (do-something) | |
| 2277 (do-something-else)) | |
| 2278 (error | |
| 2279 (issue-warning-or) | |
| 2280 ;; but strangely, you don't need one here. | |
| 2281 (return-a-value-etc) | |
| 2282 )) | |
| 2283 | |
| 428 | 2284 A handler is applicable to an error if CONDITION-NAME is one of the |
| 2285 error's condition names. If an error happens, the first applicable | |
| 2286 handler is run. As a special case, a CONDITION-NAME of t matches | |
| 2287 all errors, even those without the `error' condition name on them | |
| 2288 \(e.g. `quit'). | |
| 2289 | |
| 2290 The car of a handler may be a list of condition names | |
| 2291 instead of a single condition name. | |
| 2292 | |
| 2293 When a handler handles an error, | |
| 2294 control returns to the condition-case and the handler BODY... is executed | |
| 2295 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA). | |
| 2296 VAR may be nil; then you do not get access to the signal information. | |
| 2297 | |
| 2298 The value of the last BODY form is returned from the condition-case. | |
| 2299 See also the function `signal' for more info. | |
| 2300 | |
| 2301 Note that at the time the condition handler is invoked, the Lisp stack | |
| 2302 and the current catches, condition-cases, and bindings have all been | |
| 2303 popped back to the state they were in just before the call to | |
| 2304 `condition-case'. This means that resignalling the error from | |
| 2305 within the handler will not result in an infinite loop. | |
| 2306 | |
| 2307 If you want to establish an error handler that is called with the | |
| 2308 Lisp stack, bindings, etc. as they were when `signal' was called, | |
| 2309 rather than when the handler was set, use `call-with-condition-handler'. | |
| 2310 */ | |
| 2311 (args)) | |
| 2312 { | |
| 2313 /* This function can GC */ | |
| 2314 Lisp_Object var = XCAR (args); | |
| 2315 Lisp_Object bodyform = XCAR (XCDR (args)); | |
| 2316 Lisp_Object handlers = XCDR (XCDR (args)); | |
| 2317 return condition_case_3 (bodyform, var, handlers); | |
| 2318 } | |
| 2319 | |
| 2320 DEFUN ("call-with-condition-handler", Fcall_with_condition_handler, 2, MANY, 0, /* | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
2321 Call FUNCTION with arguments ARGS, regaining control on error. |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
2322 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
2323 This function is similar to `condition-case', but HANDLER is invoked |
| 428 | 2324 with the same environment (Lisp stack, bindings, catches, condition-cases) |
| 2325 that was current when `signal' was called, rather than when the handler | |
| 2326 was established. | |
| 2327 | |
| 2328 HANDLER should be a function of one argument, which is a cons of the args | |
| 2329 \(SIG . DATA) that were passed to `signal'. It is invoked whenever | |
| 2330 `signal' is called (this differs from `condition-case', which allows | |
| 2331 you to specify which errors are trapped). If the handler function | |
| 2332 returns, `signal' continues as if the handler were never invoked. | |
| 2333 \(It continues to look for handlers established earlier than this one, | |
| 2334 and invokes the standard error-handler if none is found.) | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
2335 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
2336 arguments: (HANDLER FUNCTION &rest ARGS) |
| 428 | 2337 */ |
| 2338 (int nargs, Lisp_Object *args)) /* Note! Args side-effected! */ | |
| 2339 { | |
| 2340 /* This function can GC */ | |
| 2341 int speccount = specpdl_depth(); | |
| 2342 Lisp_Object tem; | |
| 2343 | |
| 853 | 2344 tem = Ffunction_max_args (args[0]); |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
2345 if (! (XFIXNUM (Ffunction_min_args (args[0])) <= 1 |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
2346 && (NILP (tem) || 1 <= XFIXNUM (tem)))) |
| 853 | 2347 invalid_argument ("Must be function of one argument", args[0]); |
| 2348 | |
| 2349 /* (handler-fun . handler-args) but currently there are no handler-args */ | |
| 428 | 2350 tem = noseeum_cons (list1 (args[0]), Vcondition_handlers); |
| 2351 record_unwind_protect (condition_bind_unwind, tem); | |
| 2352 Vcondition_handlers = tem; | |
| 2353 | |
| 2354 /* Caller should have GC-protected args */ | |
| 771 | 2355 return unbind_to_1 (speccount, Ffuncall (nargs - 1, args + 1)); |
| 428 | 2356 } |
| 2357 | |
| 853 | 2358 /* This is the C version of the above function. It calls FUN, passing it |
| 2359 ARG, first setting up HANDLER to catch signals in the environment in | |
| 2360 which they were signalled. (HANDLER is only invoked if there was no | |
| 2361 handler (either from condition-case or call-with-condition-handler) set | |
| 2362 later on that handled the signal; therefore, this is a real error. | |
| 2363 | |
| 2364 HANDLER is invoked with three arguments: the ERROR-SYMBOL and DATA as | |
| 2365 passed to `signal', and HANDLER_ARG. Originally I made HANDLER_ARG and | |
| 2366 ARG be void * to facilitate passing structures, but I changed to | |
| 2367 Lisp_Objects because all the other C interfaces to catch/condition-case/etc. | |
| 2368 take Lisp_Objects, and it is easy enough to use make_opaque_ptr() et al. | |
| 2369 to convert between Lisp_Objects and structure pointers. */ | |
| 2370 | |
| 2371 Lisp_Object | |
| 2372 call_with_condition_handler (Lisp_Object (*handler) (Lisp_Object, Lisp_Object, | |
| 2373 Lisp_Object), | |
| 2374 Lisp_Object handler_arg, | |
| 2375 Lisp_Object (*fun) (Lisp_Object), | |
| 2376 Lisp_Object arg) | |
| 2377 { | |
| 2378 /* This function can GC */ | |
| 1111 | 2379 int speccount = specpdl_depth (); |
| 853 | 2380 Lisp_Object tem; |
| 2381 | |
| 2382 /* ((handler-fun . (handler-arg . nil)) ... ) */ | |
| 1111 | 2383 tem = noseeum_cons (noseeum_cons (make_opaque_ptr ((void *) handler), |
| 853 | 2384 noseeum_cons (handler_arg, Qnil)), |
| 2385 Vcondition_handlers); | |
| 2386 record_unwind_protect (condition_bind_unwind, tem); | |
| 2387 Vcondition_handlers = tem; | |
| 2388 | |
| 2389 return unbind_to_1 (speccount, (*fun) (arg)); | |
| 2390 } | |
| 2391 | |
| 428 | 2392 static int |
| 2393 condition_type_p (Lisp_Object type, Lisp_Object conditions) | |
| 2394 { | |
| 2395 if (EQ (type, Qt)) | |
| 2396 /* (condition-case c # (t c)) catches -all- signals | |
| 2397 * Use with caution! */ | |
| 2398 return 1; | |
| 2399 | |
| 2400 if (SYMBOLP (type)) | |
| 2401 return !NILP (Fmemq (type, conditions)); | |
| 2402 | |
| 2403 for (; CONSP (type); type = XCDR (type)) | |
| 2404 if (!NILP (Fmemq (XCAR (type), conditions))) | |
| 2405 return 1; | |
| 2406 | |
| 2407 return 0; | |
| 2408 } | |
| 2409 | |
| 2410 static Lisp_Object | |
| 2411 return_from_signal (Lisp_Object value) | |
| 2412 { | |
| 2413 #if 1 | |
| 2414 /* Most callers are not prepared to handle gc if this | |
| 2415 returns. So, since this feature is not very useful, | |
| 2416 take it out. */ | |
| 2417 /* Have called debugger; return value to signaller */ | |
| 2418 return value; | |
| 2419 #else /* But the reality is that that stinks, because: */ | |
| 2420 /* GACK!!! Really want some way for debug-on-quit errors | |
| 2421 to be continuable!! */ | |
| 563 | 2422 signal_error (Qunimplemented, |
| 2423 "Returning a value from an error is no longer supported", | |
| 2424 Qunbound); | |
| 428 | 2425 #endif |
| 2426 } | |
| 2427 | |
| 2428 | |
| 2429 /************************************************************************/ | |
| 2430 /* the workhorse error-signaling function */ | |
| 2431 /************************************************************************/ | |
| 2432 | |
| 853 | 2433 /* This exists only for debugging purposes, as a place to put a breakpoint |
| 2434 that won't get signalled for errors occurring when | |
| 2435 call_with_suspended_errors() was invoked. */ | |
| 2436 | |
| 872 | 2437 /* Don't make static or it might be compiled away */ |
| 2438 void signal_1 (void); | |
| 2439 | |
| 2440 void | |
| 853 | 2441 signal_1 (void) |
| 2442 { | |
| 2443 } | |
| 2444 | |
| 428 | 2445 /* #### This function has not been synched with FSF. It diverges |
| 2446 significantly. */ | |
| 2447 | |
| 853 | 2448 /* The simplest external error function: it would be called |
| 2449 signal_continuable_error() in the terminology below, but it's | |
| 2450 Lisp-callable. */ | |
| 2451 | |
| 2452 DEFUN ("signal", Fsignal, 2, 2, 0, /* | |
| 2453 Signal a continuable error. Args are ERROR-SYMBOL, and associated DATA. | |
| 2454 An error symbol is a symbol defined using `define-error'. | |
| 2455 DATA should be a list. Its elements are printed as part of the error message. | |
| 2456 If the signal is handled, DATA is made available to the handler. | |
| 2457 See also the function `signal-error', and the functions to handle errors: | |
| 2458 `condition-case' and `call-with-condition-handler'. | |
| 2459 | |
| 2460 Note that this function can return, if the debugger is invoked and the | |
| 2461 user invokes the "return from signal" option. | |
| 2462 */ | |
| 2463 (error_symbol, data)) | |
| 428 | 2464 { |
| 2465 /* This function can GC */ | |
| 853 | 2466 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; |
| 2467 Lisp_Object conditions = Qnil; | |
| 2468 Lisp_Object handlers = Qnil; | |
| 428 | 2469 /* signal_call_debugger() could get called more than once |
| 2470 (once when a call-with-condition-handler is about to | |
| 2471 be dealt with, and another when a condition-case handler | |
| 2472 is about to be invoked). So make sure the debugger and/or | |
| 2473 stack trace aren't done more than once. */ | |
| 2474 int stack_trace_displayed = 0; | |
| 2475 int debugger_entered = 0; | |
| 853 | 2476 |
| 2477 /* Fsignal() is one of these functions that's called all the time | |
| 2478 with newly-created Lisp objects. We allow this; but we must GC- | |
| 2479 protect the objects because all sorts of weird stuff could | |
| 2480 happen. */ | |
| 2481 | |
| 2482 GCPRO4 (conditions, handlers, error_symbol, data); | |
| 2483 | |
| 2484 if (!(inhibit_flags & CALL_WITH_SUSPENDED_ERRORS)) | |
| 2485 signal_1 (); | |
| 428 | 2486 |
| 2487 if (!initialized) | |
| 2488 { | |
| 2489 /* who knows how much has been initialized? Safest bet is | |
| 2490 just to bomb out immediately. */ | |
| 771 | 2491 stderr_out ("Error before initialization is complete!\n"); |
| 2500 | 2492 ABORT (); |
| 428 | 2493 } |
| 2494 | |
| 3092 | 2495 #ifndef NEW_GC |
| 1123 | 2496 assert (!gc_in_progress); |
| 3092 | 2497 #endif /* not NEW_GC */ |
| 1123 | 2498 |
| 2499 /* We abort if in_display and we are not protected, as garbage | |
| 2500 collections and non-local exits will invariably be fatal, but in | |
| 2501 messy, difficult-to-debug ways. See enter_redisplay_critical_section(). | |
| 2502 */ | |
| 2503 | |
| 1318 | 2504 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS |
| 1123 | 2505 check_proper_critical_section_nonlocal_exit_protection (); |
| 1318 | 2506 #endif |
| 428 | 2507 |
| 853 | 2508 conditions = Fget (error_symbol, Qerror_conditions, Qnil); |
| 428 | 2509 |
| 2510 for (handlers = Vcondition_handlers; | |
| 2511 CONSP (handlers); | |
| 2512 handlers = XCDR (handlers)) | |
| 2513 { | |
| 2514 Lisp_Object handler_fun = XCAR (XCAR (handlers)); | |
| 2515 Lisp_Object handler_data = XCDR (XCAR (handlers)); | |
| 2516 Lisp_Object outer_handlers = XCDR (handlers); | |
| 2517 | |
| 2518 if (!UNBOUNDP (handler_fun)) | |
| 2519 { | |
| 2520 /* call-with-condition-handler */ | |
| 2521 Lisp_Object tem; | |
| 2522 Lisp_Object all_handlers = Vcondition_handlers; | |
| 2523 struct gcpro ngcpro1; | |
| 2524 NGCPRO1 (all_handlers); | |
| 2525 Vcondition_handlers = outer_handlers; | |
| 2526 | |
| 853 | 2527 tem = signal_call_debugger (conditions, error_symbol, data, |
| 428 | 2528 outer_handlers, 1, |
| 2529 &stack_trace_displayed, | |
| 2530 &debugger_entered); | |
| 2531 if (!UNBOUNDP (tem)) | |
| 2532 RETURN_NUNGCPRO (return_from_signal (tem)); | |
| 2533 | |
| 853 | 2534 if (OPAQUE_PTRP (handler_fun)) |
| 2535 { | |
| 2536 if (NILP (handler_data)) | |
| 2537 { | |
| 2538 Lisp_Object (*hfun) (Lisp_Object, Lisp_Object) = | |
| 2539 (Lisp_Object (*) (Lisp_Object, Lisp_Object)) | |
| 2540 (get_opaque_ptr (handler_fun)); | |
| 2541 | |
| 2542 tem = (*hfun) (error_symbol, data); | |
| 2543 } | |
| 2544 else | |
| 2545 { | |
| 2546 Lisp_Object (*hfun) (Lisp_Object, Lisp_Object, Lisp_Object) = | |
| 2547 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object)) | |
| 2548 (get_opaque_ptr (handler_fun)); | |
| 2549 | |
| 2550 assert (NILP (XCDR (handler_data))); | |
| 2551 tem = (*hfun) (error_symbol, data, XCAR (handler_data)); | |
| 2552 } | |
| 2553 } | |
| 2554 else | |
| 2555 { | |
| 2556 tem = Fcons (error_symbol, data); | |
| 2557 if (NILP (handler_data)) | |
| 2558 tem = call1 (handler_fun, tem); | |
| 2559 else | |
| 2560 { | |
| 2561 /* (This code won't be used (for now?).) */ | |
| 2562 struct gcpro nngcpro1; | |
| 2563 Lisp_Object args[3]; | |
| 2564 NNGCPRO1 (args[0]); | |
| 2565 nngcpro1.nvars = 3; | |
| 2566 args[0] = handler_fun; | |
| 2567 args[1] = tem; | |
| 2568 args[2] = handler_data; | |
| 2569 nngcpro1.var = args; | |
| 2570 tem = Fapply (3, args); | |
| 2571 NNUNGCPRO; | |
| 2572 } | |
| 2573 } | |
| 428 | 2574 NUNGCPRO; |
| 2575 #if 0 | |
| 2576 if (!EQ (tem, Qsignal)) | |
| 2577 return return_from_signal (tem); | |
| 2578 #endif | |
| 2579 /* If handler didn't throw, try another handler */ | |
| 2580 Vcondition_handlers = all_handlers; | |
| 2581 } | |
| 2582 | |
| 2583 /* It's a condition-case handler */ | |
| 2584 | |
| 2585 /* t is used by handlers for all conditions, set up by C code. | |
| 2586 * debugger is not called even if debug_on_error */ | |
| 2587 else if (EQ (handler_data, Qt)) | |
| 2588 { | |
| 2589 UNGCPRO; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
2590 throw_or_bomb_out (handlers, Fcons (error_symbol, data), |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
2591 0, Qnil, Qnil); |
| 428 | 2592 } |
| 2593 /* `error' is used similarly to the way `t' is used, but in | |
| 2594 addition it invokes the debugger if debug_on_error. | |
| 2595 This is normally used for the outer command-loop error | |
| 2596 handler. */ | |
| 2597 else if (EQ (handler_data, Qerror)) | |
| 2598 { | |
| 853 | 2599 Lisp_Object tem = signal_call_debugger (conditions, error_symbol, |
| 2600 data, | |
| 428 | 2601 outer_handlers, 0, |
| 2602 &stack_trace_displayed, | |
| 2603 &debugger_entered); | |
| 2604 | |
| 2605 UNGCPRO; | |
| 2606 if (!UNBOUNDP (tem)) | |
| 2607 return return_from_signal (tem); | |
| 2608 | |
| 853 | 2609 tem = Fcons (error_symbol, data); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
2610 throw_or_bomb_out (handlers, tem, 0, Qnil, Qnil); |
| 428 | 2611 } |
| 2612 else | |
| 2613 { | |
| 2614 /* handler established by real (Lisp) condition-case */ | |
| 2615 Lisp_Object h; | |
| 2616 | |
| 2617 for (h = handler_data; CONSP (h); h = Fcdr (h)) | |
| 2618 { | |
| 2619 Lisp_Object clause = Fcar (h); | |
| 2620 Lisp_Object tem = Fcar (clause); | |
| 2621 | |
| 2622 if (condition_type_p (tem, conditions)) | |
| 2623 { | |
| 853 | 2624 tem = signal_call_debugger (conditions, error_symbol, data, |
| 428 | 2625 outer_handlers, 1, |
| 2626 &stack_trace_displayed, | |
| 2627 &debugger_entered); | |
| 2628 UNGCPRO; | |
| 2629 if (!UNBOUNDP (tem)) | |
| 2630 return return_from_signal (tem); | |
| 2631 | |
| 2632 /* Doesn't return */ | |
| 853 | 2633 tem = Fcons (Fcons (error_symbol, data), Fcdr (clause)); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
2634 throw_or_bomb_out (handlers, tem, 0, Qnil, Qnil); |
| 428 | 2635 } |
| 2636 } | |
| 2637 } | |
| 2638 } | |
| 2639 | |
| 2640 /* If no handler is present now, try to run the debugger, | |
| 2641 and if that fails, throw to top level. | |
| 2642 | |
| 2643 #### The only time that no handler is present is during | |
| 2644 temacs or perhaps very early in XEmacs. In both cases, | |
| 3025 | 2645 there is no `top-level' catch. (That's why the |
| 428 | 2646 "bomb-out" hack was added.) |
| 2647 | |
| 853 | 2648 [[#### Fix this horrifitude!]] |
| 2649 | |
| 2650 I don't think this is horrifitude, but just defensive coding. --ben */ | |
| 2651 | |
| 2652 signal_call_debugger (conditions, error_symbol, data, Qnil, 0, | |
| 428 | 2653 &stack_trace_displayed, |
| 2654 &debugger_entered); | |
| 2655 UNGCPRO; | |
| 853 | 2656 throw_or_bomb_out (Qtop_level, Qt, 1, error_symbol, |
| 2657 data); /* Doesn't return */ | |
| 2268 | 2658 RETURN_NOT_REACHED (Qnil); |
| 428 | 2659 } |
| 2660 | |
| 2661 /****************** Error functions class 1 ******************/ | |
| 2662 | |
| 2663 /* Class 1: General functions that signal an error. | |
| 2664 These functions take an error type and a list of associated error | |
| 2665 data. */ | |
| 2666 | |
| 853 | 2667 /* No signal_continuable_error_1(); it's called Fsignal(). */ |
| 428 | 2668 |
| 2669 /* Signal a non-continuable error. */ | |
| 2670 | |
| 2671 DOESNT_RETURN | |
| 563 | 2672 signal_error_1 (Lisp_Object sig, Lisp_Object data) |
| 428 | 2673 { |
| 2674 for (;;) | |
| 2675 Fsignal (sig, data); | |
| 2676 } | |
| 853 | 2677 |
| 2678 #ifdef ERROR_CHECK_CATCH | |
| 2679 | |
| 2680 void | |
| 2681 check_catchlist_sanity (void) | |
| 2682 { | |
| 2683 #if 0 | |
| 2684 /* vou me tomar no cu! i just masked andy's missing-unbind | |
| 2685 bug! */ | |
| 442 | 2686 struct catchtag *c; |
| 2687 int found_error_tag = 0; | |
| 2688 | |
| 2689 for (c = catchlist; c; c = c->next) | |
| 2690 { | |
| 2691 if (EQ (c->tag, Qunbound_suspended_errors_tag)) | |
| 2692 { | |
| 2693 found_error_tag = 1; | |
| 2694 break; | |
| 2695 } | |
| 2696 } | |
| 2697 | |
| 2698 assert (found_error_tag || NILP (Vcurrent_error_state)); | |
| 853 | 2699 #endif /* vou me tomar no cul */ |
| 2700 } | |
| 2701 | |
| 2702 void | |
| 2703 check_specbind_stack_sanity (void) | |
| 2704 { | |
| 2705 } | |
| 2706 | |
| 2707 #endif /* ERROR_CHECK_CATCH */ | |
| 428 | 2708 |
| 2709 /* Signal a non-continuable error or display a warning or do nothing, | |
| 2710 according to ERRB. CLASS is the class of warning and should | |
| 2711 refer to what sort of operation is being done (e.g. Qtoolbar, | |
| 2712 Qresource, etc.). */ | |
| 2713 | |
| 2714 void | |
| 1204 | 2715 maybe_signal_error_1 (Lisp_Object sig, Lisp_Object data, Lisp_Object class_, |
| 578 | 2716 Error_Behavior errb) |
| 428 | 2717 { |
| 2718 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2719 return; | |
| 793 | 2720 else if (ERRB_EQ (errb, ERROR_ME_DEBUG_WARN)) |
| 1204 | 2721 warn_when_safe_lispobj (class_, Qdebug, Fcons (sig, data)); |
| 428 | 2722 else if (ERRB_EQ (errb, ERROR_ME_WARN)) |
| 1204 | 2723 warn_when_safe_lispobj (class_, Qwarning, Fcons (sig, data)); |
| 428 | 2724 else |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2725 signal_error_1 (sig, data); |
| 428 | 2726 } |
| 2727 | |
| 2728 /* Signal a continuable error or display a warning or do nothing, | |
| 2729 according to ERRB. */ | |
| 2730 | |
| 2731 Lisp_Object | |
| 563 | 2732 maybe_signal_continuable_error_1 (Lisp_Object sig, Lisp_Object data, |
| 1204 | 2733 Lisp_Object class_, Error_Behavior errb) |
| 428 | 2734 { |
| 2735 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2736 return Qnil; | |
| 793 | 2737 else if (ERRB_EQ (errb, ERROR_ME_DEBUG_WARN)) |
| 2738 { | |
| 1204 | 2739 warn_when_safe_lispobj (class_, Qdebug, Fcons (sig, data)); |
| 793 | 2740 return Qnil; |
| 2741 } | |
| 428 | 2742 else if (ERRB_EQ (errb, ERROR_ME_WARN)) |
| 2743 { | |
| 1204 | 2744 warn_when_safe_lispobj (class_, Qwarning, Fcons (sig, data)); |
| 428 | 2745 return Qnil; |
| 2746 } | |
| 2747 else | |
| 2748 return Fsignal (sig, data); | |
| 2749 } | |
| 2750 | |
| 2751 | |
| 2752 /****************** Error functions class 2 ******************/ | |
| 2753 | |
| 563 | 2754 /* Class 2: Signal an error with a string and an associated object. |
| 2755 Normally these functions are used to attach one associated object, | |
| 2756 but to attach no objects, specify Qunbound for FROB, and for more | |
| 2757 than one object, make a list of the objects with Qunbound as the | |
| 2758 first element. (If you have specifically two objects to attach, | |
| 2759 consider using the function in class 3 below.) These functions | |
| 2760 signal an error of a specified type, whose data is one or more | |
| 2761 objects (usually two), a string the related Lisp object(s) | |
| 2762 specified as FROB. */ | |
| 2763 | |
| 2764 /* Out of REASON and FROB, return a list of elements suitable for passing | |
| 2765 to signal_error_1(). */ | |
| 2766 | |
| 2767 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2768 build_error_data (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 2769 { |
| 2770 if (EQ (frob, Qunbound)) | |
| 2771 frob = Qnil; | |
| 2772 else if (CONSP (frob) && EQ (XCAR (frob), Qunbound)) | |
| 2773 frob = XCDR (frob); | |
| 2774 else | |
| 2775 frob = list1 (frob); | |
| 2776 if (!reason) | |
| 2777 return frob; | |
| 2778 else | |
| 771 | 2779 return Fcons (build_msg_string (reason), frob); |
| 563 | 2780 } |
| 2781 | |
| 2782 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2783 signal_error (Lisp_Object type, const Ascbyte *reason, Lisp_Object frob) |
| 563 | 2784 { |
| 2785 signal_error_1 (type, build_error_data (reason, frob)); | |
| 2786 } | |
| 2787 | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2788 /* NOTE NOTE NOTE: If you feel you need signal_ierror() or something |
|
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2789 similar when reason is a non-ASCII message, you're probably doing |
|
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2790 something wrong. When you have an error message from an external |
|
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2791 source, you should put the error message as the first item in FROB and |
|
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2792 put a string in REASON indicating what you were doing when the error |
|
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2793 message occurred. Use signal_error_2() for such a case. */ |
|
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2794 |
| 563 | 2795 void |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2796 maybe_signal_error (Lisp_Object type, const Ascbyte *reason, |
| 1204 | 2797 Lisp_Object frob, Lisp_Object class_, |
| 578 | 2798 Error_Behavior errb) |
| 563 | 2799 { |
| 2800 /* Optimization: */ | |
| 2801 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2802 return; | |
| 1204 | 2803 maybe_signal_error_1 (type, build_error_data (reason, frob), class_, errb); |
| 563 | 2804 } |
| 2805 | |
| 2806 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2807 signal_continuable_error (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2808 Lisp_Object frob) |
| 2809 { | |
| 2810 return Fsignal (type, build_error_data (reason, frob)); | |
| 2811 } | |
| 2812 | |
| 2813 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2814 maybe_signal_continuable_error (Lisp_Object type, const Ascbyte *reason, |
| 1204 | 2815 Lisp_Object frob, Lisp_Object class_, |
| 578 | 2816 Error_Behavior errb) |
| 563 | 2817 { |
| 2818 /* Optimization: */ | |
| 2819 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2820 return Qnil; | |
| 2821 return maybe_signal_continuable_error_1 (type, | |
| 2822 build_error_data (reason, frob), | |
| 1204 | 2823 class_, errb); |
| 563 | 2824 } |
| 2825 | |
| 2826 | |
| 2827 /****************** Error functions class 3 ******************/ | |
| 2828 | |
| 2829 /* Class 3: Signal an error with a string and two associated objects. | |
| 2830 These functions signal an error of a specified type, whose data | |
| 2831 is three objects, a string and two related Lisp objects. | |
| 2832 (The equivalent could be accomplished using the class 2 functions, | |
| 2833 but these are more convenient in this particular case.) */ | |
| 2834 | |
| 2835 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2836 signal_error_2 (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2837 Lisp_Object frob0, Lisp_Object frob1) |
| 2838 { | |
| 771 | 2839 signal_error_1 (type, list3 (build_msg_string (reason), frob0, |
| 563 | 2840 frob1)); |
| 2841 } | |
| 2842 | |
| 2843 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2844 maybe_signal_error_2 (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2845 Lisp_Object frob0, Lisp_Object frob1, |
| 1204 | 2846 Lisp_Object class_, Error_Behavior errb) |
| 563 | 2847 { |
| 2848 /* Optimization: */ | |
| 2849 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2850 return; | |
| 771 | 2851 maybe_signal_error_1 (type, list3 (build_msg_string (reason), frob0, |
| 1204 | 2852 frob1), class_, errb); |
| 563 | 2853 } |
| 2854 | |
| 2855 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2856 signal_continuable_error_2 (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2857 Lisp_Object frob0, Lisp_Object frob1) |
| 2858 { | |
| 771 | 2859 return Fsignal (type, list3 (build_msg_string (reason), frob0, |
| 563 | 2860 frob1)); |
| 2861 } | |
| 2862 | |
| 2863 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2864 maybe_signal_continuable_error_2 (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2865 Lisp_Object frob0, Lisp_Object frob1, |
| 1204 | 2866 Lisp_Object class_, Error_Behavior errb) |
| 563 | 2867 { |
| 2868 /* Optimization: */ | |
| 2869 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2870 return Qnil; | |
| 2871 return maybe_signal_continuable_error_1 | |
| 771 | 2872 (type, list3 (build_msg_string (reason), frob0, frob1), |
| 1204 | 2873 class_, errb); |
| 563 | 2874 } |
| 2875 | |
| 2876 | |
| 2877 /****************** Error functions class 4 ******************/ | |
| 2878 | |
| 2879 /* Class 4: Printf-like functions that signal an error. | |
| 442 | 2880 These functions signal an error of a specified type, whose data |
| 428 | 2881 is a single string, created using the arguments. */ |
| 2882 | |
| 2883 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2884 signal_ferror (Lisp_Object type, const Ascbyte *fmt, ...) |
| 442 | 2885 { |
| 2886 Lisp_Object obj; | |
| 2887 va_list args; | |
| 2888 | |
| 2889 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2890 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 442 | 2891 va_end (args); |
| 2892 | |
| 2893 /* Fsignal GC-protects its args */ | |
| 563 | 2894 signal_error (type, 0, obj); |
| 442 | 2895 } |
| 2896 | |
| 2897 void | |
| 1204 | 2898 maybe_signal_ferror (Lisp_Object type, Lisp_Object class_, Error_Behavior errb, |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2899 const Ascbyte *fmt, ...) |
| 442 | 2900 { |
| 2901 Lisp_Object obj; | |
| 2902 va_list args; | |
| 2903 | |
| 2904 /* Optimization: */ | |
| 2905 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2906 return; | |
| 2907 | |
| 2908 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2909 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 442 | 2910 va_end (args); |
| 2911 | |
| 2912 /* Fsignal GC-protects its args */ | |
| 1204 | 2913 maybe_signal_error (type, 0, obj, class_, errb); |
| 442 | 2914 } |
| 2915 | |
| 2916 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2917 signal_continuable_ferror (Lisp_Object type, const Ascbyte *fmt, ...) |
| 428 | 2918 { |
| 2919 Lisp_Object obj; | |
| 2920 va_list args; | |
| 2921 | |
| 2922 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2923 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 442 | 2924 va_end (args); |
| 2925 | |
| 2926 /* Fsignal GC-protects its args */ | |
| 2927 return Fsignal (type, list1 (obj)); | |
| 2928 } | |
| 2929 | |
| 2930 Lisp_Object | |
| 1204 | 2931 maybe_signal_continuable_ferror (Lisp_Object type, Lisp_Object class_, |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2932 Error_Behavior errb, const Ascbyte *fmt, ...) |
| 442 | 2933 { |
| 2934 Lisp_Object obj; | |
| 2935 va_list args; | |
| 2936 | |
| 2937 /* Optimization: */ | |
| 2938 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2939 return Qnil; | |
| 2940 | |
| 2941 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2942 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 442 | 2943 va_end (args); |
| 2944 | |
| 2945 /* Fsignal GC-protects its args */ | |
| 1204 | 2946 return maybe_signal_continuable_error (type, 0, obj, class_, errb); |
| 442 | 2947 } |
| 2948 | |
| 2949 | |
| 2950 /****************** Error functions class 5 ******************/ | |
| 2951 | |
| 563 | 2952 /* Class 5: Printf-like functions that signal an error. |
| 442 | 2953 These functions signal an error of a specified type, whose data |
| 563 | 2954 is a one or more objects, a string (created using the arguments) |
| 2955 and additional Lisp objects specified in FROB. (The syntax of FROB | |
| 2956 is the same as for class 2.) | |
| 2957 | |
| 2958 There is no need for a class 6 because you can always attach 2 | |
| 2959 objects using class 5 (for FROB, specify a list with three | |
| 2960 elements, the first of which is Qunbound), and these functions are | |
| 2961 not commonly used. | |
| 2962 */ | |
| 442 | 2963 |
| 2964 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2965 signal_ferror_with_frob (Lisp_Object type, Lisp_Object frob, const Ascbyte *fmt, |
| 563 | 2966 ...) |
| 442 | 2967 { |
| 2968 Lisp_Object obj; | |
| 2969 va_list args; | |
| 2970 | |
| 2971 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2972 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 442 | 2973 va_end (args); |
| 2974 | |
| 2975 /* Fsignal GC-protects its args */ | |
| 563 | 2976 signal_error_1 (type, Fcons (obj, build_error_data (0, frob))); |
| 442 | 2977 } |
| 2978 | |
| 2979 void | |
| 563 | 2980 maybe_signal_ferror_with_frob (Lisp_Object type, Lisp_Object frob, |
| 1204 | 2981 Lisp_Object class_, Error_Behavior errb, |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2982 const Ascbyte *fmt, ...) |
| 442 | 2983 { |
| 2984 Lisp_Object obj; | |
| 2985 va_list args; | |
| 2986 | |
| 2987 /* Optimization: */ | |
| 2988 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2989 return; | |
| 2990 | |
| 2991 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2992 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 428 | 2993 va_end (args); |
| 2994 | |
| 2995 /* Fsignal GC-protects its args */ | |
| 1204 | 2996 maybe_signal_error_1 (type, Fcons (obj, build_error_data (0, frob)), class_, |
| 563 | 2997 errb); |
| 428 | 2998 } |
| 2999 | |
| 3000 Lisp_Object | |
| 563 | 3001 signal_continuable_ferror_with_frob (Lisp_Object type, Lisp_Object frob, |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3002 const Ascbyte *fmt, ...) |
| 428 | 3003 { |
| 3004 Lisp_Object obj; | |
| 3005 va_list args; | |
| 3006 | |
| 3007 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3008 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 428 | 3009 va_end (args); |
| 3010 | |
| 3011 /* Fsignal GC-protects its args */ | |
| 563 | 3012 return Fsignal (type, Fcons (obj, build_error_data (0, frob))); |
| 428 | 3013 } |
| 3014 | |
| 3015 Lisp_Object | |
| 563 | 3016 maybe_signal_continuable_ferror_with_frob (Lisp_Object type, Lisp_Object frob, |
| 1204 | 3017 Lisp_Object class_, |
| 578 | 3018 Error_Behavior errb, |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3019 const Ascbyte *fmt, ...) |
| 428 | 3020 { |
| 3021 Lisp_Object obj; | |
| 3022 va_list args; | |
| 3023 | |
| 3024 /* Optimization: */ | |
| 3025 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 3026 return Qnil; | |
| 3027 | |
| 3028 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3029 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 428 | 3030 va_end (args); |
| 3031 | |
| 3032 /* Fsignal GC-protects its args */ | |
| 563 | 3033 return maybe_signal_continuable_error_1 (type, |
| 3034 Fcons (obj, | |
| 3035 build_error_data (0, frob)), | |
| 1204 | 3036 class_, errb); |
| 428 | 3037 } |
| 3038 | |
| 3039 | |
| 3040 /* This is what the QUIT macro calls to signal a quit */ | |
| 3041 void | |
| 3042 signal_quit (void) | |
| 3043 { | |
| 853 | 3044 /* This function cannot GC. GC is prohibited because most callers do |
| 3045 not expect GC occurring in QUIT. Remove this if/when that gets fixed. | |
| 3046 --ben */ | |
| 3047 | |
| 3048 int count; | |
| 3049 | |
| 428 | 3050 if (EQ (Vquit_flag, Qcritical)) |
| 3051 debug_on_quit |= 2; /* set critical bit. */ | |
| 3052 Vquit_flag = Qnil; | |
| 853 | 3053 count = begin_gc_forbidden (); |
| 428 | 3054 /* note that this is continuable. */ |
| 3055 Fsignal (Qquit, Qnil); | |
| 853 | 3056 unbind_to (count); |
| 428 | 3057 } |
| 3058 | |
| 3059 | |
| 563 | 3060 /************************ convenience error functions ***********************/ |
| 3061 | |
| 436 | 3062 Lisp_Object |
| 428 | 3063 signal_void_function_error (Lisp_Object function) |
| 3064 { | |
| 436 | 3065 return Fsignal (Qvoid_function, list1 (function)); |
| 428 | 3066 } |
| 3067 | |
| 436 | 3068 Lisp_Object |
| 428 | 3069 signal_invalid_function_error (Lisp_Object function) |
| 3070 { | |
| 436 | 3071 return Fsignal (Qinvalid_function, list1 (function)); |
| 428 | 3072 } |
| 3073 | |
| 436 | 3074 Lisp_Object |
| 428 | 3075 signal_wrong_number_of_arguments_error (Lisp_Object function, int nargs) |
| 3076 { | |
| 436 | 3077 return Fsignal (Qwrong_number_of_arguments, |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
3078 list2 (function, make_fixnum (nargs))); |
| 428 | 3079 } |
| 3080 | |
| 3081 /* Used in list traversal macros for efficiency. */ | |
| 436 | 3082 DOESNT_RETURN |
| 428 | 3083 signal_malformed_list_error (Lisp_Object list) |
| 3084 { | |
| 563 | 3085 signal_error (Qmalformed_list, 0, list); |
| 428 | 3086 } |
| 3087 | |
| 436 | 3088 DOESNT_RETURN |
| 428 | 3089 signal_malformed_property_list_error (Lisp_Object list) |
| 3090 { | |
| 563 | 3091 signal_error (Qmalformed_property_list, 0, list); |
| 428 | 3092 } |
| 3093 | |
| 436 | 3094 DOESNT_RETURN |
| 428 | 3095 signal_circular_list_error (Lisp_Object list) |
| 3096 { | |
| 563 | 3097 signal_error (Qcircular_list, 0, list); |
| 428 | 3098 } |
| 3099 | |
| 436 | 3100 DOESNT_RETURN |
| 428 | 3101 signal_circular_property_list_error (Lisp_Object list) |
| 3102 { | |
| 563 | 3103 signal_error (Qcircular_property_list, 0, list); |
| 428 | 3104 } |
| 442 | 3105 |
| 2267 | 3106 /* Called from within emacs_doprnt_1, so REASON is not formatted. */ |
| 442 | 3107 DOESNT_RETURN |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3108 syntax_error (const Ascbyte *reason, Lisp_Object frob) |
| 442 | 3109 { |
| 563 | 3110 signal_error (Qsyntax_error, reason, frob); |
| 442 | 3111 } |
| 3112 | |
| 3113 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3114 syntax_error_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2) |
| 442 | 3115 { |
| 563 | 3116 signal_error_2 (Qsyntax_error, reason, frob1, frob2); |
| 3117 } | |
| 3118 | |
| 3119 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3120 maybe_syntax_error (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3121 Lisp_Object class_, Error_Behavior errb) |
| 3122 { | |
| 3123 maybe_signal_error (Qsyntax_error, reason, frob, class_, errb); | |
| 563 | 3124 } |
| 3125 | |
| 3126 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3127 sferror (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3128 { |
| 3129 signal_error (Qstructure_formation_error, reason, frob); | |
| 3130 } | |
| 3131 | |
| 3132 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3133 sferror_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2) |
| 563 | 3134 { |
| 3135 signal_error_2 (Qstructure_formation_error, reason, frob1, frob2); | |
| 3136 } | |
| 3137 | |
| 3138 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3139 maybe_sferror (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3140 Lisp_Object class_, Error_Behavior errb) |
| 3141 { | |
| 3142 maybe_signal_error (Qstructure_formation_error, reason, frob, class_, errb); | |
| 442 | 3143 } |
| 3144 | |
| 3145 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3146 invalid_argument (const Ascbyte *reason, Lisp_Object frob) |
| 442 | 3147 { |
| 563 | 3148 signal_error (Qinvalid_argument, reason, frob); |
| 442 | 3149 } |
| 3150 | |
| 3151 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3152 invalid_argument_2 (const Ascbyte *reason, Lisp_Object frob1, |
| 609 | 3153 Lisp_Object frob2) |
| 442 | 3154 { |
| 563 | 3155 signal_error_2 (Qinvalid_argument, reason, frob1, frob2); |
| 3156 } | |
| 3157 | |
| 3158 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3159 maybe_invalid_argument (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3160 Lisp_Object class_, Error_Behavior errb) |
| 3161 { | |
| 3162 maybe_signal_error (Qinvalid_argument, reason, frob, class_, errb); | |
| 563 | 3163 } |
| 3164 | |
| 3165 DOESNT_RETURN | |
|
5084
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
3166 invalid_keyword_argument (Lisp_Object function, Lisp_Object keyword) |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
3167 { |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
3168 signal_error_1 (Qinvalid_keyword_argument, list2 (function, keyword)); |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
3169 } |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
3170 |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
3171 DOESNT_RETURN |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3172 invalid_constant (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3173 { |
| 3174 signal_error (Qinvalid_constant, reason, frob); | |
| 3175 } | |
| 3176 | |
| 3177 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3178 invalid_constant_2 (const Ascbyte *reason, Lisp_Object frob1, |
| 609 | 3179 Lisp_Object frob2) |
| 563 | 3180 { |
| 3181 signal_error_2 (Qinvalid_constant, reason, frob1, frob2); | |
| 3182 } | |
| 3183 | |
| 3184 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3185 maybe_invalid_constant (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3186 Lisp_Object class_, Error_Behavior errb) |
| 3187 { | |
| 3188 maybe_signal_error (Qinvalid_constant, reason, frob, class_, errb); | |
| 442 | 3189 } |
| 3190 | |
| 3191 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3192 invalid_operation (const Ascbyte *reason, Lisp_Object frob) |
| 442 | 3193 { |
| 563 | 3194 signal_error (Qinvalid_operation, reason, frob); |
| 442 | 3195 } |
| 3196 | |
| 3197 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3198 invalid_operation_2 (const Ascbyte *reason, Lisp_Object frob1, |
| 609 | 3199 Lisp_Object frob2) |
| 442 | 3200 { |
| 563 | 3201 signal_error_2 (Qinvalid_operation, reason, frob1, frob2); |
| 3202 } | |
| 3203 | |
| 3204 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3205 maybe_invalid_operation (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3206 Lisp_Object class_, Error_Behavior errb) |
| 3207 { | |
| 3208 maybe_signal_error (Qinvalid_operation, reason, frob, class_, errb); | |
| 442 | 3209 } |
| 3210 | |
| 3211 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3212 invalid_change (const Ascbyte *reason, Lisp_Object frob) |
| 442 | 3213 { |
| 563 | 3214 signal_error (Qinvalid_change, reason, frob); |
| 442 | 3215 } |
| 3216 | |
| 3217 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3218 invalid_change_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2) |
| 442 | 3219 { |
| 563 | 3220 signal_error_2 (Qinvalid_change, reason, frob1, frob2); |
| 3221 } | |
| 3222 | |
| 3223 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3224 maybe_invalid_change (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3225 Lisp_Object class_, Error_Behavior errb) |
| 3226 { | |
| 3227 maybe_signal_error (Qinvalid_change, reason, frob, class_, errb); | |
| 563 | 3228 } |
| 3229 | |
| 3230 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3231 invalid_state (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3232 { |
| 3233 signal_error (Qinvalid_state, reason, frob); | |
| 3234 } | |
| 3235 | |
| 3236 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3237 invalid_state_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2) |
| 563 | 3238 { |
| 3239 signal_error_2 (Qinvalid_state, reason, frob1, frob2); | |
| 3240 } | |
| 3241 | |
| 3242 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3243 maybe_invalid_state (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3244 Lisp_Object class_, Error_Behavior errb) |
| 3245 { | |
| 3246 maybe_signal_error (Qinvalid_state, reason, frob, class_, errb); | |
| 563 | 3247 } |
| 3248 | |
| 3249 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3250 wtaerror (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3251 { |
| 3252 signal_error (Qwrong_type_argument, reason, frob); | |
| 3253 } | |
| 3254 | |
| 3255 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3256 stack_overflow (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3257 { |
| 3258 signal_error (Qstack_overflow, reason, frob); | |
| 3259 } | |
| 3260 | |
| 3261 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3262 out_of_memory (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3263 { |
| 3264 signal_error (Qout_of_memory, reason, frob); | |
| 3265 } | |
| 3266 | |
| 428 | 3267 |
| 3268 /************************************************************************/ | |
| 3269 /* User commands */ | |
| 3270 /************************************************************************/ | |
| 3271 | |
| 3272 DEFUN ("commandp", Fcommandp, 1, 1, 0, /* | |
| 3273 Return t if FUNCTION makes provisions for interactive calling. | |
| 3274 This means it contains a description for how to read arguments to give it. | |
| 3275 The value is nil for an invalid function or a symbol with no function | |
| 3276 definition. | |
| 3277 | |
| 3278 Interactively callable functions include | |
| 3279 | |
| 3280 -- strings and vectors (treated as keyboard macros) | |
| 3281 -- lambda-expressions that contain a top-level call to `interactive' | |
| 3282 -- autoload definitions made by `autoload' with non-nil fourth argument | |
| 3283 (i.e. the interactive flag) | |
| 3284 -- compiled-function objects with a non-nil `compiled-function-interactive' | |
| 3285 value | |
| 3286 -- subrs (built-in functions) that are interactively callable | |
| 3287 | |
| 3288 Also, a symbol satisfies `commandp' if its function definition does so. | |
| 3289 */ | |
| 3290 (function)) | |
| 3291 { | |
| 3292 Lisp_Object fun = indirect_function (function, 0); | |
| 3293 | |
| 3294 if (COMPILED_FUNCTIONP (fun)) | |
| 3295 return XCOMPILED_FUNCTION (fun)->flags.interactivep ? Qt : Qnil; | |
| 3296 | |
| 3297 /* Lists may represent commands. */ | |
| 3298 if (CONSP (fun)) | |
| 3299 { | |
| 3300 Lisp_Object funcar = XCAR (fun); | |
| 3301 if (EQ (funcar, Qlambda)) | |
| 3302 return Fassq (Qinteractive, Fcdr (Fcdr (fun))); | |
| 3303 if (EQ (funcar, Qautoload)) | |
| 3304 return Fcar (Fcdr (Fcdr (Fcdr (fun)))); | |
| 3305 else | |
| 3306 return Qnil; | |
| 3307 } | |
| 3308 | |
| 3309 /* Emacs primitives are interactive if their DEFUN specifies an | |
| 3310 interactive spec. */ | |
| 3311 if (SUBRP (fun)) | |
| 3312 return XSUBR (fun)->prompt ? Qt : Qnil; | |
| 3313 | |
| 3314 /* Strings and vectors are keyboard macros. */ | |
| 3315 if (VECTORP (fun) || STRINGP (fun)) | |
| 3316 return Qt; | |
| 3317 | |
| 3318 /* Everything else (including Qunbound) is not a command. */ | |
| 3319 return Qnil; | |
| 3320 } | |
| 3321 | |
| 3322 DEFUN ("command-execute", Fcommand_execute, 1, 3, 0, /* | |
| 3323 Execute CMD as an editor command. | |
| 3324 CMD must be an object that satisfies the `commandp' predicate. | |
| 3325 Optional second arg RECORD-FLAG is as in `call-interactively'. | |
| 3326 The argument KEYS specifies the value to use instead of (this-command-keys) | |
| 3327 when reading the arguments. | |
| 3328 */ | |
| 444 | 3329 (cmd, record_flag, keys)) |
| 428 | 3330 { |
| 3331 /* This function can GC */ | |
| 3332 Lisp_Object prefixarg; | |
| 3333 Lisp_Object final = cmd; | |
| 4162 | 3334 PROFILE_DECLARE(); |
| 428 | 3335 struct console *con = XCONSOLE (Vselected_console); |
| 3336 | |
| 3337 prefixarg = con->prefix_arg; | |
| 3338 con->prefix_arg = Qnil; | |
| 3339 Vcurrent_prefix_arg = prefixarg; | |
| 3340 debug_on_next_call = 0; /* #### from FSFmacs; correct? */ | |
| 3341 | |
| 3342 if (SYMBOLP (cmd) && !NILP (Fget (cmd, Qdisabled, Qnil))) | |
| 733 | 3343 return run_hook (Qdisabled_command_hook); |
| 428 | 3344 |
| 3345 for (;;) | |
| 3346 { | |
| 3347 final = indirect_function (cmd, 1); | |
| 3348 if (CONSP (final) && EQ (Fcar (final), Qautoload)) | |
| 970 | 3349 { |
| 3350 /* do_autoload GCPROs both arguments */ | |
| 3351 do_autoload (final, cmd); | |
| 3352 } | |
| 428 | 3353 else |
| 3354 break; | |
| 3355 } | |
| 3356 | |
| 3357 if (CONSP (final) || SUBRP (final) || COMPILED_FUNCTIONP (final)) | |
| 3358 { | |
| 3359 backtrace.function = &Qcall_interactively; | |
| 3360 backtrace.args = &cmd; | |
| 3361 backtrace.nargs = 1; | |
| 3362 backtrace.evalargs = 0; | |
| 1292 | 3363 backtrace.pdlcount = specpdl_depth (); |
| 428 | 3364 backtrace.debug_on_exit = 0; |
| 1292 | 3365 backtrace.function_being_called = 0; |
| 428 | 3366 PUSH_BACKTRACE (backtrace); |
| 3367 | |
| 1292 | 3368 PROFILE_ENTER_FUNCTION (); |
| 444 | 3369 final = Fcall_interactively (cmd, record_flag, keys); |
| 1292 | 3370 PROFILE_EXIT_FUNCTION (); |
| 428 | 3371 |
| 3372 POP_BACKTRACE (backtrace); | |
| 3373 return final; | |
| 3374 } | |
| 3375 else if (STRINGP (final) || VECTORP (final)) | |
| 3376 { | |
| 3377 return Fexecute_kbd_macro (final, prefixarg); | |
| 3378 } | |
| 3379 else | |
| 3380 { | |
| 3381 Fsignal (Qwrong_type_argument, | |
| 3382 Fcons (Qcommandp, | |
| 3383 (EQ (cmd, final) | |
| 3384 ? list1 (cmd) | |
| 3385 : list2 (cmd, final)))); | |
| 3386 return Qnil; | |
| 3387 } | |
| 3388 } | |
| 3389 | |
| 3390 DEFUN ("interactive-p", Finteractive_p, 0, 0, 0, /* | |
| 3391 Return t if function in which this appears was called interactively. | |
| 3392 This means that the function was called with call-interactively (which | |
| 3393 includes being called as the binding of a key) | |
| 3394 and input is currently coming from the keyboard (not in keyboard macro). | |
| 3395 */ | |
| 3396 ()) | |
| 3397 { | |
| 3398 REGISTER struct backtrace *btp; | |
| 3399 REGISTER Lisp_Object fun; | |
| 3400 | |
| 3401 if (!INTERACTIVE) | |
| 3402 return Qnil; | |
| 3403 | |
| 3404 /* Unless the object was compiled, skip the frame of interactive-p itself | |
| 3405 (if interpreted) or the frame of byte-code (if called from a compiled | |
| 3406 function). Note that *btp->function may be a symbol pointing at a | |
| 3407 compiled function. */ | |
| 3408 btp = backtrace_list; | |
| 3409 | |
| 3410 #if 0 /* FSFmacs */ | |
| 3411 | |
| 3412 /* #### FSFmacs does the following instead. I can't figure | |
| 3413 out which one is more correct. */ | |
| 3414 /* If this isn't a byte-compiled function, there may be a frame at | |
| 3415 the top for Finteractive_p itself. If so, skip it. */ | |
| 3416 fun = Findirect_function (*btp->function); | |
| 3417 if (SUBRP (fun) && XSUBR (fun) == &Sinteractive_p) | |
| 3418 btp = btp->next; | |
| 3419 | |
| 3420 /* If we're running an Emacs 18-style byte-compiled function, there | |
| 3421 may be a frame for Fbyte_code. Now, given the strictest | |
| 3422 definition, this function isn't really being called | |
| 3423 interactively, but because that's the way Emacs 18 always builds | |
| 3424 byte-compiled functions, we'll accept it for now. */ | |
| 3425 if (EQ (*btp->function, Qbyte_code)) | |
| 3426 btp = btp->next; | |
| 3427 | |
| 3428 /* If this isn't a byte-compiled function, then we may now be | |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
3429 looking at several frames for special operators. Skip past them. */ |
| 428 | 3430 while (btp && |
| 3431 btp->nargs == UNEVALLED) | |
| 3432 btp = btp->next; | |
| 3433 | |
| 3434 #else | |
| 3435 | |
| 3436 if (! (COMPILED_FUNCTIONP (Findirect_function (*btp->function)))) | |
| 3437 btp = btp->next; | |
| 3438 for (; | |
| 3439 btp && (btp->nargs == UNEVALLED | |
| 3440 || EQ (*btp->function, Qbyte_code)); | |
| 3441 btp = btp->next) | |
| 3442 {} | |
| 3443 /* btp now points at the frame of the innermost function | |
| 3444 that DOES eval its args. | |
| 3445 If it is a built-in function (such as load or eval-region) | |
| 3446 return nil. */ | |
| 3447 /* Beats me why this is necessary, but it is */ | |
| 3448 if (btp && EQ (*btp->function, Qcall_interactively)) | |
| 3449 return Qt; | |
| 3450 | |
| 3451 #endif | |
| 3452 | |
| 3453 fun = Findirect_function (*btp->function); | |
| 3454 if (SUBRP (fun)) | |
| 3455 return Qnil; | |
| 3456 /* btp points to the frame of a Lisp function that called interactive-p. | |
| 3457 Return t if that function was called interactively. */ | |
| 3458 if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively)) | |
| 3459 return Qt; | |
| 3460 return Qnil; | |
| 3461 } | |
| 3462 | |
| 3463 | |
| 3464 /************************************************************************/ | |
| 3465 /* Autoloading */ | |
| 3466 /************************************************************************/ | |
| 3467 | |
| 3468 DEFUN ("autoload", Fautoload, 2, 5, 0, /* | |
| 444 | 3469 Define FUNCTION to autoload from FILENAME. |
| 3470 FUNCTION is a symbol; FILENAME is a file name string to pass to `load'. | |
| 3471 The remaining optional arguments provide additional info about the | |
| 3472 real definition. | |
| 3473 DOCSTRING is documentation for FUNCTION. | |
| 3474 INTERACTIVE, if non-nil, says FUNCTION can be called interactively. | |
| 3475 TYPE indicates the type of the object: | |
| 428 | 3476 nil or omitted says FUNCTION is a function, |
| 3477 `keymap' says FUNCTION is really a keymap, and | |
| 3478 `macro' or t says FUNCTION is really a macro. | |
| 444 | 3479 If FUNCTION already has a non-void function definition that is not an |
| 3480 autoload object, this function does nothing and returns nil. | |
| 428 | 3481 */ |
| 444 | 3482 (function, filename, docstring, interactive, type)) |
| 428 | 3483 { |
| 3484 /* This function can GC */ | |
| 3485 CHECK_SYMBOL (function); | |
| 444 | 3486 CHECK_STRING (filename); |
| 428 | 3487 |
| 3488 /* If function is defined and not as an autoload, don't override */ | |
| 3489 { | |
| 3490 Lisp_Object f = XSYMBOL (function)->function; | |
| 3491 if (!UNBOUNDP (f) && !(CONSP (f) && EQ (XCAR (f), Qautoload))) | |
| 3492 return Qnil; | |
| 3493 } | |
| 3494 | |
| 3495 if (purify_flag) | |
| 3496 { | |
| 3497 /* Attempt to avoid consing identical (string=) pure strings. */ | |
| 444 | 3498 filename = Fsymbol_name (Fintern (filename, Qnil)); |
| 428 | 3499 } |
| 440 | 3500 |
| 444 | 3501 return Ffset (function, Fcons (Qautoload, list4 (filename, |
| 428 | 3502 docstring, |
| 3503 interactive, | |
| 3504 type))); | |
| 3505 } | |
| 3506 | |
| 3507 Lisp_Object | |
| 3508 un_autoload (Lisp_Object oldqueue) | |
| 3509 { | |
| 3510 /* This function can GC */ | |
| 3511 REGISTER Lisp_Object queue, first, second; | |
| 3512 | |
| 3513 /* Queue to unwind is current value of Vautoload_queue. | |
| 3514 oldqueue is the shadowed value to leave in Vautoload_queue. */ | |
| 3515 queue = Vautoload_queue; | |
| 3516 Vautoload_queue = oldqueue; | |
| 3517 while (CONSP (queue)) | |
| 3518 { | |
| 3519 first = XCAR (queue); | |
| 3520 second = Fcdr (first); | |
| 3521 first = Fcar (first); | |
| 3522 if (NILP (second)) | |
| 3523 Vfeatures = first; | |
| 3524 else | |
| 3525 Ffset (first, second); | |
| 3526 queue = Fcdr (queue); | |
| 3527 } | |
| 3528 return Qnil; | |
| 3529 } | |
| 3530 | |
| 970 | 3531 /* do_autoload GCPROs both arguments */ |
| 428 | 3532 void |
| 3533 do_autoload (Lisp_Object fundef, | |
| 3534 Lisp_Object funname) | |
| 3535 { | |
| 3536 /* This function can GC */ | |
| 3537 int speccount = specpdl_depth(); | |
| 3538 Lisp_Object fun = funname; | |
| 970 | 3539 struct gcpro gcpro1, gcpro2, gcpro3; |
| 428 | 3540 |
| 3541 CHECK_SYMBOL (funname); | |
| 970 | 3542 GCPRO3 (fundef, funname, fun); |
| 428 | 3543 |
| 3544 /* Value saved here is to be restored into Vautoload_queue */ | |
| 3545 record_unwind_protect (un_autoload, Vautoload_queue); | |
| 3546 Vautoload_queue = Qt; | |
| 3547 call4 (Qload, Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, Qnil); | |
| 3548 | |
| 3549 { | |
| 3550 Lisp_Object queue; | |
| 3551 | |
| 3552 /* Save the old autoloads, in case we ever do an unload. */ | |
| 3553 for (queue = Vautoload_queue; CONSP (queue); queue = XCDR (queue)) | |
| 3554 { | |
| 3555 Lisp_Object first = XCAR (queue); | |
| 3556 Lisp_Object second = Fcdr (first); | |
| 3557 | |
| 3558 first = Fcar (first); | |
| 3559 | |
| 3560 /* Note: This test is subtle. The cdr of an autoload-queue entry | |
| 3561 may be an atom if the autoload entry was generated by a defalias | |
| 3562 or fset. */ | |
| 3563 if (CONSP (second)) | |
| 3564 Fput (first, Qautoload, (XCDR (second))); | |
| 3565 } | |
| 3566 } | |
| 3567 | |
| 3568 /* Once loading finishes, don't undo it. */ | |
| 3569 Vautoload_queue = Qt; | |
| 771 | 3570 unbind_to (speccount); |
| 428 | 3571 |
| 3572 fun = indirect_function (fun, 0); | |
| 3573 | |
| 3574 #if 0 /* FSFmacs */ | |
| 3575 if (!NILP (Fequal (fun, fundef))) | |
| 3576 #else | |
| 3577 if (UNBOUNDP (fun) | |
| 3578 || (CONSP (fun) | |
| 3579 && EQ (XCAR (fun), Qautoload))) | |
| 3580 #endif | |
| 563 | 3581 invalid_state ("Autoloading failed to define function", funname); |
| 428 | 3582 UNGCPRO; |
| 3583 } | |
| 3584 | |
| 3585 | |
| 3586 /************************************************************************/ | |
| 3587 /* eval, funcall, apply */ | |
| 3588 /************************************************************************/ | |
| 3589 | |
| 814 | 3590 /* NOTE: If you are hearing the endless complaint that function calls in |
| 3591 elisp are extremely slow, it just isn't true any more! The stuff below | |
| 3592 -- in particular, the calling of subrs and compiled functions, the most | |
| 3593 common cases -- has been highly optimized. There isn't a whole lot left | |
| 3594 to do to squeeze more speed out except by switching to lexical | |
| 3595 variables, which would eliminate the specbind loop. (But the real gain | |
| 3596 from lexical variables would come from better optimization -- with | |
| 3597 dynamic binding, you have the constant problem that any function call | |
| 3598 that you haven't explicitly proven to be side-effect-free might | |
| 3599 potentially side effect your local variables, which makes optimization | |
| 3600 extremely difficult when there are function calls anywhere in a chunk of | |
| 3601 code to be optimized. Even worse, you don't know that *your* local | |
| 3602 variables aren't side-effecting an outer function's local variables, so | |
| 3603 it's impossible to optimize away almost *any* variable assignment.) */ | |
| 3604 | |
| 428 | 3605 static Lisp_Object funcall_lambda (Lisp_Object fun, |
| 442 | 3606 int nargs, Lisp_Object args[]); |
| 428 | 3607 static int in_warnings; |
| 3608 | |
| 3609 | |
| 814 | 3610 void handle_compiled_function_with_and_rest (Lisp_Compiled_Function *f, |
| 3611 int nargs, | |
| 3612 Lisp_Object args[]); | |
| 3613 | |
| 3614 /* The theory behind making this a separate function is to shrink | |
| 3615 funcall_compiled_function() so as to increase the likelihood of a cache | |
| 3616 hit in the L1 cache -- &rest processing is not going to be fast anyway. | |
| 3617 The idea is the same as with execute_rare_opcode() in bytecode.c. We | |
| 3618 make this non-static to ensure the compiler doesn't inline it. */ | |
| 3619 | |
| 3620 void | |
| 3621 handle_compiled_function_with_and_rest (Lisp_Compiled_Function *f, int nargs, | |
| 3622 Lisp_Object args[]) | |
| 3623 { | |
| 3624 REGISTER int i = 0; | |
| 3625 int max_non_rest_args = f->args_in_array - 1; | |
| 3626 int bindargs = min (nargs, max_non_rest_args); | |
| 3627 | |
| 3628 for (i = 0; i < bindargs; i++) | |
| 3092 | 3629 #ifdef NEW_GC |
| 3630 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3631 args[i]); | |
| 3632 #else /* not NEW_GC */ | |
| 814 | 3633 SPECBIND_FAST_UNSAFE (f->args[i], args[i]); |
| 3092 | 3634 #endif /* not NEW_GC */ |
| 814 | 3635 for (i = bindargs; i < max_non_rest_args; i++) |
| 3092 | 3636 #ifdef NEW_GC |
| 3637 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3638 Qnil); | |
| 3639 #else /* not NEW_GC */ | |
| 814 | 3640 SPECBIND_FAST_UNSAFE (f->args[i], Qnil); |
| 3092 | 3641 #endif /* not NEW_GC */ |
| 3642 #ifdef NEW_GC | |
| 3643 SPECBIND_FAST_UNSAFE | |
| 3644 (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[max_non_rest_args], | |
| 3645 nargs > max_non_rest_args ? | |
| 3646 Flist (nargs - max_non_rest_args, &args[max_non_rest_args]) : | |
| 3647 Qnil); | |
| 3648 #else /* not NEW_GC */ | |
| 814 | 3649 SPECBIND_FAST_UNSAFE |
| 3650 (f->args[max_non_rest_args], | |
| 3651 nargs > max_non_rest_args ? | |
| 3652 Flist (nargs - max_non_rest_args, &args[max_non_rest_args]) : | |
| 3653 Qnil); | |
| 3092 | 3654 #endif /* not NEW_GC */ |
| 814 | 3655 } |
| 3656 | |
| 3657 /* Apply compiled-function object FUN to the NARGS evaluated arguments | |
| 3658 in ARGS, and return the result of evaluation. */ | |
| 3659 inline static Lisp_Object | |
| 3660 funcall_compiled_function (Lisp_Object fun, int nargs, Lisp_Object args[]) | |
| 3661 { | |
| 3662 /* This function can GC */ | |
| 3663 int speccount = specpdl_depth(); | |
| 3664 REGISTER int i = 0; | |
| 3665 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun); | |
| 3666 | |
| 3667 if (!OPAQUEP (f->instructions)) | |
| 3668 /* Lazily munge the instructions into a more efficient form */ | |
| 3669 optimize_compiled_function (fun); | |
| 3670 | |
| 3671 /* optimize_compiled_function() guaranteed that f->specpdl_depth is | |
| 3672 the required space on the specbinding stack for binding the args | |
| 3673 and local variables of fun. So just reserve it once. */ | |
| 3674 SPECPDL_RESERVE (f->specpdl_depth); | |
| 3675 | |
| 3676 if (nargs == f->max_args) /* Optimize for the common case -- no unspecified | |
| 3677 optional arguments. */ | |
| 3678 { | |
| 3679 #if 1 | |
| 3680 for (i = 0; i < nargs; i++) | |
| 3092 | 3681 #ifdef NEW_GC |
| 3682 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3683 args[i]); | |
| 3684 #else /* not NEW_GC */ | |
| 814 | 3685 SPECBIND_FAST_UNSAFE (f->args[i], args[i]); |
| 3092 | 3686 #endif /* not NEW_GC */ |
| 814 | 3687 #else |
| 3688 /* Here's an alternate way to write the loop that tries to further | |
| 3689 optimize funcalls for functions with few arguments by partially | |
| 3690 unrolling the loop. It's not clear whether this is a win since it | |
| 3691 increases the size of the function and the possibility of L1 cache | |
| 3692 misses. (Microsoft VC++ 6 with /O2 /G5 generates 0x90 == 144 bytes | |
| 3693 per SPECBIND_FAST_UNSAFE().) Tests under VC++ 6, running the byte | |
| 3694 compiler repeatedly and looking at the total time, show very | |
| 3695 little difference between the simple loop above, the unrolled code | |
| 3696 below, and a "partly unrolled" solution with only cases 0-2 below | |
| 3697 instead of 0-4. Therefore, I'm keeping it at the simple loop | |
| 3698 because it's smaller. */ | |
| 3699 switch (nargs) | |
| 3700 { | |
| 3701 default: | |
| 3702 for (i = nargs - 1; i >= 4; i--) | |
| 3703 SPECBIND_FAST_UNSAFE (f->args[i], args[i]); | |
| 3704 case 4: SPECBIND_FAST_UNSAFE (f->args[3], args[3]); | |
| 3705 case 3: SPECBIND_FAST_UNSAFE (f->args[2], args[2]); | |
| 3706 case 2: SPECBIND_FAST_UNSAFE (f->args[1], args[1]); | |
| 3707 case 1: SPECBIND_FAST_UNSAFE (f->args[0], args[0]); | |
| 3708 case 0: break; | |
| 3709 } | |
| 3710 #endif | |
| 3711 } | |
| 3712 else if (nargs < f->min_args) | |
| 3713 goto wrong_number_of_arguments; | |
| 3714 else if (nargs < f->max_args) | |
| 3715 { | |
| 3716 for (i = 0; i < nargs; i++) | |
| 3092 | 3717 #ifdef NEW_GC |
| 3718 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3719 args[i]); | |
| 3720 #else /* not NEW_GC */ | |
| 814 | 3721 SPECBIND_FAST_UNSAFE (f->args[i], args[i]); |
| 3092 | 3722 #endif /* not NEW_GC */ |
| 814 | 3723 for (i = nargs; i < f->max_args; i++) |
| 3092 | 3724 #ifdef NEW_GC |
| 3725 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3726 Qnil); | |
| 3727 #else /* not NEW_GC */ | |
| 814 | 3728 SPECBIND_FAST_UNSAFE (f->args[i], Qnil); |
| 3092 | 3729 #endif /* not NEW_GC */ |
| 814 | 3730 } |
| 3731 else if (f->max_args == MANY) | |
| 3732 handle_compiled_function_with_and_rest (f, nargs, args); | |
| 3733 else | |
| 3734 { | |
| 3735 wrong_number_of_arguments: | |
| 3736 /* The actual printed compiled_function object is incomprehensible. | |
| 3737 Check the backtrace to see if we can get a more meaningful symbol. */ | |
| 3738 if (EQ (fun, indirect_function (*backtrace_list->function, 0))) | |
| 3739 fun = *backtrace_list->function; | |
| 3740 return Fsignal (Qwrong_number_of_arguments, | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
3741 list2 (fun, make_fixnum (nargs))); |
| 814 | 3742 } |
| 3743 | |
| 3744 { | |
| 3745 Lisp_Object value = | |
| 3746 execute_optimized_program ((Opbyte *) XOPAQUE_DATA (f->instructions), | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4905
diff
changeset
|
3747 #ifdef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4905
diff
changeset
|
3748 XOPAQUE_SIZE (f->instructions) / |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4905
diff
changeset
|
3749 sizeof (Opbyte), |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4905
diff
changeset
|
3750 #endif |
| 814 | 3751 f->stack_depth, |
| 3752 XVECTOR_DATA (f->constants)); | |
| 3753 | |
| 3754 /* The attempt to optimize this by only unbinding variables failed | |
| 3755 because using buffer-local variables as function parameters | |
| 3756 leads to specpdl_ptr->func != 0 */ | |
| 3757 /* UNBIND_TO_GCPRO_VARIABLES_ONLY (speccount, value); */ | |
| 3758 UNBIND_TO_GCPRO (speccount, value); | |
| 3759 return value; | |
| 3760 } | |
| 3761 } | |
| 3762 | |
| 428 | 3763 DEFUN ("eval", Feval, 1, 1, 0, /* |
| 3764 Evaluate FORM and return its value. | |
| 3765 */ | |
| 3766 (form)) | |
| 3767 { | |
| 3768 /* This function can GC */ | |
| 3769 Lisp_Object fun, val, original_fun, original_args; | |
| 3770 int nargs; | |
| 4162 | 3771 PROFILE_DECLARE(); |
| 428 | 3772 |
| 1318 | 3773 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS |
| 3774 check_proper_critical_section_lisp_protection (); | |
| 3775 #endif | |
| 3776 | |
| 3989 | 3777 if (!CONSP (form)) |
| 3778 { | |
| 3779 if (SYMBOLP (form)) | |
| 3780 { | |
| 3781 return Fsymbol_value (form); | |
| 3782 } | |
| 3783 | |
| 3784 return form; | |
| 3785 } | |
| 3786 | |
| 428 | 3787 /* I think this is a pretty safe place to call Lisp code, don't you? */ |
| 853 | 3788 while (!in_warnings && !NILP (Vpending_warnings) |
| 3789 /* well, perhaps not so safe after all! */ | |
| 3790 && !(inhibit_flags & INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY)) | |
| 428 | 3791 { |
| 3792 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; | |
| 1204 | 3793 Lisp_Object this_warning_cons, this_warning, class_, level, messij; |
| 853 | 3794 int speccount = internal_bind_int (&in_warnings, 1); |
| 3795 | |
| 428 | 3796 this_warning_cons = Vpending_warnings; |
| 3797 this_warning = XCAR (this_warning_cons); | |
| 3798 /* in case an error occurs in the warn function, at least | |
| 3799 it won't happen infinitely */ | |
| 3800 Vpending_warnings = XCDR (Vpending_warnings); | |
| 853 | 3801 free_cons (this_warning_cons); |
| 1204 | 3802 class_ = XCAR (this_warning); |
| 428 | 3803 level = XCAR (XCDR (this_warning)); |
| 3804 messij = XCAR (XCDR (XCDR (this_warning))); | |
| 3805 free_list (this_warning); | |
| 3806 | |
| 3807 if (NILP (Vpending_warnings)) | |
| 3808 Vpending_warnings_tail = Qnil; /* perhaps not strictly necessary, | |
| 3809 but safer */ | |
| 3810 | |
| 1204 | 3811 GCPRO4 (form, class_, level, messij); |
| 428 | 3812 if (!STRINGP (messij)) |
| 3813 messij = Fprin1_to_string (messij, Qnil); | |
| 1204 | 3814 call3 (Qdisplay_warning, class_, messij, level); |
| 428 | 3815 UNGCPRO; |
| 771 | 3816 unbind_to (speccount); |
| 428 | 3817 } |
| 3818 | |
| 3819 QUIT; | |
| 814 | 3820 if (need_to_garbage_collect) |
| 428 | 3821 { |
| 3822 struct gcpro gcpro1; | |
| 3823 GCPRO1 (form); | |
| 3092 | 3824 #ifdef NEW_GC |
| 3825 gc_incremental (); | |
| 3826 #else /* not NEW_GC */ | |
| 428 | 3827 garbage_collect_1 (); |
| 3092 | 3828 #endif /* not NEW_GC */ |
| 428 | 3829 UNGCPRO; |
| 3830 } | |
| 3831 | |
| 3832 if (++lisp_eval_depth > max_lisp_eval_depth) | |
| 3833 { | |
| 3834 if (max_lisp_eval_depth < 100) | |
| 3835 max_lisp_eval_depth = 100; | |
| 3836 if (lisp_eval_depth > max_lisp_eval_depth) | |
| 563 | 3837 stack_overflow ("Lisp nesting exceeds `max-lisp-eval-depth'", |
| 3838 Qunbound); | |
| 428 | 3839 } |
| 3840 | |
| 3841 /* We guaranteed CONSP (form) above */ | |
| 3842 original_fun = XCAR (form); | |
| 3843 original_args = XCDR (form); | |
| 3844 | |
| 3845 GET_EXTERNAL_LIST_LENGTH (original_args, nargs); | |
| 3846 | |
| 3847 backtrace.pdlcount = specpdl_depth(); | |
| 3848 backtrace.function = &original_fun; /* This also protects them from gc */ | |
| 3849 backtrace.args = &original_args; | |
| 3850 backtrace.nargs = UNEVALLED; | |
| 3851 backtrace.evalargs = 1; | |
| 3852 backtrace.debug_on_exit = 0; | |
| 1292 | 3853 backtrace.function_being_called = 0; |
| 428 | 3854 PUSH_BACKTRACE (backtrace); |
| 3855 | |
| 3856 if (debug_on_next_call) | |
| 3857 do_debug_on_call (Qt); | |
| 3858 | |
| 3859 /* At this point, only original_fun and original_args | |
| 3860 have values that will be used below. */ | |
| 3861 retry: | |
| 3989 | 3862 /* Optimise for no indirection. */ |
| 3863 fun = original_fun; | |
| 3864 if (SYMBOLP (fun) && !EQ (fun, Qunbound) | |
| 3865 && (fun = XSYMBOL (fun)->function, SYMBOLP (fun))) | |
| 3866 { | |
| 3867 fun = indirect_function(original_fun, 1); | |
| 3868 } | |
| 428 | 3869 |
| 3870 if (SUBRP (fun)) | |
| 3871 { | |
| 3872 Lisp_Subr *subr = XSUBR (fun); | |
| 3873 int max_args = subr->max_args; | |
| 3874 | |
| 3875 if (nargs < subr->min_args) | |
| 3876 goto wrong_number_of_arguments; | |
| 3877 | |
| 3878 if (max_args == UNEVALLED) /* Optimize for the common case */ | |
| 3879 { | |
| 3880 backtrace.evalargs = 0; | |
| 1292 | 3881 PROFILE_ENTER_FUNCTION (); |
| 428 | 3882 val = (((Lisp_Object (*) (Lisp_Object)) subr_function (subr)) |
| 3883 (original_args)); | |
| 1292 | 3884 PROFILE_EXIT_FUNCTION (); |
| 428 | 3885 } |
| 3886 else if (nargs <= max_args) | |
| 3887 { | |
| 3888 struct gcpro gcpro1; | |
| 3889 Lisp_Object args[SUBR_MAX_ARGS]; | |
| 3890 REGISTER Lisp_Object *p = args; | |
| 3891 | |
| 3892 GCPRO1 (args[0]); | |
| 3893 gcpro1.nvars = 0; | |
| 3894 | |
| 3895 { | |
| 3896 LIST_LOOP_2 (arg, original_args) | |
| 3897 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
3898 *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); |
| 428 | 3899 gcpro1.nvars++; |
| 3900 } | |
| 3901 } | |
| 3902 | |
| 3903 /* &optional args default to nil. */ | |
| 3904 while (p - args < max_args) | |
| 3905 *p++ = Qnil; | |
| 3906 | |
| 3907 backtrace.args = args; | |
| 3908 backtrace.nargs = nargs; | |
| 3909 | |
| 1292 | 3910 PROFILE_ENTER_FUNCTION (); |
| 428 | 3911 FUNCALL_SUBR (val, subr, args, max_args); |
| 1292 | 3912 PROFILE_EXIT_FUNCTION (); |
| 428 | 3913 |
| 3914 UNGCPRO; | |
| 3915 } | |
| 3916 else if (max_args == MANY) | |
| 3917 { | |
| 3918 /* Pass a vector of evaluated arguments */ | |
| 3919 struct gcpro gcpro1; | |
| 3920 Lisp_Object *args = alloca_array (Lisp_Object, nargs); | |
| 3921 REGISTER Lisp_Object *p = args; | |
| 3922 | |
| 3923 GCPRO1 (args[0]); | |
| 3924 gcpro1.nvars = 0; | |
| 3925 | |
| 3926 { | |
| 3927 LIST_LOOP_2 (arg, original_args) | |
| 3928 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
3929 *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); |
| 428 | 3930 gcpro1.nvars++; |
| 3931 } | |
| 3932 } | |
| 3933 | |
| 3934 backtrace.args = args; | |
| 3935 backtrace.nargs = nargs; | |
| 3936 | |
| 1292 | 3937 PROFILE_ENTER_FUNCTION (); |
| 428 | 3938 val = (((Lisp_Object (*) (int, Lisp_Object *)) subr_function (subr)) |
| 3939 (nargs, args)); | |
| 1292 | 3940 PROFILE_EXIT_FUNCTION (); |
| 428 | 3941 |
| 3942 UNGCPRO; | |
| 3943 } | |
| 3944 else | |
| 3945 { | |
| 3946 wrong_number_of_arguments: | |
| 440 | 3947 val = signal_wrong_number_of_arguments_error (original_fun, nargs); |
| 428 | 3948 } |
| 3949 } | |
| 3950 else if (COMPILED_FUNCTIONP (fun)) | |
| 3951 { | |
| 3952 struct gcpro gcpro1; | |
| 3953 Lisp_Object *args = alloca_array (Lisp_Object, nargs); | |
| 3954 REGISTER Lisp_Object *p = args; | |
| 3955 | |
| 3956 GCPRO1 (args[0]); | |
| 3957 gcpro1.nvars = 0; | |
| 3958 | |
| 3959 { | |
| 3960 LIST_LOOP_2 (arg, original_args) | |
| 3961 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
3962 *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); |
| 428 | 3963 gcpro1.nvars++; |
| 3964 } | |
| 3965 } | |
| 3966 | |
| 3967 backtrace.args = args; | |
| 3968 backtrace.nargs = nargs; | |
| 3969 backtrace.evalargs = 0; | |
| 3970 | |
| 1292 | 3971 PROFILE_ENTER_FUNCTION (); |
| 428 | 3972 val = funcall_compiled_function (fun, nargs, args); |
| 1292 | 3973 PROFILE_EXIT_FUNCTION (); |
| 428 | 3974 |
| 3975 /* Do the debug-on-exit now, while args is still GCPROed. */ | |
| 3976 if (backtrace.debug_on_exit) | |
| 3977 val = do_debug_on_exit (val); | |
| 3978 /* Don't do it again when we return to eval. */ | |
| 3979 backtrace.debug_on_exit = 0; | |
| 3980 | |
| 3981 UNGCPRO; | |
| 3982 } | |
| 3983 else if (CONSP (fun)) | |
| 3984 { | |
| 3985 Lisp_Object funcar = XCAR (fun); | |
| 3986 | |
| 3987 if (EQ (funcar, Qautoload)) | |
| 3988 { | |
| 970 | 3989 /* do_autoload GCPROs both arguments */ |
| 428 | 3990 do_autoload (fun, original_fun); |
| 3991 goto retry; | |
| 3992 } | |
| 3993 else if (EQ (funcar, Qmacro)) | |
| 3994 { | |
| 1292 | 3995 PROFILE_ENTER_FUNCTION (); |
| 428 | 3996 val = Feval (apply1 (XCDR (fun), original_args)); |
| 1292 | 3997 PROFILE_EXIT_FUNCTION (); |
| 428 | 3998 } |
| 3999 else if (EQ (funcar, Qlambda)) | |
| 4000 { | |
| 4001 struct gcpro gcpro1; | |
| 4002 Lisp_Object *args = alloca_array (Lisp_Object, nargs); | |
| 4003 REGISTER Lisp_Object *p = args; | |
| 4004 | |
| 4005 GCPRO1 (args[0]); | |
| 4006 gcpro1.nvars = 0; | |
| 4007 | |
| 4008 { | |
| 4009 LIST_LOOP_2 (arg, original_args) | |
| 4010 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4011 *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); |
| 428 | 4012 gcpro1.nvars++; |
| 4013 } | |
| 4014 } | |
| 4015 | |
| 4016 UNGCPRO; | |
| 4017 | |
| 4018 backtrace.args = args; /* this also GCPROs `args' */ | |
| 4019 backtrace.nargs = nargs; | |
| 4020 backtrace.evalargs = 0; | |
| 4021 | |
| 1292 | 4022 PROFILE_ENTER_FUNCTION (); |
| 428 | 4023 val = funcall_lambda (fun, nargs, args); |
| 1292 | 4024 PROFILE_EXIT_FUNCTION (); |
| 428 | 4025 |
| 4026 /* Do the debug-on-exit now, while args is still GCPROed. */ | |
| 4027 if (backtrace.debug_on_exit) | |
| 4028 val = do_debug_on_exit (val); | |
| 4029 /* Don't do it again when we return to eval. */ | |
| 4030 backtrace.debug_on_exit = 0; | |
| 4031 } | |
| 4032 else | |
| 4033 { | |
| 4034 goto invalid_function; | |
| 4035 } | |
| 4036 } | |
| 4104 | 4037 else if (UNBOUNDP (fun)) |
| 4038 { | |
| 4039 val = signal_void_function_error (original_fun); | |
| 4040 } | |
| 4041 else /* ! (SUBRP (fun) || COMPILED_FUNCTIONP (fun) || CONSP (fun) | |
| 4042 UNBOUNDP (fun)) */ | |
| 428 | 4043 { |
| 4044 invalid_function: | |
| 436 | 4045 val = signal_invalid_function_error (fun); |
| 428 | 4046 } |
| 4047 | |
| 4048 lisp_eval_depth--; | |
| 4049 if (backtrace.debug_on_exit) | |
| 4050 val = do_debug_on_exit (val); | |
| 4051 POP_BACKTRACE (backtrace); | |
| 4052 return val; | |
| 4053 } | |
| 4054 | |
| 4055 | |
| 1111 | 4056 |
| 4057 static void | |
| 4058 run_post_gc_hook (void) | |
| 4059 { | |
| 4060 Lisp_Object args[2]; | |
| 4061 | |
| 4062 args[0] = Qpost_gc_hook; | |
| 4063 args[1] = Fcons (Fcons (Qfinalize_list, zap_finalize_list ()), Qnil); | |
| 4064 | |
| 4065 run_hook_with_args_trapping_problems | |
| 1333 | 4066 (Qgarbage_collecting, 2, args, RUN_HOOKS_TO_COMPLETION, |
| 1111 | 4067 INHIBIT_QUIT | NO_INHIBIT_ERRORS); |
| 4068 } | |
| 4069 | |
| 428 | 4070 DEFUN ("funcall", Ffuncall, 1, MANY, 0, /* |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
4071 Call FUNCTION as a function, passing the remaining arguments to it. |
| 428 | 4072 Thus, (funcall 'cons 'x 'y) returns (x . y). |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
4073 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
4074 arguments: (FUNCTION &rest ARGS) |
| 428 | 4075 */ |
| 4076 (int nargs, Lisp_Object *args)) | |
| 4077 { | |
| 4078 /* This function can GC */ | |
| 4079 Lisp_Object fun; | |
| 4080 Lisp_Object val; | |
| 4162 | 4081 PROFILE_DECLARE(); |
| 428 | 4082 int fun_nargs = nargs - 1; |
| 4083 Lisp_Object *fun_args = args + 1; | |
| 4084 | |
| 1318 | 4085 /* QUIT will check for proper redisplay wrapping */ |
| 4086 | |
| 428 | 4087 QUIT; |
| 851 | 4088 |
| 4089 if (funcall_allocation_flag) | |
| 4090 { | |
| 4091 if (need_to_garbage_collect) | |
| 4092 /* Callers should gcpro lexpr args */ | |
| 3092 | 4093 #ifdef NEW_GC |
| 4094 gc_incremental (); | |
| 4095 #else /* not NEW_GC */ | |
| 851 | 4096 garbage_collect_1 (); |
| 3092 | 4097 #endif /* not NEW_GC */ |
| 851 | 4098 if (need_to_check_c_alloca) |
| 4099 { | |
| 4100 if (++funcall_alloca_count >= MAX_FUNCALLS_BETWEEN_ALLOCA_CLEANUP) | |
| 4101 { | |
| 4102 xemacs_c_alloca (0); | |
| 4103 funcall_alloca_count = 0; | |
| 4104 } | |
| 4105 } | |
| 887 | 4106 if (need_to_signal_post_gc) |
| 4107 { | |
| 4108 need_to_signal_post_gc = 0; | |
| 1111 | 4109 recompute_funcall_allocation_flag (); |
| 3263 | 4110 #ifdef NEW_GC |
| 4111 run_finalizers (); | |
| 4112 #endif /* NEW_GC */ | |
| 1111 | 4113 run_post_gc_hook (); |
| 887 | 4114 } |
| 851 | 4115 } |
| 428 | 4116 |
| 4117 if (++lisp_eval_depth > max_lisp_eval_depth) | |
| 4118 { | |
| 4119 if (max_lisp_eval_depth < 100) | |
| 4120 max_lisp_eval_depth = 100; | |
| 4121 if (lisp_eval_depth > max_lisp_eval_depth) | |
| 563 | 4122 stack_overflow ("Lisp nesting exceeds `max-lisp-eval-depth'", |
| 4123 Qunbound); | |
| 428 | 4124 } |
| 4125 | |
| 1292 | 4126 backtrace.pdlcount = specpdl_depth (); |
| 428 | 4127 backtrace.function = &args[0]; |
| 4128 backtrace.args = fun_args; | |
| 4129 backtrace.nargs = fun_nargs; | |
| 4130 backtrace.evalargs = 0; | |
| 4131 backtrace.debug_on_exit = 0; | |
| 1292 | 4132 backtrace.function_being_called = 0; |
| 428 | 4133 PUSH_BACKTRACE (backtrace); |
| 4134 | |
| 4135 if (debug_on_next_call) | |
| 4136 do_debug_on_call (Qlambda); | |
| 4137 | |
| 4138 retry: | |
| 4139 | |
| 4140 fun = args[0]; | |
| 4141 | |
| 4142 /* We could call indirect_function directly, but profiling shows | |
| 4143 this is worth optimizing by partially unrolling the loop. */ | |
| 4144 if (SYMBOLP (fun)) | |
| 4145 { | |
| 4146 fun = XSYMBOL (fun)->function; | |
| 4147 if (SYMBOLP (fun)) | |
| 4148 { | |
| 4149 fun = XSYMBOL (fun)->function; | |
| 4150 if (SYMBOLP (fun)) | |
| 4151 fun = indirect_function (fun, 1); | |
| 4152 } | |
| 4153 } | |
| 4154 | |
| 4155 if (SUBRP (fun)) | |
| 4156 { | |
| 4157 Lisp_Subr *subr = XSUBR (fun); | |
| 4158 int max_args = subr->max_args; | |
| 4159 Lisp_Object spacious_args[SUBR_MAX_ARGS]; | |
| 4160 | |
| 4161 if (fun_nargs == max_args) /* Optimize for the common case */ | |
| 4162 { | |
| 4163 funcall_subr: | |
| 1292 | 4164 PROFILE_ENTER_FUNCTION (); |
| 428 | 4165 FUNCALL_SUBR (val, subr, fun_args, max_args); |
| 1292 | 4166 PROFILE_EXIT_FUNCTION (); |
| 428 | 4167 } |
| 436 | 4168 else if (fun_nargs < subr->min_args) |
| 4169 { | |
| 4170 goto wrong_number_of_arguments; | |
| 4171 } | |
| 428 | 4172 else if (fun_nargs < max_args) |
| 4173 { | |
| 4174 Lisp_Object *p = spacious_args; | |
| 4175 | |
| 4176 /* Default optionals to nil */ | |
| 4177 while (fun_nargs--) | |
| 4178 *p++ = *fun_args++; | |
| 4179 while (p - spacious_args < max_args) | |
| 4180 *p++ = Qnil; | |
| 4181 | |
| 4182 fun_args = spacious_args; | |
| 4183 goto funcall_subr; | |
| 4184 } | |
| 4185 else if (max_args == MANY) | |
| 4186 { | |
| 1292 | 4187 PROFILE_ENTER_FUNCTION (); |
| 436 | 4188 val = SUBR_FUNCTION (subr, MANY) (fun_nargs, fun_args); |
| 1292 | 4189 PROFILE_EXIT_FUNCTION (); |
| 428 | 4190 } |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
4191 else if (max_args == UNEVALLED) /* Can't funcall a special operator */ |
| 428 | 4192 { |
|
5222
18c0b5909d16
Use keywords in structure syntax; new #define, NEED_TO_HANDLE_21_4_CODE 1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5207
diff
changeset
|
4193 |
|
18c0b5909d16
Use keywords in structure syntax; new #define, NEED_TO_HANDLE_21_4_CODE 1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5207
diff
changeset
|
4194 #ifdef NEED_TO_HANDLE_21_4_CODE |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4195 /* Ugh, ugh, ugh. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4196 if (EQ (fun, XSYMBOL_FUNCTION (Qthrow))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4197 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4198 args[0] = Qobsolete_throw; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4199 goto retry; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4200 } |
|
5222
18c0b5909d16
Use keywords in structure syntax; new #define, NEED_TO_HANDLE_21_4_CODE 1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5207
diff
changeset
|
4201 #endif /* NEED_TO_HANDLE_21_4_CODE */ |
|
18c0b5909d16
Use keywords in structure syntax; new #define, NEED_TO_HANDLE_21_4_CODE 1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5207
diff
changeset
|
4202 |
| 428 | 4203 goto invalid_function; |
| 4204 } | |
| 4205 else | |
| 4206 { | |
| 4207 wrong_number_of_arguments: | |
| 436 | 4208 val = signal_wrong_number_of_arguments_error (fun, fun_nargs); |
| 428 | 4209 } |
| 4210 } | |
| 4211 else if (COMPILED_FUNCTIONP (fun)) | |
| 4212 { | |
| 1292 | 4213 PROFILE_ENTER_FUNCTION (); |
| 428 | 4214 val = funcall_compiled_function (fun, fun_nargs, fun_args); |
| 1292 | 4215 PROFILE_EXIT_FUNCTION (); |
| 428 | 4216 } |
| 4217 else if (CONSP (fun)) | |
| 4218 { | |
| 4219 Lisp_Object funcar = XCAR (fun); | |
| 4220 | |
| 4221 if (EQ (funcar, Qlambda)) | |
| 4222 { | |
| 1292 | 4223 PROFILE_ENTER_FUNCTION (); |
| 428 | 4224 val = funcall_lambda (fun, fun_nargs, fun_args); |
| 1292 | 4225 PROFILE_EXIT_FUNCTION (); |
| 428 | 4226 } |
| 4227 else if (EQ (funcar, Qautoload)) | |
| 4228 { | |
| 970 | 4229 /* do_autoload GCPROs both arguments */ |
| 428 | 4230 do_autoload (fun, args[0]); |
| 4231 goto retry; | |
| 4232 } | |
| 4233 else /* Can't funcall a macro */ | |
| 4234 { | |
| 4235 goto invalid_function; | |
| 4236 } | |
| 4237 } | |
| 4238 else if (UNBOUNDP (fun)) | |
| 4239 { | |
| 436 | 4240 val = signal_void_function_error (args[0]); |
| 428 | 4241 } |
| 4242 else | |
| 4243 { | |
| 4244 invalid_function: | |
| 436 | 4245 val = signal_invalid_function_error (fun); |
| 428 | 4246 } |
| 4247 | |
| 4248 lisp_eval_depth--; | |
| 4249 if (backtrace.debug_on_exit) | |
| 4250 val = do_debug_on_exit (val); | |
| 4251 POP_BACKTRACE (backtrace); | |
| 4252 return val; | |
| 4253 } | |
| 4254 | |
| 4255 DEFUN ("functionp", Ffunctionp, 1, 1, 0, /* | |
| 4256 Return t if OBJECT can be called as a function, else nil. | |
| 4257 A function is an object that can be applied to arguments, | |
| 4258 using for example `funcall' or `apply'. | |
| 4259 */ | |
| 4260 (object)) | |
| 4261 { | |
| 4262 if (SYMBOLP (object)) | |
| 4263 object = indirect_function (object, 0); | |
| 4264 | |
|
4795
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4744
diff
changeset
|
4265 if (COMPILED_FUNCTIONP (object) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4744
diff
changeset
|
4266 || (SUBRP (object) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4744
diff
changeset
|
4267 && (XSUBR (object)->max_args != UNEVALLED))) |
| 919 | 4268 return Qt; |
| 4269 if (CONSP (object)) | |
| 4270 { | |
| 4271 Lisp_Object car = XCAR (object); | |
| 4272 if (EQ (car, Qlambda)) | |
| 4273 return Qt; | |
| 4274 if (EQ (car, Qautoload) | |
|
4795
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4744
diff
changeset
|
4275 && NILP (Fcar_safe (Fcdr_safe(Fcdr_safe |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4744
diff
changeset
|
4276 (Fcdr_safe (XCDR (object))))))) |
| 919 | 4277 return Qt; |
| 4278 } | |
| 4279 return Qnil; | |
| 428 | 4280 } |
| 4281 | |
| 4282 static Lisp_Object | |
| 4283 function_argcount (Lisp_Object function, int function_min_args_p) | |
| 4284 { | |
| 4285 Lisp_Object orig_function = function; | |
| 4286 Lisp_Object arglist; | |
| 4287 | |
| 4288 retry: | |
| 4289 | |
| 4290 if (SYMBOLP (function)) | |
| 4291 function = indirect_function (function, 1); | |
| 4292 | |
| 4293 if (SUBRP (function)) | |
| 4294 { | |
| 442 | 4295 /* Using return with the ?: operator tickles a DEC CC compiler bug. */ |
| 4296 if (function_min_args_p) | |
| 4297 return Fsubr_min_args (function); | |
| 4298 else | |
| 4299 return Fsubr_max_args (function); | |
| 428 | 4300 } |
| 4301 else if (COMPILED_FUNCTIONP (function)) | |
| 4302 { | |
| 814 | 4303 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (function); |
| 4304 | |
| 1737 | 4305 if (!OPAQUEP (f->instructions)) |
| 4306 /* Lazily munge the instructions into a more efficient form */ | |
| 4307 /* Needed to set max_args */ | |
| 4308 optimize_compiled_function (function); | |
| 4309 | |
| 814 | 4310 if (function_min_args_p) |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
4311 return make_fixnum (f->min_args); |
| 814 | 4312 else if (f->max_args == MANY) |
| 4313 return Qnil; | |
| 4314 else | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
4315 return make_fixnum (f->max_args); |
| 428 | 4316 } |
| 4317 else if (CONSP (function)) | |
| 4318 { | |
| 4319 Lisp_Object funcar = XCAR (function); | |
| 4320 | |
| 4321 if (EQ (funcar, Qmacro)) | |
| 4322 { | |
| 4323 function = XCDR (function); | |
| 4324 goto retry; | |
| 4325 } | |
| 4326 else if (EQ (funcar, Qautoload)) | |
| 4327 { | |
| 970 | 4328 /* do_autoload GCPROs both arguments */ |
| 428 | 4329 do_autoload (function, orig_function); |
| 442 | 4330 function = orig_function; |
| 428 | 4331 goto retry; |
| 4332 } | |
| 4333 else if (EQ (funcar, Qlambda)) | |
| 4334 { | |
| 4335 arglist = Fcar (XCDR (function)); | |
| 4336 } | |
| 4337 else | |
| 4338 { | |
| 4339 goto invalid_function; | |
| 4340 } | |
| 4341 } | |
| 4342 else | |
| 4343 { | |
| 4344 invalid_function: | |
| 442 | 4345 return signal_invalid_function_error (orig_function); |
| 428 | 4346 } |
| 4347 | |
| 4348 { | |
| 4349 int argcount = 0; | |
| 4350 | |
| 4351 EXTERNAL_LIST_LOOP_2 (arg, arglist) | |
| 4352 { | |
| 4353 if (EQ (arg, Qand_optional)) | |
| 4354 { | |
| 4355 if (function_min_args_p) | |
| 4356 break; | |
| 4357 } | |
| 4358 else if (EQ (arg, Qand_rest)) | |
| 4359 { | |
| 4360 if (function_min_args_p) | |
| 4361 break; | |
| 4362 else | |
| 4363 return Qnil; | |
| 4364 } | |
| 4365 else | |
| 4366 { | |
| 4367 argcount++; | |
| 4368 } | |
| 4369 } | |
| 4370 | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
4371 return make_fixnum (argcount); |
| 428 | 4372 } |
| 4373 } | |
| 4374 | |
| 4375 DEFUN ("function-min-args", Ffunction_min_args, 1, 1, 0, /* | |
| 617 | 4376 Return the minimum number of arguments a function may be called with. |
| 428 | 4377 The function may be any form that can be passed to `funcall', |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
4378 any special operator, or any macro. |
| 853 | 4379 |
| 4380 To check if a function can be called with a specified number of | |
| 4381 arguments, use `function-allows-args'. | |
| 428 | 4382 */ |
| 4383 (function)) | |
| 4384 { | |
| 4385 return function_argcount (function, 1); | |
| 4386 } | |
| 4387 | |
| 4388 DEFUN ("function-max-args", Ffunction_max_args, 1, 1, 0, /* | |
| 617 | 4389 Return the maximum number of arguments a function may be called with. |
| 428 | 4390 The function may be any form that can be passed to `funcall', |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
4391 any special operator, or any macro. |
| 428 | 4392 If the function takes an arbitrary number of arguments or is |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
4393 a built-in special operator, nil is returned. |
| 853 | 4394 |
| 4395 To check if a function can be called with a specified number of | |
| 4396 arguments, use `function-allows-args'. | |
| 428 | 4397 */ |
| 4398 (function)) | |
| 4399 { | |
| 4400 return function_argcount (function, 0); | |
| 4401 } | |
| 4402 | |
| 4403 | |
| 4404 DEFUN ("apply", Fapply, 2, MANY, 0, /* | |
| 4405 Call FUNCTION with the remaining args, using the last arg as a list of args. | |
| 4406 Thus, (apply '+ 1 2 '(3 4)) returns 10. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
4407 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
4408 arguments: (FUNCTION &rest ARGS) |
| 428 | 4409 */ |
| 4410 (int nargs, Lisp_Object *args)) | |
| 4411 { | |
| 4412 /* This function can GC */ | |
| 4413 Lisp_Object fun = args[0]; | |
| 4414 Lisp_Object spread_arg = args [nargs - 1]; | |
| 4415 int numargs; | |
| 4416 int funcall_nargs; | |
| 4417 | |
| 4418 GET_EXTERNAL_LIST_LENGTH (spread_arg, numargs); | |
| 4419 | |
| 4420 if (numargs == 0) | |
| 4421 /* (apply foo 0 1 '()) */ | |
| 4422 return Ffuncall (nargs - 1, args); | |
| 4423 else if (numargs == 1) | |
| 4424 { | |
| 4425 /* (apply foo 0 1 '(2)) */ | |
| 4426 args [nargs - 1] = XCAR (spread_arg); | |
| 4427 return Ffuncall (nargs, args); | |
| 4428 } | |
| 4429 | |
| 4430 /* -1 for function, -1 for spread arg */ | |
| 4431 numargs = nargs - 2 + numargs; | |
| 4432 /* +1 for function */ | |
| 4433 funcall_nargs = 1 + numargs; | |
| 4434 | |
| 4435 if (SYMBOLP (fun)) | |
| 4436 fun = indirect_function (fun, 0); | |
| 4437 | |
| 4438 if (SUBRP (fun)) | |
| 4439 { | |
| 4440 Lisp_Subr *subr = XSUBR (fun); | |
| 4441 int max_args = subr->max_args; | |
| 4442 | |
| 4443 if (numargs < subr->min_args | |
| 4444 || (max_args >= 0 && max_args < numargs)) | |
| 4445 { | |
| 4446 /* Let funcall get the error */ | |
| 4447 } | |
| 4448 else if (max_args > numargs) | |
| 4449 { | |
| 4450 /* Avoid having funcall cons up yet another new vector of arguments | |
| 4451 by explicitly supplying nil's for optional values */ | |
| 4452 funcall_nargs += (max_args - numargs); | |
| 4453 } | |
| 4454 } | |
| 4455 else if (UNBOUNDP (fun)) | |
| 4456 { | |
| 4457 /* Let funcall get the error */ | |
| 4458 fun = args[0]; | |
| 4459 } | |
| 4460 | |
| 4461 { | |
| 4462 REGISTER int i; | |
| 4463 Lisp_Object *funcall_args = alloca_array (Lisp_Object, funcall_nargs); | |
| 4464 struct gcpro gcpro1; | |
| 4465 | |
| 4466 GCPRO1 (*funcall_args); | |
| 4467 gcpro1.nvars = funcall_nargs; | |
| 4468 | |
| 4469 /* Copy in the unspread args */ | |
| 4470 memcpy (funcall_args, args, (nargs - 1) * sizeof (Lisp_Object)); | |
| 4471 /* Spread the last arg we got. Its first element goes in | |
| 4472 the slot that it used to occupy, hence this value of I. */ | |
| 4473 for (i = nargs - 1; | |
| 4474 !NILP (spread_arg); /* i < 1 + numargs */ | |
| 4475 i++, spread_arg = XCDR (spread_arg)) | |
| 4476 { | |
| 4477 funcall_args [i] = XCAR (spread_arg); | |
| 4478 } | |
| 4479 /* Supply nil for optional args (to subrs) */ | |
| 4480 for (; i < funcall_nargs; i++) | |
| 4481 funcall_args[i] = Qnil; | |
| 4482 | |
| 4483 | |
| 4484 RETURN_UNGCPRO (Ffuncall (funcall_nargs, funcall_args)); | |
| 4485 } | |
| 4486 } | |
| 4487 | |
| 4488 /* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and | |
| 4489 return the result of evaluation. */ | |
| 4490 | |
| 4491 static Lisp_Object | |
| 4492 funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object args[]) | |
| 4493 { | |
| 4494 /* This function can GC */ | |
| 442 | 4495 Lisp_Object arglist, body, tail; |
| 428 | 4496 int speccount = specpdl_depth(); |
| 4497 REGISTER int i = 0; | |
| 4498 | |
| 4499 tail = XCDR (fun); | |
| 4500 | |
| 4501 if (!CONSP (tail)) | |
| 4502 goto invalid_function; | |
| 4503 | |
| 4504 arglist = XCAR (tail); | |
| 4505 body = XCDR (tail); | |
| 4506 | |
| 4507 { | |
| 4508 int optional = 0, rest = 0; | |
| 4509 | |
| 442 | 4510 EXTERNAL_LIST_LOOP_2 (symbol, arglist) |
| 428 | 4511 { |
| 4512 if (!SYMBOLP (symbol)) | |
| 4513 goto invalid_function; | |
| 4514 if (EQ (symbol, Qand_rest)) | |
| 4515 rest = 1; | |
| 4516 else if (EQ (symbol, Qand_optional)) | |
| 4517 optional = 1; | |
| 4518 else if (rest) | |
| 4519 { | |
| 4520 specbind (symbol, Flist (nargs - i, &args[i])); | |
| 4521 i = nargs; | |
| 4522 } | |
| 4523 else if (i < nargs) | |
| 4524 specbind (symbol, args[i++]); | |
| 4525 else if (!optional) | |
| 4526 goto wrong_number_of_arguments; | |
| 4527 else | |
| 4528 specbind (symbol, Qnil); | |
| 4529 } | |
| 4530 } | |
| 4531 | |
| 4532 if (i < nargs) | |
| 4533 goto wrong_number_of_arguments; | |
| 4534 | |
| 771 | 4535 return unbind_to_1 (speccount, Fprogn (body)); |
| 428 | 4536 |
| 4537 wrong_number_of_arguments: | |
| 436 | 4538 return signal_wrong_number_of_arguments_error (fun, nargs); |
| 428 | 4539 |
| 4540 invalid_function: | |
| 436 | 4541 return signal_invalid_function_error (fun); |
| 428 | 4542 } |
| 4543 | |
| 4544 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4545 /* Multiple values. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4546 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4547 A multiple value object is returned by #'values if: |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4548 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4549 -- The number of arguments to #'values is not one, and: |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
4550 -- Some special operator in the call stack is prepared to handle more than |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4551 one multiple value. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4552 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4553 The return value of #'values-list is analogous to that of #'values. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4554 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4555 Henry Baker, in https://eprints.kfupm.edu.sa/31898/1/31898.pdf ("CONS |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4556 Should not CONS its Arguments, or, a Lazy Alloc is a Smart Alloc", ACM |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4557 Sigplan Notices 27,3 (March 1992),24-34.) says it should be possible to |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4558 allocate Common Lisp multiple-value objects on the stack, but this |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4559 assumes that variable-length records can be allocated on the stack, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4560 something not true for us. As far as I can tell, it also ignores the |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4561 contexts where multiple-values need to be thrown, or maybe it thinks such |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4562 objects should be converted to heap allocation at that point. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4563 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4564 The specific multiple values saved and returned depend on how many |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
4565 multiple-values special operators in the stack are interested in; for |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4566 example, if #'multiple-value-call is somewhere in the call stack, all |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4567 values passed to #'values will be saved and returned. If an expansion of |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4568 #'multiple-value-setq with 10 SYMS is the only part of the call stack |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4569 interested in multiple values, then a maximum of ten multiple values will |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4570 be saved and returned. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4571 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4572 (#'throw passes back multiple values in its VALUE argument; this is why |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4573 we can't just take the details of the most immediate |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4574 #'multiple-value-{whatever} call to work out which values to save, we |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4575 need to look at the whole stack, or, equivalently, the dynamic variables |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4576 we set to reflect the whole stack.) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4577 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4578 The first value passed to #'values will always be saved, since that is |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4579 needed to convert a multiple value object into a single value object, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4580 something that is normally necessary independent of how many functions in |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4581 the call stack are interested in multiple values. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4582 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4583 However many values (for values of "however many" that are not one) are |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4584 saved and restored, the multiple value object knows how many arguments it |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4585 would contain were none to have been discarded, and will indicate this |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4586 on being printed from within GDB. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4587 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4588 In lisp-interaction-mode, no multiple values should be discarded (unless |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4589 they need to be for the sake of the correctness of the program); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4590 #'eval-interactive-with-multiple-value-list in lisp-mode.el wraps its |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4591 #'eval calls with #'multiple-value-list calls to avoid this. This means |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4592 that there is a small performance and memory penalty for code evaluated |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4593 in *scratch*; use M-: EXPRESSION RET if you really need to avoid |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4594 this. Lisp code execution that is not ultimately from hitting C-j in |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4595 *scratch*--that is, the vast vast majority of Lisp code execution--does |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4596 not have this penalty. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4597 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4598 Probably the most important aspect of multiple values is stated with |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4599 admirable clarity by CLTL2: |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4600 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4601 "No matter how many values a form produces, if the form is an argument |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4602 form in a function call, then exactly one value (the first one) is |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4603 used." |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4604 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4605 This means that most contexts, most of the time, will never see multiple |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4606 values. There are important exceptions; search the web for that text in |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4607 quotation marks and read the related chapter. This code handles all of |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4608 them, to my knowledge. Aidan Kehoe, Mon Mar 16 00:17:39 GMT 2009. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4609 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4610 static Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4611 make_multiple_value (Lisp_Object first_value, Elemcount count, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4612 Elemcount first_desired, Elemcount upper_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4613 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4614 Bytecount sizem; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4615 struct multiple_value *mv; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4616 Elemcount i, allocated_count; |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
4617 Lisp_Object mvobj; |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4618 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4619 assert (count != 1); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4620 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4621 if (1 != upper_limit && (0 == first_desired)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4622 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4623 /* We always allocate element zero, and that's taken into account when |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4624 working out allocated_count: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4625 first_desired = 1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4626 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4627 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4628 if (first_desired >= count) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4629 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4630 /* We can't pass anything back that our caller is interested in. Only |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4631 allocate for the first argument. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4632 allocated_count = 1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4633 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4634 else |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4635 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4636 allocated_count = 1 + ((upper_limit > count ? count : upper_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4637 - first_desired); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4638 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4639 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4640 sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (multiple_value, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4641 Lisp_Object, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4642 contents, allocated_count); |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
4643 mvobj = ALLOC_SIZED_LISP_OBJECT (sizem, multiple_value); |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
4644 mv = XMULTIPLE_VALUE (mvobj); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4645 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4646 mv->count = count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4647 mv->first_desired = first_desired; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4648 mv->allocated_count = allocated_count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4649 mv->contents[0] = first_value; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4650 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4651 for (i = first_desired; i < upper_limit && i < count; ++i) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4652 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4653 mv->contents[1 + (i - first_desired)] = Qunbound; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4654 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4655 |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
4656 return mvobj; |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4657 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4658 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4659 void |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4660 multiple_value_aset (Lisp_Object obj, Elemcount index, Lisp_Object value) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4661 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4662 struct multiple_value *mv = XMULTIPLE_VALUE (obj); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4663 Elemcount first_desired = mv->first_desired; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4664 Elemcount allocated_count = mv->allocated_count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4665 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4666 if (index != 0 && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4667 (index < first_desired || index >= (first_desired + allocated_count))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4668 { |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
4669 args_out_of_range (make_fixnum (first_desired), |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
4670 make_fixnum (first_desired + allocated_count)); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4671 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4672 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4673 mv->contents[index == 0 ? 0 : 1 + (index - first_desired)] = value; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4674 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4675 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4676 Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4677 multiple_value_aref (Lisp_Object obj, Elemcount index) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4678 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4679 struct multiple_value *mv = XMULTIPLE_VALUE (obj); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4680 Elemcount first_desired = mv->first_desired; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4681 Elemcount allocated_count = mv->allocated_count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4682 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4683 if (index != 0 && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4684 (index < first_desired || index >= (first_desired + allocated_count))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4685 { |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
4686 args_out_of_range (make_fixnum (first_desired), |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
4687 make_fixnum (first_desired + allocated_count)); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4688 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4689 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4690 return mv->contents[index == 0 ? 0 : 1 + (index - first_desired)]; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4691 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4692 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4693 static void |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4694 print_multiple_value (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4695 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4696 struct multiple_value *mv = XMULTIPLE_VALUE (obj); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4697 Elemcount first_desired = mv->first_desired; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4698 Elemcount allocated_count = mv->allocated_count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4699 Elemcount count = mv->count, index; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4700 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4701 if (print_readably) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4702 { |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
4703 printing_unreadable_object_fmt ("#<multiple values 0x%x>", |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
4704 LISP_OBJECT_UID (obj)); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4705 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4706 |
|
5086
47bcef7b0b44
Print multiple values with #<INTERNAL OBJECT (XEmacs bug?) ...>, too
Aidan Kehoe <kehoea@parhasard.net>
parents:
5084
diff
changeset
|
4707 write_fmt_string (printcharfun, |
|
47bcef7b0b44
Print multiple values with #<INTERNAL OBJECT (XEmacs bug?) ...>, too
Aidan Kehoe <kehoea@parhasard.net>
parents:
5084
diff
changeset
|
4708 "#<INTERNAL OBJECT (XEmacs bug?) %d multiple values," |
|
47bcef7b0b44
Print multiple values with #<INTERNAL OBJECT (XEmacs bug?) ...>, too
Aidan Kehoe <kehoea@parhasard.net>
parents:
5084
diff
changeset
|
4709 " data (", count); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4710 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4711 for (index = 0; index < count;) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4712 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4713 if (index != 0 && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4714 (index < first_desired || |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4715 index >= (first_desired + (allocated_count - 1)))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4716 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4717 write_fmt_string (printcharfun, "#<discarded-multiple-value %d>", |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4718 index); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4719 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4720 else |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4721 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4722 print_internal (multiple_value_aref (obj, index), |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4723 printcharfun, escapeflag); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4724 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4725 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4726 ++index; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4727 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4728 if (count > 1 && index < count) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4729 { |
|
5086
47bcef7b0b44
Print multiple values with #<INTERNAL OBJECT (XEmacs bug?) ...>, too
Aidan Kehoe <kehoea@parhasard.net>
parents:
5084
diff
changeset
|
4730 write_ascstring (printcharfun, " "); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4731 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4732 } |
|
5086
47bcef7b0b44
Print multiple values with #<INTERNAL OBJECT (XEmacs bug?) ...>, too
Aidan Kehoe <kehoea@parhasard.net>
parents:
5084
diff
changeset
|
4733 |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
4734 write_fmt_string (printcharfun, ") 0x%x>", LISP_OBJECT_UID (obj)); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4735 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4736 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4737 static Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4738 mark_multiple_value (Lisp_Object obj) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4739 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4740 struct multiple_value *mv = XMULTIPLE_VALUE (obj); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4741 Elemcount index, allocated_count = mv->allocated_count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4742 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4743 for (index = 0; index < allocated_count; ++index) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4744 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4745 mark_object (mv->contents[index]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4746 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4747 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4748 return Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4749 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4750 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4751 static Bytecount |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
4752 size_multiple_value (Lisp_Object obj) |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4753 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4754 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (struct multiple_value, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4755 Lisp_Object, contents, |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
4756 XMULTIPLE_VALUE (obj)->allocated_count); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4757 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4758 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4759 static const struct memory_description multiple_value_description[] = { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4760 { XD_LONG, offsetof (struct multiple_value, count) }, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4761 { XD_ELEMCOUNT, offsetof (struct multiple_value, allocated_count) }, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4762 { XD_LONG, offsetof (struct multiple_value, first_desired) }, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4763 { XD_LISP_OBJECT_ARRAY, offsetof (struct multiple_value, contents), |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4764 XD_INDIRECT (1, 0) }, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4765 { XD_END } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4766 }; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4767 |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
4768 DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("multiple-value", multiple_value, |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4769 mark_multiple_value, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4770 print_multiple_value, 0, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4771 0, /* No equal method. */ |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4772 0, /* No hash method. */ |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4773 multiple_value_description, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4774 size_multiple_value, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4775 struct multiple_value); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4776 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4777 /* Given that FIRST and UPPER are the inclusive lower and exclusive upper |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4778 bounds for the multiple values we're interested in, modify (or don't) the |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4779 special variables used to indicate this to #'values and #'values-list. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4780 Returns the specpdl_depth() value before any modification. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4781 int |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4782 bind_multiple_value_limits (int first, int upper) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4783 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4784 int result = specpdl_depth(); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4785 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4786 if (!(upper > first)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4787 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4788 invalid_argument ("MULTIPLE-VALUE-UPPER-LIMIT must be greater than " |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4789 " FIRST-DESIRED-MULTIPLE-VALUE", Qunbound); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4790 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4791 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4792 if (upper > Vmultiple_values_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4793 { |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
4794 args_out_of_range (make_fixnum (upper), make_fixnum (Vmultiple_values_limit)); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4795 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4796 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4797 /* In the event that something back up the stack wants more multiple |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4798 values than we do, we need to keep its figures for |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4799 first_desired_multiple_value or multiple_value_current_limit both. It |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4800 may be that the form will throw past us. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4801 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4802 If first_desired_multiple_value is zero, this means it hasn't ever been |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4803 bound, and any value we have for first is appropriate to use. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4804 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4805 Zeroth element is always saved, no need to note that: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4806 if (0 == first) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4807 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4808 first = 1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4809 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4810 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4811 if (0 == first_desired_multiple_value |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4812 || first < first_desired_multiple_value) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4813 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4814 internal_bind_int (&first_desired_multiple_value, first); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4815 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4816 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4817 if (upper > multiple_value_current_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4818 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4819 internal_bind_int (&multiple_value_current_limit, upper); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4820 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4821 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4822 return result; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4823 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4824 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4825 Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4826 multiple_value_call (int nargs, Lisp_Object *args) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4827 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4828 /* The argument order here is horrible: */ |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
4829 int i, speccount = XFIXNUM (args[3]); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4830 Lisp_Object result = Qnil, head = Fcons (args[0], Qnil), list_offset; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4831 struct gcpro gcpro1, gcpro2; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4832 Lisp_Object apply_args[2]; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4833 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4834 GCPRO2 (head, result); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4835 list_offset = head; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4836 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4837 assert (!(MULTIPLE_VALUEP (args[0]))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4838 CHECK_FUNCTION (args[0]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4839 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4840 /* Start at 4, to ignore the function, the speccount, and the arguments to |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4841 multiple-values-limit (which we don't discard because |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4842 #'multiple-value-list-internal needs them): */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4843 for (i = 4; i < nargs; ++i) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4844 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4845 result = args[i]; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4846 if (MULTIPLE_VALUEP (result)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4847 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4848 Lisp_Object val; |
|
5016
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
4849 Elemcount j, count = XMULTIPLE_VALUE_COUNT (result); |
|
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
4850 |
|
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
4851 for (j = 0; j < count; j++) |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4852 { |
|
5016
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
4853 val = multiple_value_aref (result, j); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4854 assert (!UNBOUNDP (val)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4855 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4856 XSETCDR (list_offset, Fcons (val, Qnil)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4857 list_offset = XCDR (list_offset); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4858 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4859 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4860 else |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4861 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4862 XSETCDR (list_offset, Fcons (result, Qnil)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4863 list_offset = XCDR (list_offset); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4864 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4865 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4866 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4867 apply_args [0] = XCAR (head); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4868 apply_args [1] = XCDR (head); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4869 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4870 unbind_to (speccount); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4871 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4872 RETURN_UNGCPRO (Fapply (countof(apply_args), apply_args)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4873 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4874 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4875 DEFUN ("multiple-value-call", Fmultiple_value_call, 1, UNEVALLED, 0, /* |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4876 Call FUNCTION with arguments FORMS, using multiple values when returned. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4877 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4878 All of the (possibly multiple) values returned by each form in FORMS are |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4879 gathered together, and given as arguments to FUNCTION; conceptually, this |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4880 function is a version of `apply' that by-passes the multiple values |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4881 infrastructure, treating multiple values as intercalated lists. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4882 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4883 arguments: (FUNCTION &rest FORMS) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4884 */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4885 (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4886 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4887 int listcount, i = 0, speccount; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4888 Lisp_Object *constructed_args; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4889 struct gcpro gcpro1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4890 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4891 GET_EXTERNAL_LIST_LENGTH (args, listcount); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4892 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4893 constructed_args = alloca_array (Lisp_Object, listcount + 3); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4894 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4895 /* Fcar so we error on non-cons: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4896 constructed_args[i] = IGNORE_MULTIPLE_VALUES (Feval (Fcar (args))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4897 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4898 GCPRO1 (*constructed_args); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4899 gcpro1.nvars = ++i; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4900 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4901 /* The argument order is horrible here. */ |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
4902 constructed_args[i] = make_fixnum (0); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4903 gcpro1.nvars = ++i; |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
4904 constructed_args[i] = make_fixnum (Vmultiple_values_limit); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4905 gcpro1.nvars = ++i; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4906 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4907 speccount = bind_multiple_value_limits (0, Vmultiple_values_limit); |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
4908 constructed_args[i] = make_fixnum (speccount); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4909 gcpro1.nvars = ++i; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4910 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4911 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4912 LIST_LOOP_2 (elt, XCDR (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4913 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4914 constructed_args[i] = Feval (elt); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4915 gcpro1.nvars = ++i; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4916 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4917 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4918 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4919 RETURN_UNGCPRO (multiple_value_call (listcount + 3, constructed_args)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4920 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4921 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4922 Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4923 multiple_value_list_internal (int nargs, Lisp_Object *args) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4924 { |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
4925 int first = XFIXNUM (args[0]), upper = XFIXNUM (args[1]), |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
4926 speccount = XFIXNUM(args[2]); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4927 Lisp_Object result = Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4928 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4929 assert (nargs == 4); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4930 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4931 result = args[3]; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4932 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4933 unbind_to (speccount); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4934 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4935 if (MULTIPLE_VALUEP (result)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4936 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4937 Lisp_Object head = Fcons (Qnil, Qnil); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4938 Lisp_Object list_offset = head, val; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4939 Elemcount count = XMULTIPLE_VALUE_COUNT(result); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4940 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4941 for (; first < upper && first < count; ++first) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4942 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4943 val = multiple_value_aref (result, first); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4944 assert (!UNBOUNDP (val)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4945 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4946 XSETCDR (list_offset, Fcons (val, Qnil)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4947 list_offset = XCDR (list_offset); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4948 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4949 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4950 return XCDR (head); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4951 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4952 else |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4953 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4954 if (first == 0) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4955 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4956 return Fcons (result, Qnil); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4957 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4958 else |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4959 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4960 return Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4961 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4962 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4963 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4964 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4965 DEFUN ("multiple-value-list-internal", Fmultiple_value_list_internal, 3, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4966 UNEVALLED, 0, /* |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4967 Evaluate FORM. Return a list of multiple vals reflecting the other two args. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4968 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4969 Don't use this. Use `multiple-value-list', the macro specified by Common |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4970 Lisp, instead. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4971 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4972 FIRST-DESIRED-MULTIPLE-VALUE is the first element in list of multiple values |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4973 to pass back. MULTIPLE-VALUE-UPPER-LIMIT is the exclusive upper limit on |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4974 the indexes within the values that may be passed back; this function will |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4975 never return a list longer than MULTIPLE-VALUE-UPPER-LIMIT - |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4976 FIRST-DESIRED-MULTIPLE-VALUE. It may return a list shorter than that, if |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4977 `values' or `values-list' do not supply enough elements. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4978 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4979 arguments: (FIRST-DESIRED-MULTIPLE-VALUE MULTIPLE-VALUE-UPPER-LIMIT FORM) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4980 */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4981 (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4982 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4983 Lisp_Object argv[4]; |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4984 int first, upper, nargs; |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4985 struct gcpro gcpro1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4986 |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4987 GET_LIST_LENGTH (args, nargs); |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4988 if (nargs != 3) |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4989 { |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4990 Fsignal (Qwrong_number_of_arguments, |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
4991 list2 (Qmultiple_value_list_internal, make_fixnum (nargs))); |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4992 } |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4993 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4994 argv[0] = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4995 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4996 GCPRO1 (argv[0]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4997 gcpro1.nvars = 1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4998 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4999 args = XCDR (args); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5000 argv[1] = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args))); |
|
5307
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5265
diff
changeset
|
5001 |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
5002 check_integer_range (argv[1], Qzero, make_fixnum (MOST_POSITIVE_FIXNUM)); |
|
5307
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5265
diff
changeset
|
5003 check_integer_range (argv[0], Qzero, argv[1]); |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5265
diff
changeset
|
5004 |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
5005 upper = XFIXNUM (argv[1]); |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
5006 first = XFIXNUM (argv[0]); |
|
5307
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5265
diff
changeset
|
5007 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5008 gcpro1.nvars = 2; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5009 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5010 /* The unintuitive order of things here is for the sake of the bytecode; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5011 the alternative would be to encode the number of arguments in the |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5012 bytecode stream, which complicates things if we have more than 255 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5013 arguments. */ |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
5014 argv[2] = make_fixnum (bind_multiple_value_limits (first, upper)); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5015 gcpro1.nvars = 3; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5016 args = XCDR (args); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5017 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5018 /* GCPROing in this function is not strictly necessary, this Feval is the |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5019 only point that may cons up data that is not immediately discarded, and |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5020 within it is the only point (in Fmultiple_value_list_internal and |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5021 multiple_value_list) that we can garbage collect. But I'm conservative, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5022 and this function is called so rarely (only from interpreted code) that |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5023 it doesn't matter for performance. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5024 argv[3] = Feval (XCAR (args)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5025 gcpro1.nvars = 4; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5026 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5027 RETURN_UNGCPRO (multiple_value_list_internal (countof (argv), argv)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5028 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5029 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5030 DEFUN ("multiple-value-prog1", Fmultiple_value_prog1, 1, UNEVALLED, 0, /* |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5031 Similar to `prog1', but return any multiple values from the first form. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5032 `prog1' itself will never return multiple values. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5033 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5034 arguments: (FIRST &rest BODY) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5035 */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5036 (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5037 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5038 /* This function can GC */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5039 Lisp_Object val; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5040 struct gcpro gcpro1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5041 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5042 val = Feval (XCAR (args)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5043 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5044 GCPRO1 (val); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5045 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5046 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5047 LIST_LOOP_2 (form, XCDR (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5048 Feval (form); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5049 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5050 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5051 RETURN_UNGCPRO (val); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5052 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5053 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5054 DEFUN ("values", Fvalues, 0, MANY, 0, /* |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5055 Return all ARGS as multiple values. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5056 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5057 arguments: (&rest ARGS) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5058 */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5059 (int nargs, Lisp_Object *args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5060 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5061 Lisp_Object result = Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5062 int counting = 1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5063 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5064 /* Pathological cases, no need to cons up an object: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5065 if (1 == nargs || 1 == multiple_value_current_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5066 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5067 return nargs ? args[0] : Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5068 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5069 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5070 /* If nargs is zero, this code is correct and desirable. With |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5071 #'multiple-value-call, we want zero-length multiple values in the |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5072 argument list to be discarded entirely, and we can't do this if we |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5073 transform them to nil. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5074 result = make_multiple_value (nargs ? args[0] : Qnil, nargs, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5075 first_desired_multiple_value, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5076 multiple_value_current_limit); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5077 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5078 for (; counting < nargs; ++counting) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5079 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5080 if (counting >= first_desired_multiple_value && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5081 counting < multiple_value_current_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5082 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5083 multiple_value_aset (result, counting, args[counting]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5084 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5085 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5086 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5087 return result; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5088 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5089 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5090 DEFUN ("values-list", Fvalues_list, 1, 1, 0, /* |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5091 Return all the elements of LIST as multiple values. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5092 */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5093 (list)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5094 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5095 Lisp_Object result = Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5096 int counting = 1, listcount; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5097 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5098 GET_EXTERNAL_LIST_LENGTH (list, listcount); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5099 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5100 /* Pathological cases, no need to cons up an object: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5101 if (1 == listcount || 1 == multiple_value_current_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5102 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5103 return Fcar_safe (list); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5104 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5105 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5106 result = make_multiple_value (Fcar_safe (list), listcount, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5107 first_desired_multiple_value, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5108 multiple_value_current_limit); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5109 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5110 list = Fcdr_safe (list); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5111 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5112 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5113 EXTERNAL_LIST_LOOP_2 (elt, list) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5114 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5115 if (counting >= first_desired_multiple_value && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5116 counting < multiple_value_current_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5117 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5118 multiple_value_aset (result, counting, elt); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5119 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5120 ++counting; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5121 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5122 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5123 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5124 return result; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5125 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5126 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5127 Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5128 values2 (Lisp_Object first, Lisp_Object second) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5129 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5130 Lisp_Object argv[2]; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5131 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5132 argv[0] = first; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5133 argv[1] = second; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5134 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5135 return Fvalues (countof (argv), argv); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5136 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5137 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5138 |
| 428 | 5139 /************************************************************************/ |
| 5140 /* Run hook variables in various ways. */ | |
| 5141 /************************************************************************/ | |
| 5142 | |
| 5143 DEFUN ("run-hooks", Frun_hooks, 1, MANY, 0, /* | |
| 5144 Run each hook in HOOKS. Major mode functions use this. | |
| 5145 Each argument should be a symbol, a hook variable. | |
| 5146 These symbols are processed in the order specified. | |
| 5147 If a hook symbol has a non-nil value, that value may be a function | |
| 5148 or a list of functions to be called to run the hook. | |
| 5149 If the value is a function, it is called with no arguments. | |
| 5150 If it is a list, the elements are called, in order, with no arguments. | |
| 5151 | |
| 5152 To make a hook variable buffer-local, use `make-local-hook', | |
| 5153 not `make-local-variable'. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5154 |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
5155 arguments: (FIRST &rest REST) |
| 428 | 5156 */ |
| 5157 (int nargs, Lisp_Object *args)) | |
| 5158 { | |
| 5159 REGISTER int i; | |
| 5160 | |
| 5161 for (i = 0; i < nargs; i++) | |
| 5162 run_hook_with_args (1, args + i, RUN_HOOKS_TO_COMPLETION); | |
| 5163 | |
| 5164 return Qnil; | |
| 5165 } | |
| 5166 | |
| 5167 DEFUN ("run-hook-with-args", Frun_hook_with_args, 1, MANY, 0, /* | |
| 5168 Run HOOK with the specified arguments ARGS. | |
| 5169 HOOK should be a symbol, a hook variable. If HOOK has a non-nil | |
| 5170 value, that value may be a function or a list of functions to be | |
| 5171 called to run the hook. If the value is a function, it is called with | |
| 5172 the given arguments and its return value is returned. If it is a list | |
| 5173 of functions, those functions are called, in order, | |
| 5174 with the given arguments ARGS. | |
| 444 | 5175 It is best not to depend on the value returned by `run-hook-with-args', |
| 428 | 5176 as that may change. |
| 5177 | |
| 5178 To make a hook variable buffer-local, use `make-local-hook', | |
| 5179 not `make-local-variable'. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5180 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5181 arguments: (HOOK &rest ARGS) |
| 428 | 5182 */ |
| 5183 (int nargs, Lisp_Object *args)) | |
| 5184 { | |
| 5185 return run_hook_with_args (nargs, args, RUN_HOOKS_TO_COMPLETION); | |
| 5186 } | |
| 5187 | |
| 5188 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success, 1, MANY, 0, /* | |
| 5189 Run HOOK with the specified arguments ARGS. | |
| 5190 HOOK should be a symbol, a hook variable. Its value should | |
| 5191 be a list of functions. We call those functions, one by one, | |
| 5192 passing arguments ARGS to each of them, until one of them | |
| 5193 returns a non-nil value. Then we return that value. | |
| 5194 If all the functions return nil, we return nil. | |
| 5195 | |
| 5196 To make a hook variable buffer-local, use `make-local-hook', | |
| 5197 not `make-local-variable'. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5198 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5199 arguments: (HOOK &rest ARGS) |
| 428 | 5200 */ |
| 5201 (int nargs, Lisp_Object *args)) | |
| 5202 { | |
| 5203 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_SUCCESS); | |
| 5204 } | |
| 5205 | |
| 5206 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure, 1, MANY, 0, /* | |
| 5207 Run HOOK with the specified arguments ARGS. | |
| 5208 HOOK should be a symbol, a hook variable. Its value should | |
| 5209 be a list of functions. We call those functions, one by one, | |
| 5210 passing arguments ARGS to each of them, until one of them | |
| 5211 returns nil. Then we return nil. | |
| 5212 If all the functions return non-nil, we return non-nil. | |
| 5213 | |
| 5214 To make a hook variable buffer-local, use `make-local-hook', | |
| 5215 not `make-local-variable'. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5216 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5217 arguments: (HOOK &rest ARGS) |
| 428 | 5218 */ |
| 5219 (int nargs, Lisp_Object *args)) | |
| 5220 { | |
| 5221 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_FAILURE); | |
| 5222 } | |
| 5223 | |
| 5224 /* ARGS[0] should be a hook symbol. | |
| 5225 Call each of the functions in the hook value, passing each of them | |
| 5226 as arguments all the rest of ARGS (all NARGS - 1 elements). | |
| 5227 COND specifies a condition to test after each call | |
| 5228 to decide whether to stop. | |
| 5229 The caller (or its caller, etc) must gcpro all of ARGS, | |
| 5230 except that it isn't necessary to gcpro ARGS[0]. */ | |
| 5231 | |
| 5232 Lisp_Object | |
| 5233 run_hook_with_args_in_buffer (struct buffer *buf, int nargs, Lisp_Object *args, | |
| 5234 enum run_hooks_condition cond) | |
| 5235 { | |
| 5236 Lisp_Object sym, val, ret; | |
| 5237 | |
| 5238 if (!initialized || preparing_for_armageddon) | |
| 5239 /* We need to bail out of here pronto. */ | |
| 5240 return Qnil; | |
| 5241 | |
| 3092 | 5242 #ifndef NEW_GC |
| 428 | 5243 /* Whenever gc_in_progress is true, preparing_for_armageddon |
| 5244 will also be true unless something is really hosed. */ | |
| 5245 assert (!gc_in_progress); | |
| 3092 | 5246 #endif /* not NEW_GC */ |
| 428 | 5247 |
| 5248 sym = args[0]; | |
| 771 | 5249 val = symbol_value_in_buffer (sym, wrap_buffer (buf)); |
| 428 | 5250 ret = (cond == RUN_HOOKS_UNTIL_FAILURE ? Qt : Qnil); |
| 5251 | |
| 5252 if (UNBOUNDP (val) || NILP (val)) | |
| 5253 return ret; | |
| 5254 else if (!CONSP (val) || EQ (XCAR (val), Qlambda)) | |
| 5255 { | |
| 5256 args[0] = val; | |
| 5257 return Ffuncall (nargs, args); | |
| 5258 } | |
| 5259 else | |
| 5260 { | |
| 5261 struct gcpro gcpro1, gcpro2, gcpro3; | |
| 5262 Lisp_Object globals = Qnil; | |
| 5263 GCPRO3 (sym, val, globals); | |
| 5264 | |
| 5265 for (; | |
| 5266 CONSP (val) && ((cond == RUN_HOOKS_TO_COMPLETION) | |
| 5267 || (cond == RUN_HOOKS_UNTIL_SUCCESS ? NILP (ret) | |
| 5268 : !NILP (ret))); | |
| 5269 val = XCDR (val)) | |
| 5270 { | |
| 5271 if (EQ (XCAR (val), Qt)) | |
| 5272 { | |
| 5273 /* t indicates this hook has a local binding; | |
| 5274 it means to run the global binding too. */ | |
| 5275 globals = Fdefault_value (sym); | |
| 5276 | |
| 5277 if ((! CONSP (globals) || EQ (XCAR (globals), Qlambda)) && | |
| 5278 ! NILP (globals)) | |
| 5279 { | |
| 5280 args[0] = globals; | |
| 5281 ret = Ffuncall (nargs, args); | |
| 5282 } | |
| 5283 else | |
| 5284 { | |
| 5285 for (; | |
| 5286 CONSP (globals) && ((cond == RUN_HOOKS_TO_COMPLETION) | |
| 5287 || (cond == RUN_HOOKS_UNTIL_SUCCESS | |
| 5288 ? NILP (ret) | |
| 5289 : !NILP (ret))); | |
| 5290 globals = XCDR (globals)) | |
| 5291 { | |
| 5292 args[0] = XCAR (globals); | |
| 5293 /* In a global value, t should not occur. If it does, we | |
| 5294 must ignore it to avoid an endless loop. */ | |
| 5295 if (!EQ (args[0], Qt)) | |
| 5296 ret = Ffuncall (nargs, args); | |
| 5297 } | |
| 5298 } | |
| 5299 } | |
| 5300 else | |
| 5301 { | |
| 5302 args[0] = XCAR (val); | |
| 5303 ret = Ffuncall (nargs, args); | |
| 5304 } | |
| 5305 } | |
| 5306 | |
| 5307 UNGCPRO; | |
| 5308 return ret; | |
| 5309 } | |
| 5310 } | |
| 5311 | |
| 5312 Lisp_Object | |
| 5313 run_hook_with_args (int nargs, Lisp_Object *args, | |
| 5314 enum run_hooks_condition cond) | |
| 5315 { | |
| 5316 return run_hook_with_args_in_buffer (current_buffer, nargs, args, cond); | |
| 5317 } | |
| 5318 | |
| 5319 #if 0 | |
| 5320 | |
| 853 | 5321 /* From FSF 19.30, not currently used; seems like a big kludge. */ |
| 428 | 5322 |
| 5323 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual | |
| 5324 present value of that symbol. | |
| 5325 Call each element of FUNLIST, | |
| 5326 passing each of them the rest of ARGS. | |
| 5327 The caller (or its caller, etc) must gcpro all of ARGS, | |
| 5328 except that it isn't necessary to gcpro ARGS[0]. */ | |
| 5329 | |
| 5330 Lisp_Object | |
| 5331 run_hook_list_with_args (Lisp_Object funlist, int nargs, Lisp_Object *args) | |
| 5332 { | |
| 853 | 5333 omitted; |
| 428 | 5334 } |
| 5335 | |
| 5336 #endif /* 0 */ | |
| 5337 | |
| 5338 void | |
| 5339 va_run_hook_with_args (Lisp_Object hook_var, int nargs, ...) | |
| 5340 { | |
| 5341 /* This function can GC */ | |
| 5342 struct gcpro gcpro1; | |
| 5343 int i; | |
| 5344 va_list vargs; | |
| 5345 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs); | |
| 5346 | |
| 5347 va_start (vargs, nargs); | |
| 5348 funcall_args[0] = hook_var; | |
| 5349 for (i = 0; i < nargs; i++) | |
| 5350 funcall_args[i + 1] = va_arg (vargs, Lisp_Object); | |
| 5351 va_end (vargs); | |
| 5352 | |
| 5353 GCPRO1 (*funcall_args); | |
| 5354 gcpro1.nvars = nargs + 1; | |
| 5355 run_hook_with_args (nargs + 1, funcall_args, RUN_HOOKS_TO_COMPLETION); | |
| 5356 UNGCPRO; | |
| 5357 } | |
| 5358 | |
| 5359 void | |
| 5360 va_run_hook_with_args_in_buffer (struct buffer *buf, Lisp_Object hook_var, | |
| 5361 int nargs, ...) | |
| 5362 { | |
| 5363 /* This function can GC */ | |
| 5364 struct gcpro gcpro1; | |
| 5365 int i; | |
| 5366 va_list vargs; | |
| 5367 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs); | |
| 5368 | |
| 5369 va_start (vargs, nargs); | |
| 5370 funcall_args[0] = hook_var; | |
| 5371 for (i = 0; i < nargs; i++) | |
| 5372 funcall_args[i + 1] = va_arg (vargs, Lisp_Object); | |
| 5373 va_end (vargs); | |
| 5374 | |
| 5375 GCPRO1 (*funcall_args); | |
| 5376 gcpro1.nvars = nargs + 1; | |
| 5377 run_hook_with_args_in_buffer (buf, nargs + 1, funcall_args, | |
| 5378 RUN_HOOKS_TO_COMPLETION); | |
| 5379 UNGCPRO; | |
| 5380 } | |
| 5381 | |
| 5382 Lisp_Object | |
| 5383 run_hook (Lisp_Object hook) | |
| 5384 { | |
| 853 | 5385 return run_hook_with_args (1, &hook, RUN_HOOKS_TO_COMPLETION); |
| 428 | 5386 } |
| 5387 | |
| 5388 | |
| 5389 /************************************************************************/ | |
| 5390 /* Front-ends to eval, funcall, apply */ | |
| 5391 /************************************************************************/ | |
| 5392 | |
| 5393 /* Apply fn to arg */ | |
| 5394 Lisp_Object | |
| 5395 apply1 (Lisp_Object fn, Lisp_Object arg) | |
| 5396 { | |
| 5397 /* This function can GC */ | |
| 5398 struct gcpro gcpro1; | |
| 5399 Lisp_Object args[2]; | |
| 5400 | |
| 5401 if (NILP (arg)) | |
| 5402 return Ffuncall (1, &fn); | |
| 5403 GCPRO1 (args[0]); | |
| 5404 gcpro1.nvars = 2; | |
| 5405 args[0] = fn; | |
| 5406 args[1] = arg; | |
| 5407 RETURN_UNGCPRO (Fapply (2, args)); | |
| 5408 } | |
| 5409 | |
| 5410 /* Call function fn on no arguments */ | |
| 5411 Lisp_Object | |
| 5412 call0 (Lisp_Object fn) | |
| 5413 { | |
| 5414 /* This function can GC */ | |
| 5415 struct gcpro gcpro1; | |
| 5416 | |
| 5417 GCPRO1 (fn); | |
| 5418 RETURN_UNGCPRO (Ffuncall (1, &fn)); | |
| 5419 } | |
| 5420 | |
| 5421 /* Call function fn with argument arg0 */ | |
| 5422 Lisp_Object | |
| 5423 call1 (Lisp_Object fn, | |
| 5424 Lisp_Object arg0) | |
| 5425 { | |
| 5426 /* This function can GC */ | |
| 5427 struct gcpro gcpro1; | |
| 5428 Lisp_Object args[2]; | |
| 5429 args[0] = fn; | |
| 5430 args[1] = arg0; | |
| 5431 GCPRO1 (args[0]); | |
| 5432 gcpro1.nvars = 2; | |
| 5433 RETURN_UNGCPRO (Ffuncall (2, args)); | |
| 5434 } | |
| 5435 | |
| 5436 /* Call function fn with arguments arg0, arg1 */ | |
| 5437 Lisp_Object | |
| 5438 call2 (Lisp_Object fn, | |
| 5439 Lisp_Object arg0, Lisp_Object arg1) | |
| 5440 { | |
| 5441 /* This function can GC */ | |
| 5442 struct gcpro gcpro1; | |
| 5443 Lisp_Object args[3]; | |
| 5444 args[0] = fn; | |
| 5445 args[1] = arg0; | |
| 5446 args[2] = arg1; | |
| 5447 GCPRO1 (args[0]); | |
| 5448 gcpro1.nvars = 3; | |
| 5449 RETURN_UNGCPRO (Ffuncall (3, args)); | |
| 5450 } | |
| 5451 | |
| 5452 /* Call function fn with arguments arg0, arg1, arg2 */ | |
| 5453 Lisp_Object | |
| 5454 call3 (Lisp_Object fn, | |
| 5455 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2) | |
| 5456 { | |
| 5457 /* This function can GC */ | |
| 5458 struct gcpro gcpro1; | |
| 5459 Lisp_Object args[4]; | |
| 5460 args[0] = fn; | |
| 5461 args[1] = arg0; | |
| 5462 args[2] = arg1; | |
| 5463 args[3] = arg2; | |
| 5464 GCPRO1 (args[0]); | |
| 5465 gcpro1.nvars = 4; | |
| 5466 RETURN_UNGCPRO (Ffuncall (4, args)); | |
| 5467 } | |
| 5468 | |
| 5469 /* Call function fn with arguments arg0, arg1, arg2, arg3 */ | |
| 5470 Lisp_Object | |
| 5471 call4 (Lisp_Object fn, | |
| 5472 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5473 Lisp_Object arg3) | |
| 5474 { | |
| 5475 /* This function can GC */ | |
| 5476 struct gcpro gcpro1; | |
| 5477 Lisp_Object args[5]; | |
| 5478 args[0] = fn; | |
| 5479 args[1] = arg0; | |
| 5480 args[2] = arg1; | |
| 5481 args[3] = arg2; | |
| 5482 args[4] = arg3; | |
| 5483 GCPRO1 (args[0]); | |
| 5484 gcpro1.nvars = 5; | |
| 5485 RETURN_UNGCPRO (Ffuncall (5, args)); | |
| 5486 } | |
| 5487 | |
| 5488 /* Call function fn with arguments arg0, arg1, arg2, arg3, arg4 */ | |
| 5489 Lisp_Object | |
| 5490 call5 (Lisp_Object fn, | |
| 5491 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5492 Lisp_Object arg3, Lisp_Object arg4) | |
| 5493 { | |
| 5494 /* This function can GC */ | |
| 5495 struct gcpro gcpro1; | |
| 5496 Lisp_Object args[6]; | |
| 5497 args[0] = fn; | |
| 5498 args[1] = arg0; | |
| 5499 args[2] = arg1; | |
| 5500 args[3] = arg2; | |
| 5501 args[4] = arg3; | |
| 5502 args[5] = arg4; | |
| 5503 GCPRO1 (args[0]); | |
| 5504 gcpro1.nvars = 6; | |
| 5505 RETURN_UNGCPRO (Ffuncall (6, args)); | |
| 5506 } | |
| 5507 | |
| 5508 Lisp_Object | |
| 5509 call6 (Lisp_Object fn, | |
| 5510 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5511 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5) | |
| 5512 { | |
| 5513 /* This function can GC */ | |
| 5514 struct gcpro gcpro1; | |
| 5515 Lisp_Object args[7]; | |
| 5516 args[0] = fn; | |
| 5517 args[1] = arg0; | |
| 5518 args[2] = arg1; | |
| 5519 args[3] = arg2; | |
| 5520 args[4] = arg3; | |
| 5521 args[5] = arg4; | |
| 5522 args[6] = arg5; | |
| 5523 GCPRO1 (args[0]); | |
| 5524 gcpro1.nvars = 7; | |
| 5525 RETURN_UNGCPRO (Ffuncall (7, args)); | |
| 5526 } | |
| 5527 | |
| 5528 Lisp_Object | |
| 5529 call7 (Lisp_Object fn, | |
| 5530 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5531 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5, | |
| 5532 Lisp_Object arg6) | |
| 5533 { | |
| 5534 /* This function can GC */ | |
| 5535 struct gcpro gcpro1; | |
| 5536 Lisp_Object args[8]; | |
| 5537 args[0] = fn; | |
| 5538 args[1] = arg0; | |
| 5539 args[2] = arg1; | |
| 5540 args[3] = arg2; | |
| 5541 args[4] = arg3; | |
| 5542 args[5] = arg4; | |
| 5543 args[6] = arg5; | |
| 5544 args[7] = arg6; | |
| 5545 GCPRO1 (args[0]); | |
| 5546 gcpro1.nvars = 8; | |
| 5547 RETURN_UNGCPRO (Ffuncall (8, args)); | |
| 5548 } | |
| 5549 | |
| 5550 Lisp_Object | |
| 5551 call8 (Lisp_Object fn, | |
| 5552 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5553 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5, | |
| 5554 Lisp_Object arg6, Lisp_Object arg7) | |
| 5555 { | |
| 5556 /* This function can GC */ | |
| 5557 struct gcpro gcpro1; | |
| 5558 Lisp_Object args[9]; | |
| 5559 args[0] = fn; | |
| 5560 args[1] = arg0; | |
| 5561 args[2] = arg1; | |
| 5562 args[3] = arg2; | |
| 5563 args[4] = arg3; | |
| 5564 args[5] = arg4; | |
| 5565 args[6] = arg5; | |
| 5566 args[7] = arg6; | |
| 5567 args[8] = arg7; | |
| 5568 GCPRO1 (args[0]); | |
| 5569 gcpro1.nvars = 9; | |
| 5570 RETURN_UNGCPRO (Ffuncall (9, args)); | |
| 5571 } | |
| 5572 | |
| 5573 Lisp_Object | |
| 5574 call0_in_buffer (struct buffer *buf, Lisp_Object fn) | |
| 5575 { | |
| 5576 if (current_buffer == buf) | |
| 5577 return call0 (fn); | |
| 5578 else | |
| 5579 { | |
| 5580 Lisp_Object val; | |
| 5581 int speccount = specpdl_depth(); | |
| 5582 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5583 set_buffer_internal (buf); | |
| 5584 val = call0 (fn); | |
| 771 | 5585 unbind_to (speccount); |
| 428 | 5586 return val; |
| 5587 } | |
| 5588 } | |
| 5589 | |
| 5590 Lisp_Object | |
| 5591 call1_in_buffer (struct buffer *buf, Lisp_Object fn, | |
| 5592 Lisp_Object arg0) | |
| 5593 { | |
| 5594 if (current_buffer == buf) | |
| 5595 return call1 (fn, arg0); | |
| 5596 else | |
| 5597 { | |
| 5598 Lisp_Object val; | |
| 5599 int speccount = specpdl_depth(); | |
| 5600 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5601 set_buffer_internal (buf); | |
| 5602 val = call1 (fn, arg0); | |
| 771 | 5603 unbind_to (speccount); |
| 428 | 5604 return val; |
| 5605 } | |
| 5606 } | |
| 5607 | |
| 5608 Lisp_Object | |
| 5609 call2_in_buffer (struct buffer *buf, Lisp_Object fn, | |
| 5610 Lisp_Object arg0, Lisp_Object arg1) | |
| 5611 { | |
| 5612 if (current_buffer == buf) | |
| 5613 return call2 (fn, arg0, arg1); | |
| 5614 else | |
| 5615 { | |
| 5616 Lisp_Object val; | |
| 5617 int speccount = specpdl_depth(); | |
| 5618 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5619 set_buffer_internal (buf); | |
| 5620 val = call2 (fn, arg0, arg1); | |
| 771 | 5621 unbind_to (speccount); |
| 428 | 5622 return val; |
| 5623 } | |
| 5624 } | |
| 5625 | |
| 5626 Lisp_Object | |
| 5627 call3_in_buffer (struct buffer *buf, Lisp_Object fn, | |
| 5628 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2) | |
| 5629 { | |
| 5630 if (current_buffer == buf) | |
| 5631 return call3 (fn, arg0, arg1, arg2); | |
| 5632 else | |
| 5633 { | |
| 5634 Lisp_Object val; | |
| 5635 int speccount = specpdl_depth(); | |
| 5636 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5637 set_buffer_internal (buf); | |
| 5638 val = call3 (fn, arg0, arg1, arg2); | |
| 771 | 5639 unbind_to (speccount); |
| 428 | 5640 return val; |
| 5641 } | |
| 5642 } | |
| 5643 | |
| 5644 Lisp_Object | |
| 5645 call4_in_buffer (struct buffer *buf, Lisp_Object fn, | |
| 5646 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5647 Lisp_Object arg3) | |
| 5648 { | |
| 5649 if (current_buffer == buf) | |
| 5650 return call4 (fn, arg0, arg1, arg2, arg3); | |
| 5651 else | |
| 5652 { | |
| 5653 Lisp_Object val; | |
| 5654 int speccount = specpdl_depth(); | |
| 5655 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5656 set_buffer_internal (buf); | |
| 5657 val = call4 (fn, arg0, arg1, arg2, arg3); | |
| 771 | 5658 unbind_to (speccount); |
| 428 | 5659 return val; |
| 5660 } | |
| 5661 } | |
| 5662 | |
| 5663 Lisp_Object | |
| 5664 eval_in_buffer (struct buffer *buf, Lisp_Object form) | |
| 5665 { | |
| 5666 if (current_buffer == buf) | |
| 5667 return Feval (form); | |
| 5668 else | |
| 5669 { | |
| 5670 Lisp_Object val; | |
| 5671 int speccount = specpdl_depth(); | |
| 5672 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5673 set_buffer_internal (buf); | |
| 5674 val = Feval (form); | |
| 771 | 5675 unbind_to (speccount); |
| 428 | 5676 return val; |
| 5677 } | |
| 5678 } | |
| 5679 | |
| 5680 | |
| 5681 /************************************************************************/ | |
| 5682 /* Error-catching front-ends to eval, funcall, apply */ | |
| 5683 /************************************************************************/ | |
| 5684 | |
| 853 | 5685 int |
| 5686 get_inhibit_flags (void) | |
| 5687 { | |
| 5688 return inhibit_flags; | |
| 5689 } | |
| 5690 | |
| 5691 void | |
| 2286 | 5692 check_allowed_operation (int what, Lisp_Object obj, Lisp_Object UNUSED (prop)) |
| 853 | 5693 { |
| 5694 if (inhibit_flags & INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION) | |
| 5695 { | |
| 5696 if (what == OPERATION_MODIFY_BUFFER_TEXT && BUFFERP (obj) | |
| 5697 && NILP (memq_no_quit (obj, Vmodifiable_buffers))) | |
| 5698 invalid_change | |
| 5699 ("Modification of this buffer not currently permitted", obj); | |
| 5700 } | |
| 5701 if (inhibit_flags & INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION) | |
| 5702 { | |
| 5703 if (what == OPERATION_DELETE_OBJECT | |
| 5704 && (BUFFERP (obj) || WINDOWP (obj) || FRAMEP (obj) || DEVICEP (obj) | |
| 5705 || CONSOLEP (obj)) | |
| 5706 && NILP (memq_no_quit (obj, Vdeletable_permanent_display_objects))) | |
| 5707 invalid_change | |
| 5708 ("Deletion of this object not currently permitted", obj); | |
| 5709 } | |
| 5710 } | |
| 5711 | |
| 5712 void | |
| 5713 note_object_created (Lisp_Object obj) | |
| 5714 { | |
| 5715 if (inhibit_flags & INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION) | |
| 5716 { | |
| 5717 if (BUFFERP (obj)) | |
| 5718 Vmodifiable_buffers = Fcons (obj, Vmodifiable_buffers); | |
| 5719 } | |
| 5720 if (inhibit_flags & INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION) | |
| 5721 { | |
| 5722 if (BUFFERP (obj) || WINDOWP (obj) || FRAMEP (obj) || DEVICEP (obj) | |
| 5723 || CONSOLEP (obj)) | |
| 5724 Vdeletable_permanent_display_objects = | |
| 5725 Fcons (obj, Vdeletable_permanent_display_objects); | |
| 5726 } | |
| 5727 } | |
| 5728 | |
| 5729 void | |
| 5730 note_object_deleted (Lisp_Object obj) | |
| 5731 { | |
| 5732 if (inhibit_flags & INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION) | |
| 5733 { | |
| 5734 if (BUFFERP (obj)) | |
| 5735 Vmodifiable_buffers = delq_no_quit (obj, Vmodifiable_buffers); | |
| 5736 } | |
| 5737 if (inhibit_flags & INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION) | |
| 5738 { | |
| 5739 if (BUFFERP (obj) || WINDOWP (obj) || FRAMEP (obj) || DEVICEP (obj) | |
| 5740 || CONSOLEP (obj)) | |
| 5741 Vdeletable_permanent_display_objects = | |
| 5742 delq_no_quit (obj, Vdeletable_permanent_display_objects); | |
| 5743 } | |
| 5744 } | |
| 5745 | |
| 5746 struct call_trapping_problems | |
| 5747 { | |
| 5748 Lisp_Object catchtag; | |
| 5749 Lisp_Object error_conditions; | |
| 5750 Lisp_Object data; | |
| 5751 Lisp_Object backtrace; | |
| 5752 Lisp_Object warning_class; | |
| 5753 | |
| 867 | 5754 const CIbyte *warning_string; |
| 853 | 5755 Lisp_Object (*fun) (void *); |
| 5756 void *arg; | |
| 5757 }; | |
| 428 | 5758 |
| 2532 | 5759 static Lisp_Object |
| 5760 maybe_get_trapping_problems_backtrace (void) | |
| 5761 { | |
| 5762 Lisp_Object backtrace; | |
| 853 | 5763 |
| 1123 | 5764 if (!(inhibit_flags & INHIBIT_WARNING_ISSUE) |
| 2532 | 5765 && !warning_will_be_discarded (current_warning_level ())) |
| 428 | 5766 { |
| 1333 | 5767 struct gcpro gcpro1; |
| 5768 Lisp_Object lstream = Qnil; | |
| 5769 int speccount = specpdl_depth (); | |
| 5770 | |
| 853 | 5771 /* We're no longer protected against errors or quit here, so at |
| 5772 least let's temporarily inhibit quit. We definitely do not | |
| 5773 want to inhibit quit during the calling of the function | |
| 5774 itself!!!!!!!!!!! */ | |
| 5775 | |
| 5776 specbind (Qinhibit_quit, Qt); | |
| 5777 | |
| 5778 GCPRO1 (lstream); | |
| 5779 lstream = make_resizing_buffer_output_stream (); | |
| 5780 Fbacktrace (lstream, Qt); | |
| 5781 Lstream_flush (XLSTREAM (lstream)); | |
| 2532 | 5782 backtrace = resizing_buffer_to_lisp_string (XLSTREAM (lstream)); |
| 853 | 5783 Lstream_delete (XLSTREAM (lstream)); |
| 5784 UNGCPRO; | |
| 5785 | |
| 5786 unbind_to (speccount); | |
| 428 | 5787 } |
| 853 | 5788 else |
| 2532 | 5789 backtrace = Qnil; |
| 5790 | |
| 5791 return backtrace; | |
| 5792 } | |
| 5793 | |
| 5794 static DECLARE_DOESNT_RETURN_TYPE | |
| 5795 (Lisp_Object, flagged_a_squirmer (Lisp_Object, Lisp_Object, Lisp_Object)); | |
| 5796 | |
| 5797 static DOESNT_RETURN_TYPE (Lisp_Object) | |
| 5798 flagged_a_squirmer (Lisp_Object error_conditions, Lisp_Object data, | |
| 5799 Lisp_Object opaque) | |
| 5800 { | |
| 5801 struct call_trapping_problems *p = | |
| 5802 (struct call_trapping_problems *) get_opaque_ptr (opaque); | |
| 5803 | |
| 5804 if (!EQ (error_conditions, Qquit)) | |
| 5805 p->backtrace = maybe_get_trapping_problems_backtrace (); | |
| 5806 else | |
| 853 | 5807 p->backtrace = Qnil; |
| 5808 p->error_conditions = error_conditions; | |
| 5809 p->data = data; | |
| 5810 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5811 throw_or_bomb_out (p->catchtag, Qnil, 0, Qnil, Qnil); |
| 2268 | 5812 RETURN_NOT_REACHED (Qnil); |
| 853 | 5813 } |
| 5814 | |
| 5815 static Lisp_Object | |
| 5816 call_trapping_problems_2 (Lisp_Object opaque) | |
| 5817 { | |
| 5818 struct call_trapping_problems *p = | |
| 5819 (struct call_trapping_problems *) get_opaque_ptr (opaque); | |
| 5820 | |
| 5821 return (p->fun) (p->arg); | |
| 428 | 5822 } |
| 5823 | |
| 5824 static Lisp_Object | |
| 853 | 5825 call_trapping_problems_1 (Lisp_Object opaque) |
| 5826 { | |
| 5827 return call_with_condition_handler (flagged_a_squirmer, opaque, | |
| 5828 call_trapping_problems_2, opaque); | |
| 5829 } | |
| 5830 | |
| 1333 | 5831 static void |
| 5832 issue_call_trapping_problems_warning (Lisp_Object warning_class, | |
| 5833 const CIbyte *warning_string, | |
| 5834 struct call_trapping_problems_result *p) | |
| 5835 { | |
| 5836 if (!warning_will_be_discarded (current_warning_level ())) | |
| 5837 { | |
| 5838 int depth = specpdl_depth (); | |
| 5839 | |
| 5840 /* We're no longer protected against errors or quit here, so at | |
| 5841 least let's temporarily inhibit quit. */ | |
| 5842 specbind (Qinhibit_quit, Qt); | |
| 5843 | |
| 5844 if (p->caught_throw) | |
| 5845 { | |
| 5846 Lisp_Object errstr = | |
| 5847 emacs_sprintf_string_lisp | |
| 2532 | 5848 ("%s: Attempt to throw outside of function:" |
| 5849 "To catch `%s' with value `%s'\n\nBacktrace follows:\n\n%s", | |
| 2725 | 5850 Qnil, 4, |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
5851 build_msg_cistring (warning_string ? warning_string : "error"), |
| 2532 | 5852 p->thrown_tag, p->thrown_value, p->backtrace); |
| 1333 | 5853 warn_when_safe_lispobj (Qerror, current_warning_level (), errstr); |
| 5854 } | |
| 2421 | 5855 else if (p->caught_error && !EQ (p->error_conditions, Qquit)) |
| 1333 | 5856 { |
| 5857 Lisp_Object errstr; | |
| 5858 /* #### This should call | |
| 5859 (with-output-to-string (display-error (cons error_conditions | |
| 5860 data)) | |
| 5861 but that stuff is all in Lisp currently. */ | |
| 5862 errstr = | |
| 5863 emacs_sprintf_string_lisp | |
| 5864 ("%s: (%s %s)\n\nBacktrace follows:\n\n%s", | |
| 5865 Qnil, 4, | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
5866 build_msg_cistring (warning_string ? warning_string : "error"), |
| 1333 | 5867 p->error_conditions, p->data, p->backtrace); |
| 5868 | |
| 5869 warn_when_safe_lispobj (warning_class, current_warning_level (), | |
| 5870 errstr); | |
| 5871 } | |
| 5872 | |
| 5873 unbind_to (depth); | |
| 5874 } | |
| 5875 } | |
| 5876 | |
| 1318 | 5877 /* Turn on the trapping flags in FLAGS -- see call_trapping_problems(). |
| 5878 This cannot handle INTERNAL_INHIBIT_THROWS() or INTERNAL_INHIBIT_ERRORS | |
| 5879 (because they ultimately boil down to a setjmp()!) -- you must directly | |
| 5880 use call_trapping_problems() for that. Turn the flags off with | |
| 5881 unbind_to(). Returns the "canonicalized" flags (particularly in the | |
| 5882 case of INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY, which is shorthand for | |
| 5883 various other flags). */ | |
| 5884 | |
| 5885 int | |
| 5886 set_trapping_problems_flags (int flags) | |
| 5887 { | |
| 5888 int new_inhibit_flags; | |
| 5889 | |
| 5890 if (flags & INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY) | |
| 5891 flags |= INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION | |
| 5892 | INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION | |
| 5893 | INHIBIT_ENTERING_DEBUGGER | |
| 5894 | INHIBIT_WARNING_ISSUE | |
| 5895 | INHIBIT_GC; | |
| 5896 | |
| 5897 new_inhibit_flags = inhibit_flags | flags; | |
| 5898 if (new_inhibit_flags != inhibit_flags) | |
| 5899 internal_bind_int (&inhibit_flags, new_inhibit_flags); | |
| 5900 | |
| 5901 if (flags & INHIBIT_QUIT) | |
| 5902 specbind (Qinhibit_quit, Qt); | |
| 5903 | |
| 5904 if (flags & UNINHIBIT_QUIT) | |
| 5905 begin_do_check_for_quit (); | |
| 5906 | |
| 5907 if (flags & INHIBIT_GC) | |
| 5908 begin_gc_forbidden (); | |
| 5909 | |
| 5910 /* #### If we have nested calls to call_trapping_problems(), and the | |
| 5911 inner one creates some buffers/etc., should the outer one be able | |
| 5912 to delete them? I think so, but it means we need to combine rather | |
| 5913 than just reset the value. */ | |
| 5914 if (flags & INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION) | |
| 5915 internal_bind_lisp_object (&Vdeletable_permanent_display_objects, Qnil); | |
| 5916 | |
| 5917 if (flags & INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION) | |
| 5918 internal_bind_lisp_object (&Vmodifiable_buffers, Qnil); | |
| 5919 | |
| 5920 return flags; | |
| 5921 } | |
| 5922 | |
| 853 | 5923 /* This is equivalent to (*fun) (arg), except that various conditions |
| 5924 can be trapped or inhibited, according to FLAGS. | |
| 5925 | |
| 5926 If FLAGS does not contain NO_INHIBIT_ERRORS, when an error occurs, | |
| 5927 the error is caught and a warning is issued, specifying the | |
| 5928 specific error that occurred and a backtrace. In that case, | |
| 5929 WARNING_STRING should be given, and will be printed at the | |
| 5930 beginning of the error to indicate where the error occurred. | |
| 5931 | |
| 5932 If FLAGS does not contain NO_INHIBIT_THROWS, all attempts to | |
| 5933 `throw' out of the function being called are trapped, and a warning | |
| 5934 issued. (Again, WARNING_STRING should be given.) | |
| 5935 | |
| 2367 | 5936 If FLAGS contains INHIBIT_WARNING_ISSUE, no warnings are issued; |
| 853 | 5937 this applies to recursive invocations of call_trapping_problems, too. |
| 5938 | |
| 1333 | 5939 If FLAGS contains POSTPONE_WARNING_ISSUE, no warnings are issued; |
| 5940 but values useful for generating a warning are still computed (in | |
| 5941 particular, the backtrace), so that the calling function can issue | |
| 5942 a warning. | |
| 5943 | |
| 853 | 5944 If FLAGS contains ISSUE_WARNINGS_AT_DEBUG_LEVEL, warnings will be |
| 5945 issued, but at level `debug', which normally is below the minimum | |
| 5946 specified by `log-warning-minimum-level', meaning such warnings will | |
| 5947 be ignored entirely. The user can change this variable, however, | |
| 5948 to see the warnings.) | |
| 5949 | |
| 5950 Note: If neither of NO_INHIBIT_THROWS or NO_INHIBIT_ERRORS is | |
| 5951 given, you are *guaranteed* that there will be no non-local exits | |
| 5952 out of this function. | |
| 5953 | |
| 5954 If FLAGS contains INHIBIT_QUIT, QUIT using C-g is inhibited. (This | |
| 5955 is *rarely* a good idea. Unless you use NO_INHIBIT_ERRORS, QUIT is | |
| 5956 automatically caught as well, and treated as an error; you can | |
| 5957 check for this using EQ (problems->error_conditions, Qquit). | |
| 5958 | |
| 5959 If FLAGS contains UNINHIBIT_QUIT, QUIT checking will be explicitly | |
| 5960 turned on. (It will abort the code being called, but will still be | |
| 5961 trapped and reported as an error, unless NO_INHIBIT_ERRORS is | |
| 5962 given.) This is useful when QUIT checking has been turned off by a | |
| 5963 higher-level caller. | |
| 5964 | |
| 5965 If FLAGS contains INHIBIT_GC, garbage collection is inhibited. | |
| 1123 | 5966 This is useful for Lisp called within redisplay, for example. |
| 853 | 5967 |
| 5968 If FLAGS contains INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION, | |
| 5969 Lisp code is not allowed to delete any window, buffers, frames, devices, | |
| 5970 or consoles that were already in existence at the time this function | |
| 5971 was called. (However, it's perfectly legal for code to create a new | |
| 5972 buffer and then delete it.) | |
| 5973 | |
| 5974 #### It might be useful to have a flag that inhibits deletion of a | |
| 5975 specific permanent display object and everything it's attached to | |
| 5976 (e.g. a window, and the buffer, frame, device, and console it's | |
| 5977 attached to. | |
| 5978 | |
| 5979 If FLAGS contains INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION, Lisp | |
| 5980 code is not allowed to modify the text of any buffers that were | |
| 5981 already in existence at the time this function was called. | |
| 5982 (However, it's perfectly legal for code to create a new buffer and | |
| 5983 then modify its text.) | |
| 5984 | |
| 5985 [These last two flags are implemented using global variables | |
| 5986 Vdeletable_permanent_display_objects and Vmodifiable_buffers, | |
| 5987 which keep track of a list of all buffers or permanent display | |
| 5988 objects created since the last time one of these flags was set. | |
| 5989 The code that deletes buffers, etc. and modifies buffers checks | |
| 5990 | |
| 5991 (1) if the corresponding flag is set (through the global variable | |
| 5992 inhibit_flags or its accessor function get_inhibit_flags()), and | |
| 5993 | |
| 5994 (2) if the object to be modified or deleted is not in the | |
| 5995 appropriate list. | |
| 5996 | |
| 5997 If so, it signals an error. | |
| 5998 | |
| 5999 Recursive calls to call_trapping_problems() are allowed. In | |
| 6000 the case of the two flags mentioned above, the current values | |
| 6001 of the global variables are stored in an unwind-protect, and | |
| 6002 they're reset to nil.] | |
| 6003 | |
| 6004 If FLAGS contains INHIBIT_ENTERING_DEBUGGER, the debugger will not | |
| 6005 be entered if an error occurs inside the Lisp code being called, | |
| 6006 even when the user has requested an error. In such case, a warning | |
| 6007 is issued stating that access to the debugger is denied, unless | |
| 6008 INHIBIT_WARNING_ISSUE has also been supplied. This is useful when | |
| 6009 calling Lisp code inside redisplay, in menu callbacks, etc. because | |
| 6010 in such cases either the display is in an inconsistent state or | |
| 6011 doing window operations is explicitly forbidden by the OS, and the | |
| 6012 debugger would causes visual changes on the screen and might create | |
| 6013 another frame. | |
| 6014 | |
| 6015 If FLAGS contains INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY, no | |
| 6016 changes of any sort to extents, faces, glyphs, buffer text, | |
| 6017 specifiers relating to display, other variables relating to | |
| 6018 display, splitting, deleting, or resizing windows or frames, | |
| 6019 deleting buffers, windows, frames, devices, or consoles, etc. is | |
| 6020 allowed. This is for things called absolutely in the middle of | |
| 6021 redisplay, which expects things to be *exactly* the same after the | |
| 6022 call as before. This isn't completely implemented and needs to be | |
| 6023 thought out some more to determine exactly what its semantics are. | |
| 6024 For the moment, turning on this flag also turns on | |
| 6025 | |
| 6026 INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION | |
| 6027 INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION | |
| 6028 INHIBIT_ENTERING_DEBUGGER | |
| 6029 INHIBIT_WARNING_ISSUE | |
| 6030 INHIBIT_GC | |
| 6031 | |
| 6032 #### The following five flags are defined, but unimplemented: | |
| 6033 | |
| 6034 #define INHIBIT_EXISTING_CODING_SYSTEM_DELETION (1<<6) | |
| 6035 #define INHIBIT_EXISTING_CHARSET_DELETION (1<<7) | |
| 6036 #define INHIBIT_PERMANENT_DISPLAY_OBJECT_CREATION (1<<8) | |
| 6037 #define INHIBIT_CODING_SYSTEM_CREATION (1<<9) | |
| 6038 #define INHIBIT_CHARSET_CREATION (1<<10) | |
| 6039 | |
| 6040 FLAGS containing CALL_WITH_SUSPENDED_ERRORS is a sign that | |
| 6041 call_with_suspended_errors() was invoked. This exists only for | |
| 6042 debugging purposes -- often we want to break when a signal happens, | |
| 6043 but ignore signals from call_with_suspended_errors(), because they | |
| 6044 occur often and for legitimate reasons. | |
| 6045 | |
| 6046 If PROBLEM is non-zero, it should be a pointer to a structure into | |
| 6047 which exact information about any occurring problems (either an | |
| 6048 error or an attempted throw past this boundary). | |
| 6049 | |
| 6050 If a problem occurred and aborted operation (error, quit, or | |
| 6051 invalid throw), Qunbound is returned. Otherwise the return value | |
| 6052 from the call to (*fun) (arg) is returned. */ | |
| 6053 | |
| 6054 Lisp_Object | |
| 6055 call_trapping_problems (Lisp_Object warning_class, | |
| 867 | 6056 const CIbyte *warning_string, |
| 853 | 6057 int flags, |
| 6058 struct call_trapping_problems_result *problem, | |
| 6059 Lisp_Object (*fun) (void *), | |
| 6060 void *arg) | |
| 6061 { | |
| 1318 | 6062 int speccount = specpdl_depth (); |
| 853 | 6063 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; |
| 6064 struct call_trapping_problems package; | |
| 1333 | 6065 struct call_trapping_problems_result real_problem; |
| 2532 | 6066 Lisp_Object opaque, thrown_tag, tem, thrown_backtrace; |
| 853 | 6067 int thrown = 0; |
| 6068 | |
| 6069 assert (SYMBOLP (warning_class)); /* sanity-check */ | |
| 6070 assert (!NILP (warning_class)); | |
| 6071 | |
| 6072 flags ^= INTERNAL_INHIBIT_ERRORS | INTERNAL_INHIBIT_THROWS; | |
| 6073 | |
| 6074 package.warning_class = warning_class; | |
| 6075 package.warning_string = warning_string; | |
| 6076 package.fun = fun; | |
| 6077 package.arg = arg; | |
| 6078 package.catchtag = | |
| 6079 flags & INTERNAL_INHIBIT_THROWS ? Vcatch_everything_tag : | |
| 6080 flags & INTERNAL_INHIBIT_ERRORS ? make_opaque_ptr (0) : | |
| 6081 Qnil; | |
| 6082 package.error_conditions = Qnil; | |
| 6083 package.data = Qnil; | |
| 6084 package.backtrace = Qnil; | |
| 6085 | |
| 1318 | 6086 flags = set_trapping_problems_flags (flags); |
| 853 | 6087 |
| 6088 if (flags & (INTERNAL_INHIBIT_THROWS | INTERNAL_INHIBIT_ERRORS)) | |
| 6089 opaque = make_opaque_ptr (&package); | |
| 6090 else | |
| 6091 opaque = Qnil; | |
| 6092 | |
| 6093 GCPRO5 (package.catchtag, package.error_conditions, package.data, | |
| 6094 package.backtrace, opaque); | |
| 6095 | |
| 6096 if (flags & INTERNAL_INHIBIT_ERRORS) | |
| 6097 /* We need a catch so that our condition-handler can throw back here | |
| 6098 after printing the warning. (We print the warning in the stack | |
| 6099 context of the error, so we can get a backtrace.) */ | |
| 6100 tem = internal_catch (package.catchtag, call_trapping_problems_1, opaque, | |
| 2532 | 6101 &thrown, &thrown_tag, &thrown_backtrace); |
| 853 | 6102 else if (flags & INTERNAL_INHIBIT_THROWS) |
| 6103 /* We skip over the first wrapper, which traps errors. */ | |
| 6104 tem = internal_catch (package.catchtag, call_trapping_problems_2, opaque, | |
| 2532 | 6105 &thrown, &thrown_tag, &thrown_backtrace); |
| 853 | 6106 else |
| 6107 /* Nothing special. */ | |
| 6108 tem = (fun) (arg); | |
| 6109 | |
| 1333 | 6110 if (!problem) |
| 6111 problem = &real_problem; | |
| 6112 | |
| 6113 if (!thrown) | |
| 853 | 6114 { |
| 1333 | 6115 problem->caught_error = 0; |
| 6116 problem->caught_throw = 0; | |
| 6117 problem->error_conditions = Qnil; | |
| 6118 problem->data = Qnil; | |
| 6119 problem->backtrace = Qnil; | |
| 6120 problem->thrown_tag = Qnil; | |
| 6121 problem->thrown_value = Qnil; | |
| 853 | 6122 } |
| 1333 | 6123 else if (EQ (thrown_tag, package.catchtag)) |
| 853 | 6124 { |
| 1333 | 6125 problem->caught_error = 1; |
| 6126 problem->caught_throw = 0; | |
| 6127 problem->error_conditions = package.error_conditions; | |
| 6128 problem->data = package.data; | |
| 6129 problem->backtrace = package.backtrace; | |
| 6130 problem->thrown_tag = Qnil; | |
| 6131 problem->thrown_value = Qnil; | |
| 853 | 6132 } |
| 1333 | 6133 else |
| 6134 { | |
| 6135 problem->caught_error = 0; | |
| 6136 problem->caught_throw = 1; | |
| 6137 problem->error_conditions = Qnil; | |
| 6138 problem->data = Qnil; | |
| 2532 | 6139 problem->backtrace = thrown_backtrace; |
| 1333 | 6140 problem->thrown_tag = thrown_tag; |
| 6141 problem->thrown_value = tem; | |
| 6142 } | |
| 6143 | |
| 6144 if (!(flags & INHIBIT_WARNING_ISSUE) && !(flags & POSTPONE_WARNING_ISSUE)) | |
| 6145 issue_call_trapping_problems_warning (warning_class, warning_string, | |
| 6146 problem); | |
| 853 | 6147 |
| 6148 if (!NILP (package.catchtag) && | |
| 6149 !EQ (package.catchtag, Vcatch_everything_tag)) | |
| 6150 free_opaque_ptr (package.catchtag); | |
| 6151 | |
| 6152 if (!NILP (opaque)) | |
| 6153 free_opaque_ptr (opaque); | |
| 6154 | |
| 6155 unbind_to (speccount); | |
| 6156 RETURN_UNGCPRO (thrown ? Qunbound : tem); | |
| 6157 } | |
| 6158 | |
| 6159 struct va_call_trapping_problems | |
| 6160 { | |
| 6161 lisp_fn_t fun; | |
| 6162 int nargs; | |
| 6163 Lisp_Object *args; | |
| 6164 }; | |
| 6165 | |
| 6166 static Lisp_Object | |
| 6167 va_call_trapping_problems_1 (void *ai_mi_madre) | |
| 6168 { | |
| 6169 struct va_call_trapping_problems *ai_no_corrida = | |
| 6170 (struct va_call_trapping_problems *) ai_mi_madre; | |
| 6171 Lisp_Object pegar_no_bumbum; | |
| 6172 | |
| 6173 PRIMITIVE_FUNCALL (pegar_no_bumbum, ai_no_corrida->fun, | |
| 6174 ai_no_corrida->args, ai_no_corrida->nargs); | |
| 6175 return pegar_no_bumbum; | |
| 6176 } | |
| 6177 | |
| 6178 /* #### document me. */ | |
| 6179 | |
| 6180 Lisp_Object | |
| 6181 va_call_trapping_problems (Lisp_Object warning_class, | |
| 867 | 6182 const CIbyte *warning_string, |
| 853 | 6183 int flags, |
| 6184 struct call_trapping_problems_result *problem, | |
| 6185 lisp_fn_t fun, int nargs, ...) | |
| 6186 { | |
| 6187 va_list vargs; | |
| 6188 Lisp_Object args[20]; | |
| 6189 int i; | |
| 6190 struct va_call_trapping_problems fazer_invocacao_atrapalhando_problemas; | |
| 6191 struct gcpro gcpro1; | |
| 6192 | |
| 6193 assert (nargs >= 0 && nargs < 20); | |
| 6194 | |
| 6195 va_start (vargs, nargs); | |
| 6196 for (i = 0; i < nargs; i++) | |
| 6197 args[i] = va_arg (vargs, Lisp_Object); | |
| 6198 va_end (vargs); | |
| 6199 | |
| 6200 fazer_invocacao_atrapalhando_problemas.fun = fun; | |
| 6201 fazer_invocacao_atrapalhando_problemas.nargs = nargs; | |
| 6202 fazer_invocacao_atrapalhando_problemas.args = args; | |
| 6203 | |
| 6204 GCPRO1_ARRAY (args, nargs); | |
| 6205 RETURN_UNGCPRO | |
| 6206 (call_trapping_problems | |
| 6207 (warning_class, warning_string, flags, problem, | |
| 6208 va_call_trapping_problems_1, &fazer_invocacao_atrapalhando_problemas)); | |
| 6209 } | |
| 6210 | |
| 6211 /* this is an older interface, barely different from | |
| 6212 va_call_trapping_problems. | |
| 6213 | |
| 6214 #### eliminate this or at least merge the ERROR_BEHAVIOR stuff into | |
| 6215 va_call_trapping_problems(). */ | |
| 6216 | |
| 6217 Lisp_Object | |
| 6218 call_with_suspended_errors (lisp_fn_t fun, Lisp_Object retval, | |
| 1204 | 6219 Lisp_Object class_, Error_Behavior errb, |
| 853 | 6220 int nargs, ...) |
| 6221 { | |
| 6222 va_list vargs; | |
| 6223 Lisp_Object args[20]; | |
| 6224 int i; | |
| 6225 struct va_call_trapping_problems fazer_invocacao_atrapalhando_problemas; | |
| 6226 int flags; | |
| 6227 struct gcpro gcpro1; | |
| 6228 | |
| 1204 | 6229 assert (SYMBOLP (class_)); /* sanity-check */ |
| 6230 assert (!NILP (class_)); | |
| 853 | 6231 assert (nargs >= 0 && nargs < 20); |
| 6232 | |
| 6233 va_start (vargs, nargs); | |
| 6234 for (i = 0; i < nargs; i++) | |
| 6235 args[i] = va_arg (vargs, Lisp_Object); | |
| 6236 va_end (vargs); | |
| 6237 | |
| 6238 /* If error-checking is not disabled, just call the function. */ | |
| 6239 | |
| 6240 if (ERRB_EQ (errb, ERROR_ME)) | |
| 6241 { | |
| 6242 Lisp_Object val; | |
| 6243 PRIMITIVE_FUNCALL (val, fun, args, nargs); | |
| 6244 return val; | |
| 6245 } | |
| 6246 | |
| 6247 if (ERRB_EQ (errb, ERROR_ME_NOT)) /* person wants no warnings */ | |
| 6248 flags = INHIBIT_WARNING_ISSUE | INHIBIT_ENTERING_DEBUGGER; | |
| 6249 else if (ERRB_EQ (errb, ERROR_ME_DEBUG_WARN)) | |
| 6250 flags = ISSUE_WARNINGS_AT_DEBUG_LEVEL | INHIBIT_ENTERING_DEBUGGER; | |
| 6251 else | |
| 6252 { | |
| 6253 assert (ERRB_EQ (errb, ERROR_ME_WARN)); | |
| 6254 flags = INHIBIT_ENTERING_DEBUGGER; | |
| 6255 } | |
| 6256 | |
| 6257 flags |= CALL_WITH_SUSPENDED_ERRORS; | |
| 6258 | |
| 6259 fazer_invocacao_atrapalhando_problemas.fun = fun; | |
| 6260 fazer_invocacao_atrapalhando_problemas.nargs = nargs; | |
| 6261 fazer_invocacao_atrapalhando_problemas.args = args; | |
| 6262 | |
| 6263 GCPRO1_ARRAY (args, nargs); | |
| 6264 { | |
| 6265 Lisp_Object its_way_too_goddamn_late = | |
| 6266 call_trapping_problems | |
| 1204 | 6267 (class_, 0, flags, 0, va_call_trapping_problems_1, |
| 853 | 6268 &fazer_invocacao_atrapalhando_problemas); |
| 6269 UNGCPRO; | |
| 6270 if (UNBOUNDP (its_way_too_goddamn_late)) | |
| 6271 return retval; | |
| 6272 else | |
| 6273 return its_way_too_goddamn_late; | |
| 6274 } | |
| 6275 } | |
| 6276 | |
| 6277 struct calln_trapping_problems | |
| 6278 { | |
| 6279 int nargs; | |
| 6280 Lisp_Object *args; | |
| 6281 }; | |
| 6282 | |
| 6283 static Lisp_Object | |
| 6284 calln_trapping_problems_1 (void *puta) | |
| 6285 { | |
| 6286 struct calln_trapping_problems *p = (struct calln_trapping_problems *) puta; | |
| 6287 | |
| 6288 return Ffuncall (p->nargs, p->args); | |
| 428 | 6289 } |
| 6290 | |
| 6291 static Lisp_Object | |
| 853 | 6292 calln_trapping_problems (Lisp_Object warning_class, |
| 867 | 6293 const CIbyte *warning_string, int flags, |
| 853 | 6294 struct call_trapping_problems_result *problem, |
| 6295 int nargs, Lisp_Object *args) | |
| 6296 { | |
| 6297 struct calln_trapping_problems foo; | |
| 6298 struct gcpro gcpro1; | |
| 6299 | |
| 6300 if (SYMBOLP (args[0])) | |
| 6301 { | |
| 6302 Lisp_Object tem = XSYMBOL (args[0])->function; | |
| 6303 if (NILP (tem) || UNBOUNDP (tem)) | |
| 6304 { | |
| 6305 if (problem) | |
| 6306 { | |
| 6307 problem->caught_error = 0; | |
| 6308 problem->caught_throw = 0; | |
| 6309 problem->error_conditions = Qnil; | |
| 6310 problem->data = Qnil; | |
| 6311 problem->backtrace = Qnil; | |
| 6312 problem->thrown_tag = Qnil; | |
| 6313 problem->thrown_value = Qnil; | |
| 6314 } | |
| 6315 return Qnil; | |
| 6316 } | |
| 6317 } | |
| 6318 | |
| 6319 foo.nargs = nargs; | |
| 6320 foo.args = args; | |
| 6321 | |
| 6322 GCPRO1_ARRAY (args, nargs); | |
| 6323 RETURN_UNGCPRO (call_trapping_problems (warning_class, warning_string, | |
| 6324 flags, problem, | |
| 6325 calln_trapping_problems_1, | |
| 6326 &foo)); | |
| 6327 } | |
| 6328 | |
| 6329 /* #### fix these functions to follow the calling convention of | |
| 6330 call_trapping_problems! */ | |
| 6331 | |
| 6332 Lisp_Object | |
| 867 | 6333 call0_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6334 int flags) |
| 6335 { | |
| 6336 return calln_trapping_problems (Qerror, warning_string, flags, 0, 1, | |
| 6337 &function); | |
| 428 | 6338 } |
| 6339 | |
| 6340 Lisp_Object | |
| 867 | 6341 call1_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6342 Lisp_Object object, int flags) |
| 6343 { | |
| 6344 Lisp_Object args[2]; | |
| 6345 | |
| 6346 args[0] = function; | |
| 6347 args[1] = object; | |
| 6348 | |
| 6349 return calln_trapping_problems (Qerror, warning_string, flags, 0, 2, | |
| 6350 args); | |
| 6351 } | |
| 6352 | |
| 6353 Lisp_Object | |
| 867 | 6354 call2_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6355 Lisp_Object object1, Lisp_Object object2, |
| 6356 int flags) | |
| 6357 { | |
| 6358 Lisp_Object args[3]; | |
| 6359 | |
| 6360 args[0] = function; | |
| 6361 args[1] = object1; | |
| 6362 args[2] = object2; | |
| 6363 | |
| 6364 return calln_trapping_problems (Qerror, warning_string, flags, 0, 3, | |
| 6365 args); | |
| 6366 } | |
| 6367 | |
| 6368 Lisp_Object | |
| 867 | 6369 call3_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6370 Lisp_Object object1, Lisp_Object object2, |
| 6371 Lisp_Object object3, int flags) | |
| 6372 { | |
| 6373 Lisp_Object args[4]; | |
| 6374 | |
| 6375 args[0] = function; | |
| 6376 args[1] = object1; | |
| 6377 args[2] = object2; | |
| 6378 args[3] = object3; | |
| 6379 | |
| 6380 return calln_trapping_problems (Qerror, warning_string, flags, 0, 4, | |
| 6381 args); | |
| 6382 } | |
| 6383 | |
| 6384 Lisp_Object | |
| 867 | 6385 call4_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6386 Lisp_Object object1, Lisp_Object object2, |
| 6387 Lisp_Object object3, Lisp_Object object4, | |
| 6388 int flags) | |
| 6389 { | |
| 6390 Lisp_Object args[5]; | |
| 6391 | |
| 6392 args[0] = function; | |
| 6393 args[1] = object1; | |
| 6394 args[2] = object2; | |
| 6395 args[3] = object3; | |
| 6396 args[4] = object4; | |
| 6397 | |
| 6398 return calln_trapping_problems (Qerror, warning_string, flags, 0, 5, | |
| 6399 args); | |
| 6400 } | |
| 6401 | |
| 6402 Lisp_Object | |
| 867 | 6403 call5_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6404 Lisp_Object object1, Lisp_Object object2, |
| 6405 Lisp_Object object3, Lisp_Object object4, | |
| 6406 Lisp_Object object5, int flags) | |
| 6407 { | |
| 6408 Lisp_Object args[6]; | |
| 6409 | |
| 6410 args[0] = function; | |
| 6411 args[1] = object1; | |
| 6412 args[2] = object2; | |
| 6413 args[3] = object3; | |
| 6414 args[4] = object4; | |
| 6415 args[5] = object5; | |
| 6416 | |
| 6417 return calln_trapping_problems (Qerror, warning_string, flags, 0, 6, | |
| 6418 args); | |
| 6419 } | |
| 6420 | |
| 6421 struct eval_in_buffer_trapping_problems | |
| 6422 { | |
| 6423 struct buffer *buf; | |
| 6424 Lisp_Object form; | |
| 6425 }; | |
| 6426 | |
| 6427 static Lisp_Object | |
| 6428 eval_in_buffer_trapping_problems_1 (void *arg) | |
| 6429 { | |
| 6430 struct eval_in_buffer_trapping_problems *p = | |
| 6431 (struct eval_in_buffer_trapping_problems *) arg; | |
| 6432 | |
| 6433 return eval_in_buffer (p->buf, p->form); | |
| 6434 } | |
| 6435 | |
| 6436 /* #### fix these functions to follow the calling convention of | |
| 6437 call_trapping_problems! */ | |
| 6438 | |
| 6439 Lisp_Object | |
| 867 | 6440 eval_in_buffer_trapping_problems (const CIbyte *warning_string, |
| 853 | 6441 struct buffer *buf, Lisp_Object form, |
| 6442 int flags) | |
| 6443 { | |
| 6444 struct eval_in_buffer_trapping_problems p; | |
| 6445 Lisp_Object buffer = wrap_buffer (buf); | |
| 428 | 6446 struct gcpro gcpro1, gcpro2; |
| 6447 | |
| 853 | 6448 GCPRO2 (buffer, form); |
| 6449 p.buf = buf; | |
| 6450 p.form = form; | |
| 6451 RETURN_UNGCPRO (call_trapping_problems (Qerror, warning_string, flags, 0, | |
| 6452 eval_in_buffer_trapping_problems_1, | |
| 6453 &p)); | |
| 6454 } | |
| 6455 | |
| 6456 Lisp_Object | |
| 1333 | 6457 run_hook_trapping_problems (Lisp_Object warning_class, |
| 853 | 6458 Lisp_Object hook_symbol, |
| 6459 int flags) | |
| 6460 { | |
| 1333 | 6461 return run_hook_with_args_trapping_problems (warning_class, 1, &hook_symbol, |
| 853 | 6462 RUN_HOOKS_TO_COMPLETION, |
| 6463 flags); | |
| 428 | 6464 } |
| 6465 | |
| 6466 static Lisp_Object | |
| 853 | 6467 safe_run_hook_trapping_problems_1 (void *puta) |
| 6468 { | |
| 5013 | 6469 Lisp_Object hook = GET_LISP_FROM_VOID (puta); |
| 853 | 6470 |
| 6471 run_hook (hook); | |
| 428 | 6472 return Qnil; |
| 6473 } | |
| 6474 | |
| 853 | 6475 /* Same as run_hook_trapping_problems() but also set the hook to nil |
| 6476 if an error occurs (but not a quit). */ | |
| 6477 | |
| 428 | 6478 Lisp_Object |
| 1333 | 6479 safe_run_hook_trapping_problems (Lisp_Object warning_class, |
| 6480 Lisp_Object hook_symbol, int flags) | |
| 853 | 6481 { |
| 428 | 6482 Lisp_Object tem; |
| 853 | 6483 struct gcpro gcpro1, gcpro2; |
| 6484 struct call_trapping_problems_result prob; | |
| 428 | 6485 |
| 6486 if (!initialized || preparing_for_armageddon) | |
| 6487 return Qnil; | |
| 6488 tem = find_symbol_value (hook_symbol); | |
| 6489 if (NILP (tem) || UNBOUNDP (tem)) | |
| 6490 return Qnil; | |
| 6491 | |
| 853 | 6492 GCPRO2 (hook_symbol, tem); |
| 1333 | 6493 tem = call_trapping_problems (Qerror, NULL, |
| 6494 flags | POSTPONE_WARNING_ISSUE, | |
| 853 | 6495 &prob, |
| 6496 safe_run_hook_trapping_problems_1, | |
| 5013 | 6497 STORE_LISP_IN_VOID (hook_symbol)); |
| 1333 | 6498 { |
| 6499 Lisp_Object hook_name = XSYMBOL_NAME (hook_symbol); | |
| 6500 Ibyte *hook_str = XSTRING_DATA (hook_name); | |
| 6501 Ibyte *err = alloca_ibytes (XSTRING_LENGTH (hook_name) + 100); | |
| 6502 | |
| 6503 if (prob.caught_throw || (prob.caught_error && !EQ (prob.error_conditions, | |
| 6504 Qquit))) | |
| 6505 { | |
| 6506 Fset (hook_symbol, Qnil); | |
| 6507 qxesprintf (err, "Error in `%s' (resetting to nil)", hook_str); | |
| 6508 } | |
| 6509 else | |
| 6510 qxesprintf (err, "Quit in `%s'", hook_str); | |
| 6511 | |
| 6512 | |
| 6513 issue_call_trapping_problems_warning (warning_class, (CIbyte *) err, | |
| 6514 &prob); | |
| 6515 } | |
| 6516 | |
| 6517 UNGCPRO; | |
| 6518 return tem; | |
| 853 | 6519 } |
| 6520 | |
| 6521 struct run_hook_with_args_in_buffer_trapping_problems | |
| 6522 { | |
| 6523 struct buffer *buf; | |
| 6524 int nargs; | |
| 6525 Lisp_Object *args; | |
| 6526 enum run_hooks_condition cond; | |
| 6527 }; | |
| 6528 | |
| 6529 static Lisp_Object | |
| 6530 run_hook_with_args_in_buffer_trapping_problems_1 (void *puta) | |
| 6531 { | |
| 6532 struct run_hook_with_args_in_buffer_trapping_problems *porra = | |
| 6533 (struct run_hook_with_args_in_buffer_trapping_problems *) puta; | |
| 6534 | |
| 6535 return run_hook_with_args_in_buffer (porra->buf, porra->nargs, porra->args, | |
| 6536 porra->cond); | |
| 6537 } | |
| 6538 | |
| 6539 /* #### fix these functions to follow the calling convention of | |
| 6540 call_trapping_problems! */ | |
| 428 | 6541 |
| 6542 Lisp_Object | |
| 1333 | 6543 run_hook_with_args_in_buffer_trapping_problems (Lisp_Object warning_class, |
| 853 | 6544 struct buffer *buf, int nargs, |
| 6545 Lisp_Object *args, | |
| 6546 enum run_hooks_condition cond, | |
| 6547 int flags) | |
| 6548 { | |
| 6549 Lisp_Object sym, val, ret; | |
| 6550 struct run_hook_with_args_in_buffer_trapping_problems diversity_and_distrust; | |
| 428 | 6551 struct gcpro gcpro1; |
| 1333 | 6552 Lisp_Object hook_name; |
| 6553 Ibyte *hook_str; | |
| 6554 Ibyte *err; | |
| 428 | 6555 |
| 6556 if (!initialized || preparing_for_armageddon) | |
| 853 | 6557 /* We need to bail out of here pronto. */ |
| 428 | 6558 return Qnil; |
| 6559 | |
| 853 | 6560 GCPRO1_ARRAY (args, nargs); |
| 6561 | |
| 6562 sym = args[0]; | |
| 6563 val = symbol_value_in_buffer (sym, wrap_buffer (buf)); | |
| 6564 ret = (cond == RUN_HOOKS_UNTIL_FAILURE ? Qt : Qnil); | |
| 6565 | |
| 6566 if (UNBOUNDP (val) || NILP (val)) | |
| 6567 RETURN_UNGCPRO (ret); | |
| 6568 | |
| 6569 diversity_and_distrust.buf = buf; | |
| 6570 diversity_and_distrust.nargs = nargs; | |
| 6571 diversity_and_distrust.args = args; | |
| 6572 diversity_and_distrust.cond = cond; | |
| 6573 | |
| 1333 | 6574 hook_name = XSYMBOL_NAME (args[0]); |
| 6575 hook_str = XSTRING_DATA (hook_name); | |
| 6576 err = alloca_ibytes (XSTRING_LENGTH (hook_name) + 100); | |
| 6577 qxesprintf (err, "Error in `%s'", hook_str); | |
| 853 | 6578 RETURN_UNGCPRO |
| 6579 (call_trapping_problems | |
| 1333 | 6580 (warning_class, (CIbyte *) err, flags, 0, |
| 853 | 6581 run_hook_with_args_in_buffer_trapping_problems_1, |
| 6582 &diversity_and_distrust)); | |
| 428 | 6583 } |
| 6584 | |
| 6585 Lisp_Object | |
| 1333 | 6586 run_hook_with_args_trapping_problems (Lisp_Object warning_class, |
| 853 | 6587 int nargs, |
| 6588 Lisp_Object *args, | |
| 6589 enum run_hooks_condition cond, | |
| 6590 int flags) | |
| 6591 { | |
| 6592 return run_hook_with_args_in_buffer_trapping_problems | |
| 1333 | 6593 (warning_class, current_buffer, nargs, args, cond, flags); |
| 428 | 6594 } |
| 6595 | |
| 6596 Lisp_Object | |
| 1333 | 6597 va_run_hook_with_args_trapping_problems (Lisp_Object warning_class, |
| 853 | 6598 Lisp_Object hook_var, |
| 6599 int nargs, ...) | |
| 6600 { | |
| 6601 /* This function can GC */ | |
| 6602 struct gcpro gcpro1; | |
| 6603 int i; | |
| 6604 va_list vargs; | |
| 6605 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs); | |
| 6606 int flags; | |
| 6607 | |
| 6608 va_start (vargs, nargs); | |
| 6609 funcall_args[0] = hook_var; | |
| 6610 for (i = 0; i < nargs; i++) | |
| 6611 funcall_args[i + 1] = va_arg (vargs, Lisp_Object); | |
| 6612 flags = va_arg (vargs, int); | |
| 6613 va_end (vargs); | |
| 6614 | |
| 6615 GCPRO1_ARRAY (funcall_args, nargs + 1); | |
| 6616 RETURN_UNGCPRO (run_hook_with_args_in_buffer_trapping_problems | |
| 1333 | 6617 (warning_class, current_buffer, nargs + 1, funcall_args, |
| 853 | 6618 RUN_HOOKS_TO_COMPLETION, flags)); |
| 428 | 6619 } |
| 6620 | |
| 6621 Lisp_Object | |
| 1333 | 6622 va_run_hook_with_args_in_buffer_trapping_problems (Lisp_Object warning_class, |
| 853 | 6623 struct buffer *buf, |
| 6624 Lisp_Object hook_var, | |
| 6625 int nargs, ...) | |
| 6626 { | |
| 6627 /* This function can GC */ | |
| 6628 struct gcpro gcpro1; | |
| 6629 int i; | |
| 6630 va_list vargs; | |
| 6631 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs); | |
| 6632 int flags; | |
| 6633 | |
| 6634 va_start (vargs, nargs); | |
| 6635 funcall_args[0] = hook_var; | |
| 6636 for (i = 0; i < nargs; i++) | |
| 6637 funcall_args[i + 1] = va_arg (vargs, Lisp_Object); | |
| 6638 flags = va_arg (vargs, int); | |
| 6639 va_end (vargs); | |
| 6640 | |
| 6641 GCPRO1_ARRAY (funcall_args, nargs + 1); | |
| 6642 RETURN_UNGCPRO (run_hook_with_args_in_buffer_trapping_problems | |
| 1333 | 6643 (warning_class, buf, nargs + 1, funcall_args, |
| 853 | 6644 RUN_HOOKS_TO_COMPLETION, flags)); |
| 428 | 6645 } |
| 6646 | |
| 6647 | |
| 6648 /************************************************************************/ | |
| 6649 /* The special binding stack */ | |
| 771 | 6650 /* Most C code should simply use specbind() and unbind_to_1(). */ |
| 428 | 6651 /* When performance is critical, use the macros in backtrace.h. */ |
| 6652 /************************************************************************/ | |
| 6653 | |
| 6654 #define min_max_specpdl_size 400 | |
| 6655 | |
| 6656 void | |
| 647 | 6657 grow_specpdl (EMACS_INT reserved) |
| 6658 { | |
| 6659 EMACS_INT size_needed = specpdl_depth() + reserved; | |
| 428 | 6660 if (size_needed >= max_specpdl_size) |
| 6661 { | |
| 6662 if (max_specpdl_size < min_max_specpdl_size) | |
| 6663 max_specpdl_size = min_max_specpdl_size; | |
| 6664 if (size_needed >= max_specpdl_size) | |
| 6665 { | |
| 1951 | 6666 /* Leave room for some specpdl in the debugger. */ |
| 6667 max_specpdl_size = size_needed + 100; | |
| 6668 if (max_specpdl_size > specpdl_size) | |
| 6669 { | |
| 6670 specpdl_size = max_specpdl_size; | |
| 6671 XREALLOC_ARRAY (specpdl, struct specbinding, specpdl_size); | |
| 6672 specpdl_ptr = specpdl + specpdl_depth(); | |
| 6673 } | |
| 563 | 6674 signal_continuable_error |
| 6675 (Qstack_overflow, | |
| 6676 "Variable binding depth exceeds max-specpdl-size", Qunbound); | |
| 428 | 6677 } |
| 6678 } | |
| 6679 while (specpdl_size < size_needed) | |
| 6680 { | |
| 6681 specpdl_size *= 2; | |
| 6682 if (specpdl_size > max_specpdl_size) | |
| 6683 specpdl_size = max_specpdl_size; | |
| 6684 } | |
| 6685 XREALLOC_ARRAY (specpdl, struct specbinding, specpdl_size); | |
| 6686 specpdl_ptr = specpdl + specpdl_depth(); | |
| 853 | 6687 check_specbind_stack_sanity (); |
| 428 | 6688 } |
| 6689 | |
| 6690 | |
| 6691 /* Handle unbinding buffer-local variables */ | |
| 6692 static Lisp_Object | |
| 6693 specbind_unwind_local (Lisp_Object ovalue) | |
| 6694 { | |
| 6695 Lisp_Object current = Fcurrent_buffer (); | |
| 6696 Lisp_Object symbol = specpdl_ptr->symbol; | |
| 853 | 6697 Lisp_Object victim = ovalue; |
| 6698 Lisp_Object buf = get_buffer (XCAR (victim), 0); | |
| 6699 ovalue = XCDR (victim); | |
| 428 | 6700 |
| 6701 free_cons (victim); | |
| 6702 | |
| 6703 if (NILP (buf)) | |
| 6704 { | |
| 6705 /* Deleted buffer -- do nothing */ | |
| 6706 } | |
| 6707 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buf)) == 0) | |
| 6708 { | |
| 6709 /* Was buffer-local when binding was made, now no longer is. | |
| 6710 * (kill-local-variable can do this.) | |
| 6711 * Do nothing in this case. | |
| 6712 */ | |
| 6713 } | |
| 6714 else if (EQ (buf, current)) | |
| 6715 Fset (symbol, ovalue); | |
| 6716 else | |
| 6717 { | |
| 6718 /* Urk! Somebody switched buffers */ | |
| 6719 struct gcpro gcpro1; | |
| 6720 GCPRO1 (current); | |
| 6721 Fset_buffer (buf); | |
| 6722 Fset (symbol, ovalue); | |
| 6723 Fset_buffer (current); | |
| 6724 UNGCPRO; | |
| 6725 } | |
| 6726 return symbol; | |
| 6727 } | |
| 6728 | |
| 6729 static Lisp_Object | |
| 6730 specbind_unwind_wasnt_local (Lisp_Object buffer) | |
| 6731 { | |
| 6732 Lisp_Object current = Fcurrent_buffer (); | |
| 6733 Lisp_Object symbol = specpdl_ptr->symbol; | |
| 6734 | |
| 6735 buffer = get_buffer (buffer, 0); | |
| 6736 if (NILP (buffer)) | |
| 6737 { | |
| 6738 /* Deleted buffer -- do nothing */ | |
| 6739 } | |
| 6740 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buffer)) == 0) | |
| 6741 { | |
| 6742 /* Was buffer-local when binding was made, now no longer is. | |
| 6743 * (kill-local-variable can do this.) | |
| 6744 * Do nothing in this case. | |
| 6745 */ | |
| 6746 } | |
| 6747 else if (EQ (buffer, current)) | |
| 6748 Fkill_local_variable (symbol); | |
| 6749 else | |
| 6750 { | |
| 6751 /* Urk! Somebody switched buffers */ | |
| 6752 struct gcpro gcpro1; | |
| 6753 GCPRO1 (current); | |
| 6754 Fset_buffer (buffer); | |
| 6755 Fkill_local_variable (symbol); | |
| 6756 Fset_buffer (current); | |
| 6757 UNGCPRO; | |
| 6758 } | |
| 6759 return symbol; | |
| 6760 } | |
| 6761 | |
| 6762 | |
| 6763 void | |
| 6764 specbind (Lisp_Object symbol, Lisp_Object value) | |
| 6765 { | |
| 6766 SPECBIND (symbol, value); | |
| 853 | 6767 |
| 6768 check_specbind_stack_sanity (); | |
| 428 | 6769 } |
| 6770 | |
| 6771 void | |
| 6772 specbind_magic (Lisp_Object symbol, Lisp_Object value) | |
| 6773 { | |
| 6774 int buffer_local = | |
| 6775 symbol_value_buffer_local_info (symbol, current_buffer); | |
| 6776 | |
| 6777 if (buffer_local == 0) | |
| 6778 { | |
| 6779 specpdl_ptr->old_value = find_symbol_value (symbol); | |
| 771 | 6780 specpdl_ptr->func = 0; /* Handled specially by unbind_to_1 */ |
| 428 | 6781 } |
| 6782 else if (buffer_local > 0) | |
| 6783 { | |
| 6784 /* Already buffer-local */ | |
| 6785 specpdl_ptr->old_value = noseeum_cons (Fcurrent_buffer (), | |
| 6786 find_symbol_value (symbol)); | |
| 6787 specpdl_ptr->func = specbind_unwind_local; | |
| 6788 } | |
| 6789 else | |
| 6790 { | |
| 6791 /* About to become buffer-local */ | |
| 6792 specpdl_ptr->old_value = Fcurrent_buffer (); | |
| 6793 specpdl_ptr->func = specbind_unwind_wasnt_local; | |
| 6794 } | |
| 6795 | |
| 6796 specpdl_ptr->symbol = symbol; | |
| 6797 specpdl_ptr++; | |
| 6798 specpdl_depth_counter++; | |
| 6799 | |
| 6800 Fset (symbol, value); | |
| 853 | 6801 |
| 6802 check_specbind_stack_sanity (); | |
| 428 | 6803 } |
| 6804 | |
| 771 | 6805 /* Record an unwind-protect -- FUNCTION will be called with ARG no matter |
| 6806 whether a normal or non-local exit occurs. (You need to call unbind_to_1() | |
| 6807 before your function returns normally, passing in the integer returned | |
| 6808 by this function.) Note: As long as the unwind-protect exists, ARG is | |
| 6809 automatically GCPRO'd. The return value from FUNCTION is completely | |
| 6810 ignored. #### We should eliminate it entirely. */ | |
| 6811 | |
| 6812 int | |
| 428 | 6813 record_unwind_protect (Lisp_Object (*function) (Lisp_Object arg), |
| 6814 Lisp_Object arg) | |
| 6815 { | |
| 6816 SPECPDL_RESERVE (1); | |
| 6817 specpdl_ptr->func = function; | |
| 6818 specpdl_ptr->symbol = Qnil; | |
| 6819 specpdl_ptr->old_value = arg; | |
| 6820 specpdl_ptr++; | |
| 6821 specpdl_depth_counter++; | |
| 853 | 6822 check_specbind_stack_sanity (); |
| 771 | 6823 return specpdl_depth_counter - 1; |
| 6824 } | |
| 6825 | |
| 6826 static Lisp_Object | |
| 802 | 6827 restore_lisp_object (Lisp_Object cons) |
| 6828 { | |
| 5013 | 6829 Lisp_Object laddr = XCAR (cons); |
| 6830 Lisp_Object *addr = (Lisp_Object *) GET_VOID_FROM_LISP (laddr); | |
| 802 | 6831 *addr = XCDR (cons); |
| 853 | 6832 free_cons (cons); |
| 802 | 6833 return Qnil; |
| 6834 } | |
| 6835 | |
| 6836 /* Establish an unwind-protect which will restore the Lisp_Object pointed to | |
| 6837 by ADDR with the value VAL. */ | |
| 814 | 6838 static int |
| 802 | 6839 record_unwind_protect_restoring_lisp_object (Lisp_Object *addr, |
| 6840 Lisp_Object val) | |
| 6841 { | |
| 5013 | 6842 /* We use a cons rather than a malloc()ed structure because we want the |
| 6843 Lisp object to have garbage-collection protection */ | |
| 6844 Lisp_Object laddr = STORE_VOID_IN_LISP (addr); | |
| 802 | 6845 return record_unwind_protect (restore_lisp_object, |
| 5013 | 6846 noseeum_cons (laddr, val)); |
| 802 | 6847 } |
| 6848 | |
| 6849 /* Similar to specbind() but for any C variable whose value is a | |
| 6850 Lisp_Object. Sets up an unwind-protect to restore the variable | |
| 6851 pointed to by ADDR to its existing value, and then changes its | |
| 6852 value to NEWVAL. Returns the previous value of specpdl_depth(); | |
| 6853 pass this to unbind_to() after you are done. */ | |
| 6854 int | |
| 6855 internal_bind_lisp_object (Lisp_Object *addr, Lisp_Object newval) | |
| 6856 { | |
| 6857 int count = specpdl_depth (); | |
| 6858 record_unwind_protect_restoring_lisp_object (addr, *addr); | |
| 6859 *addr = newval; | |
| 6860 return count; | |
| 6861 } | |
| 6862 | |
| 5013 | 6863 struct restore_int |
| 6864 { | |
| 6865 int *addr; | |
| 802 | 6866 int val; |
| 5013 | 6867 }; |
| 6868 | |
| 6869 static Lisp_Object | |
| 6870 restore_int (Lisp_Object obj) | |
| 6871 { | |
| 6872 struct restore_int *ri = (struct restore_int *) GET_VOID_FROM_LISP (obj); | |
| 6873 *(ri->addr) = ri->val; | |
| 6874 xfree (ri); | |
| 802 | 6875 return Qnil; |
| 6876 } | |
| 6877 | |
| 6878 /* Establish an unwind-protect which will restore the int pointed to | |
| 6879 by ADDR with the value VAL. This function works correctly with | |
| 6880 all ints, even those that don't fit into a Lisp integer. */ | |
| 1333 | 6881 int |
| 802 | 6882 record_unwind_protect_restoring_int (int *addr, int val) |
| 6883 { | |
| 5013 | 6884 struct restore_int *ri = xnew (struct restore_int); |
| 6885 ri->addr = addr; | |
| 6886 ri->val = val; | |
| 6887 return record_unwind_protect (restore_int, STORE_VOID_IN_LISP (ri)); | |
| 802 | 6888 } |
| 6889 | |
| 6890 /* Similar to specbind() but for any C variable whose value is an int. | |
| 6891 Sets up an unwind-protect to restore the variable pointed to by | |
| 6892 ADDR to its existing value, and then changes its value to NEWVAL. | |
| 6893 Returns the previous value of specpdl_depth(); pass this to | |
| 6894 unbind_to() after you are done. This function works correctly with | |
| 6895 all ints, even those that don't fit into a Lisp integer. */ | |
| 6896 int | |
| 6897 internal_bind_int (int *addr, int newval) | |
| 6898 { | |
| 6899 int count = specpdl_depth (); | |
| 6900 record_unwind_protect_restoring_int (addr, *addr); | |
| 6901 *addr = newval; | |
| 6902 return count; | |
| 6903 } | |
| 6904 | |
| 6905 static Lisp_Object | |
| 771 | 6906 free_pointer (Lisp_Object opaque) |
| 6907 { | |
| 5013 | 6908 void *ptr = GET_VOID_FROM_LISP (opaque); |
| 6909 xfree (ptr); | |
| 771 | 6910 return Qnil; |
| 6911 } | |
| 6912 | |
| 6913 /* Establish an unwind-protect which will free the specified block. | |
| 6914 */ | |
| 6915 int | |
| 6916 record_unwind_protect_freeing (void *ptr) | |
| 6917 { | |
| 5013 | 6918 return record_unwind_protect (free_pointer, STORE_VOID_IN_LISP (ptr)); |
| 771 | 6919 } |
| 6920 | |
| 6921 static Lisp_Object | |
| 6922 free_dynarr (Lisp_Object opaque) | |
| 6923 { | |
| 5013 | 6924 Dynarr_free (GET_VOID_FROM_LISP (opaque)); |
| 771 | 6925 return Qnil; |
| 6926 } | |
| 6927 | |
| 6928 int | |
| 6929 record_unwind_protect_freeing_dynarr (void *ptr) | |
| 6930 { | |
| 5013 | 6931 return record_unwind_protect (free_dynarr, STORE_VOID_IN_LISP (ptr)); |
| 771 | 6932 } |
| 428 | 6933 |
| 6934 /* Unwind the stack till specpdl_depth() == COUNT. | |
| 6935 VALUE is not used, except that, purely as a convenience to the | |
| 771 | 6936 caller, it is protected from garbage-protection and returned. */ |
| 428 | 6937 Lisp_Object |
| 771 | 6938 unbind_to_1 (int count, Lisp_Object value) |
| 428 | 6939 { |
| 6940 UNBIND_TO_GCPRO (count, value); | |
| 853 | 6941 check_specbind_stack_sanity (); |
| 428 | 6942 return value; |
| 6943 } | |
| 6944 | |
| 6945 /* Don't call this directly. | |
| 6946 Only for use by UNBIND_TO* macros in backtrace.h */ | |
| 6947 void | |
| 6948 unbind_to_hairy (int count) | |
| 6949 { | |
| 442 | 6950 ++specpdl_ptr; |
| 6951 ++specpdl_depth_counter; | |
| 6952 | |
| 428 | 6953 while (specpdl_depth_counter != count) |
| 6954 { | |
| 1313 | 6955 Lisp_Object oquit = Qunbound; |
| 6956 | |
| 6957 /* Do this check BEFORE decrementing the values below, because once | |
| 6958 they're decremented, GC protection is lost on | |
| 6959 specpdl_ptr->old_value. */ | |
| 1322 | 6960 if (specpdl_ptr[-1].func == Fprogn) |
| 1313 | 6961 { |
| 6962 /* Allow QUIT within unwind-protect routines, but defer any | |
| 6963 existing QUIT until afterwards. Only do this, however, for | |
| 6964 unwind-protects established by Lisp code, not by C code | |
| 6965 (e.g. free_opaque_ptr() or something), because the act of | |
| 6966 checking for QUIT can cause all sorts of weird things to | |
| 6967 happen, since it churns the event loop -- redisplay, running | |
| 6968 Lisp, etc. Code should not have to worry about this just | |
| 6969 because of establishing an unwind-protect. */ | |
| 6970 check_quit (); /* make Vquit_flag accurate */ | |
| 6971 oquit = Vquit_flag; | |
| 6972 Vquit_flag = Qnil; | |
| 6973 } | |
| 6974 | |
| 428 | 6975 --specpdl_ptr; |
| 6976 --specpdl_depth_counter; | |
| 6977 | |
| 1313 | 6978 /* #### At this point, there is no GC protection on old_value. This |
| 6979 could be a real problem, depending on what unwind-protect function | |
| 6980 is called. It looks like it just so happens that the ones | |
| 6981 actually called don't have a problem with this, e.g. Fprogn. But | |
| 6982 we should look into fixing this. (Many unwind-protect functions | |
| 6983 free values. Is it a problem if freed values are | |
| 6984 GC-protected?) */ | |
| 428 | 6985 if (specpdl_ptr->func != 0) |
| 1313 | 6986 { |
| 6987 /* An unwind-protect */ | |
| 6988 (*specpdl_ptr->func) (specpdl_ptr->old_value); | |
| 6989 } | |
| 6990 | |
| 428 | 6991 else |
| 6992 { | |
| 6993 /* We checked symbol for validity when we specbound it, | |
| 6994 so only need to call Fset if symbol has magic value. */ | |
| 440 | 6995 Lisp_Symbol *sym = XSYMBOL (specpdl_ptr->symbol); |
| 428 | 6996 if (!SYMBOL_VALUE_MAGIC_P (sym->value)) |
| 6997 sym->value = specpdl_ptr->old_value; | |
| 6998 else | |
| 6999 Fset (specpdl_ptr->symbol, specpdl_ptr->old_value); | |
| 7000 } | |
| 7001 | |
| 7002 #if 0 /* martin */ | |
| 7003 #ifndef EXCEEDINGLY_QUESTIONABLE_CODE | |
| 7004 /* There should never be anything here for us to remove. | |
| 7005 If so, it indicates a logic error in Emacs. Catches | |
| 7006 should get removed when a throw or signal occurs, or | |
| 7007 when a catch or condition-case exits normally. But | |
| 7008 it's too dangerous to just remove this code. --ben */ | |
| 7009 | |
| 7010 /* Furthermore, this code is not in FSFmacs!!! | |
| 7011 Braino on mly's part? */ | |
| 7012 /* If we're unwound past the pdlcount of a catch frame, | |
| 7013 that catch can't possibly still be valid. */ | |
| 7014 while (catchlist && catchlist->pdlcount > specpdl_depth_counter) | |
| 7015 { | |
| 7016 catchlist = catchlist->next; | |
| 7017 /* Don't mess with gcprolist, backtrace_list here */ | |
| 7018 } | |
| 7019 #endif | |
| 7020 #endif | |
| 1313 | 7021 |
| 7022 if (!UNBOUNDP (oquit)) | |
| 7023 Vquit_flag = oquit; | |
| 428 | 7024 } |
| 853 | 7025 check_specbind_stack_sanity (); |
| 428 | 7026 } |
| 7027 | |
| 7028 | |
| 7029 | |
| 7030 /* Get the value of symbol's global binding, even if that binding is | |
| 7031 not now dynamically visible. May return Qunbound or magic values. */ | |
| 7032 | |
| 7033 Lisp_Object | |
| 7034 top_level_value (Lisp_Object symbol) | |
| 7035 { | |
| 7036 REGISTER struct specbinding *ptr = specpdl; | |
| 7037 | |
| 7038 CHECK_SYMBOL (symbol); | |
| 7039 for (; ptr != specpdl_ptr; ptr++) | |
| 7040 { | |
| 7041 if (EQ (ptr->symbol, symbol)) | |
| 7042 return ptr->old_value; | |
| 7043 } | |
| 7044 return XSYMBOL (symbol)->value; | |
| 7045 } | |
| 7046 | |
| 7047 #if 0 | |
| 7048 | |
| 7049 Lisp_Object | |
| 7050 top_level_set (Lisp_Object symbol, Lisp_Object newval) | |
| 7051 { | |
| 7052 REGISTER struct specbinding *ptr = specpdl; | |
| 7053 | |
| 7054 CHECK_SYMBOL (symbol); | |
| 7055 for (; ptr != specpdl_ptr; ptr++) | |
| 7056 { | |
| 7057 if (EQ (ptr->symbol, symbol)) | |
| 7058 { | |
| 7059 ptr->old_value = newval; | |
| 7060 return newval; | |
| 7061 } | |
| 7062 } | |
| 7063 return Fset (symbol, newval); | |
| 7064 } | |
| 7065 | |
| 7066 #endif /* 0 */ | |
| 7067 | |
| 7068 | |
| 7069 /************************************************************************/ | |
| 7070 /* Backtraces */ | |
| 7071 /************************************************************************/ | |
| 7072 | |
| 7073 DEFUN ("backtrace-debug", Fbacktrace_debug, 2, 2, 0, /* | |
| 7074 Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG. | |
| 7075 The debugger is entered when that frame exits, if the flag is non-nil. | |
| 7076 */ | |
| 7077 (level, flag)) | |
| 7078 { | |
| 7079 REGISTER struct backtrace *backlist = backtrace_list; | |
| 7080 REGISTER int i; | |
| 7081 | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
7082 CHECK_FIXNUM (level); |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
7083 |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
7084 for (i = 0; backlist && i < XFIXNUM (level); i++) |
| 428 | 7085 { |
| 7086 backlist = backlist->next; | |
| 7087 } | |
| 7088 | |
| 7089 if (backlist) | |
| 7090 backlist->debug_on_exit = !NILP (flag); | |
| 7091 | |
| 7092 return flag; | |
| 7093 } | |
| 7094 | |
| 7095 static void | |
| 7096 backtrace_specials (int speccount, int speclimit, Lisp_Object stream) | |
| 7097 { | |
| 7098 int printing_bindings = 0; | |
| 7099 | |
| 7100 for (; speccount > speclimit; speccount--) | |
| 7101 { | |
| 7102 if (specpdl[speccount - 1].func == 0 | |
| 7103 || specpdl[speccount - 1].func == specbind_unwind_local | |
| 7104 || specpdl[speccount - 1].func == specbind_unwind_wasnt_local) | |
| 7105 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7106 write_ascstring (stream, !printing_bindings ? " # bind (" : " "); |
| 428 | 7107 Fprin1 (specpdl[speccount - 1].symbol, stream); |
| 7108 printing_bindings = 1; | |
| 7109 } | |
| 7110 else | |
| 7111 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7112 if (printing_bindings) write_ascstring (stream, ")\n"); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7113 write_ascstring (stream, " # (unwind-protect ...)\n"); |
| 428 | 7114 printing_bindings = 0; |
| 7115 } | |
| 7116 } | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7117 if (printing_bindings) write_ascstring (stream, ")\n"); |
| 428 | 7118 } |
| 7119 | |
| 1292 | 7120 static Lisp_Object |
| 7121 backtrace_unevalled_args (Lisp_Object *args) | |
| 7122 { | |
| 7123 if (args) | |
| 7124 return *args; | |
| 7125 else | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7126 return list1 (build_ascstring ("[internal]")); |
| 1292 | 7127 } |
| 7128 | |
| 428 | 7129 DEFUN ("backtrace", Fbacktrace, 0, 2, "", /* |
| 7130 Print a trace of Lisp function calls currently active. | |
| 438 | 7131 Optional arg STREAM specifies the output stream to send the backtrace to, |
| 444 | 7132 and defaults to the value of `standard-output'. |
| 7133 Optional second arg DETAILED non-nil means show places where currently | |
| 7134 active variable bindings, catches, condition-cases, and | |
| 7135 unwind-protects, as well as function calls, were made. | |
| 428 | 7136 */ |
| 7137 (stream, detailed)) | |
| 7138 { | |
| 7139 /* This function can GC */ | |
| 7140 struct backtrace *backlist = backtrace_list; | |
| 7141 struct catchtag *catches = catchlist; | |
| 7142 int speccount = specpdl_depth(); | |
| 7143 | |
| 7144 int old_nl = print_escape_newlines; | |
| 7145 int old_pr = print_readably; | |
| 7146 Lisp_Object old_level = Vprint_level; | |
| 7147 Lisp_Object oiq = Vinhibit_quit; | |
| 7148 struct gcpro gcpro1, gcpro2; | |
| 7149 | |
| 7150 /* We can't allow quits in here because that could cause the values | |
| 7151 of print_readably and print_escape_newlines to get screwed up. | |
| 7152 Normally we would use a record_unwind_protect but that would | |
| 7153 screw up the functioning of this function. */ | |
| 7154 Vinhibit_quit = Qt; | |
| 7155 | |
| 7156 entering_debugger = 0; | |
| 7157 | |
| 872 | 7158 if (!NILP (detailed)) |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
7159 Vprint_level = make_fixnum (50); |
| 872 | 7160 else |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
7161 Vprint_level = make_fixnum (3); |
| 428 | 7162 print_readably = 0; |
| 7163 print_escape_newlines = 1; | |
| 7164 | |
| 7165 GCPRO2 (stream, old_level); | |
| 7166 | |
| 1261 | 7167 stream = canonicalize_printcharfun (stream); |
| 428 | 7168 |
| 7169 for (;;) | |
| 7170 { | |
| 7171 if (!NILP (detailed) && catches && catches->backlist == backlist) | |
| 7172 { | |
| 7173 int catchpdl = catches->pdlcount; | |
| 438 | 7174 if (speccount > catchpdl |
| 7175 && specpdl[catchpdl].func == condition_case_unwind) | |
| 428 | 7176 /* This is a condition-case catchpoint */ |
| 7177 catchpdl = catchpdl + 1; | |
| 7178 | |
| 7179 backtrace_specials (speccount, catchpdl, stream); | |
| 7180 | |
| 7181 speccount = catches->pdlcount; | |
| 7182 if (catchpdl == speccount) | |
| 7183 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7184 write_ascstring (stream, " # (catch "); |
| 428 | 7185 Fprin1 (catches->tag, stream); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7186 write_ascstring (stream, " ...)\n"); |
| 428 | 7187 } |
| 7188 else | |
| 7189 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7190 write_ascstring (stream, " # (condition-case ... . "); |
| 428 | 7191 Fprin1 (Fcdr (Fcar (catches->tag)), stream); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7192 write_ascstring (stream, ")\n"); |
| 428 | 7193 } |
| 7194 catches = catches->next; | |
| 7195 } | |
| 7196 else if (!backlist) | |
| 7197 break; | |
| 7198 else | |
| 7199 { | |
| 7200 if (!NILP (detailed) && backlist->pdlcount < speccount) | |
| 7201 { | |
| 7202 backtrace_specials (speccount, backlist->pdlcount, stream); | |
| 7203 speccount = backlist->pdlcount; | |
| 7204 } | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7205 write_ascstring (stream, backlist->debug_on_exit ? "* " : " "); |
| 428 | 7206 if (backlist->nargs == UNEVALLED) |
| 7207 { | |
| 1292 | 7208 Fprin1 (Fcons (*backlist->function, |
| 7209 backtrace_unevalled_args (backlist->args)), | |
| 7210 stream); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7211 write_ascstring (stream, "\n"); /* from FSFmacs 19.30 */ |
| 428 | 7212 } |
| 7213 else | |
| 7214 { | |
| 7215 Lisp_Object tem = *backlist->function; | |
| 7216 Fprin1 (tem, stream); /* This can QUIT */ | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7217 write_ascstring (stream, "("); |
| 428 | 7218 if (backlist->nargs == MANY) |
| 7219 { | |
| 7220 int i; | |
| 7221 Lisp_Object tail = Qnil; | |
| 7222 struct gcpro ngcpro1; | |
| 7223 | |
| 7224 NGCPRO1 (tail); | |
| 7225 for (tail = *backlist->args, i = 0; | |
| 7226 !NILP (tail); | |
| 7227 tail = Fcdr (tail), i++) | |
| 7228 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7229 if (i != 0) write_ascstring (stream, " "); |
| 428 | 7230 Fprin1 (Fcar (tail), stream); |
| 7231 } | |
| 7232 NUNGCPRO; | |
| 7233 } | |
| 7234 else | |
| 7235 { | |
| 7236 int i; | |
| 7237 for (i = 0; i < backlist->nargs; i++) | |
| 7238 { | |
| 826 | 7239 if (!i && EQ (tem, Qbyte_code)) |
| 7240 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7241 write_ascstring (stream, "\"...\""); |
| 826 | 7242 continue; |
| 7243 } | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7244 if (i != 0) write_ascstring (stream, " "); |
| 428 | 7245 Fprin1 (backlist->args[i], stream); |
| 7246 } | |
| 7247 } | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7248 write_ascstring (stream, ")\n"); |
| 428 | 7249 } |
| 7250 backlist = backlist->next; | |
| 7251 } | |
| 7252 } | |
| 7253 Vprint_level = old_level; | |
| 7254 print_readably = old_pr; | |
| 7255 print_escape_newlines = old_nl; | |
| 7256 UNGCPRO; | |
| 7257 Vinhibit_quit = oiq; | |
| 7258 return Qnil; | |
| 7259 } | |
| 7260 | |
| 7261 | |
| 444 | 7262 DEFUN ("backtrace-frame", Fbacktrace_frame, 1, 1, 0, /* |
| 7263 Return the function and arguments NFRAMES up from current execution point. | |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
7264 If that frame has not evaluated the arguments yet (or involves a special |
|
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
7265 operator), the value is (nil FUNCTION ARG-FORMS...). |
| 428 | 7266 If that frame has evaluated its arguments and called its function already, |
| 7267 the value is (t FUNCTION ARG-VALUES...). | |
| 7268 A &rest arg is represented as the tail of the list ARG-VALUES. | |
| 7269 FUNCTION is whatever was supplied as car of evaluated list, | |
| 7270 or a lambda expression for macro calls. | |
| 444 | 7271 If NFRAMES is more than the number of frames, the value is nil. |
| 428 | 7272 */ |
| 7273 (nframes)) | |
| 7274 { | |
| 7275 REGISTER struct backtrace *backlist = backtrace_list; | |
| 7276 REGISTER int i; | |
| 7277 Lisp_Object tem; | |
| 7278 | |
|
5736
3192994c49ca
Convert C (un)signed long long values to bignums properly.
Jerry James <james@xemacs.org>
parents:
5658
diff
changeset
|
7279 check_integer_range (nframes, Qzero, make_fixnum (MOST_POSITIVE_FIXNUM)); |
| 428 | 7280 |
| 7281 /* Find the frame requested. */ | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
7282 for (i = XFIXNUM (nframes); backlist && (i-- > 0);) |
| 428 | 7283 backlist = backlist->next; |
| 7284 | |
| 7285 if (!backlist) | |
| 7286 return Qnil; | |
| 7287 if (backlist->nargs == UNEVALLED) | |
| 1292 | 7288 return Fcons (Qnil, Fcons (*backlist->function, |
| 7289 backtrace_unevalled_args (backlist->args))); | |
| 428 | 7290 else |
| 7291 { | |
| 7292 if (backlist->nargs == MANY) | |
| 7293 tem = *backlist->args; | |
| 7294 else | |
| 7295 tem = Flist (backlist->nargs, backlist->args); | |
| 7296 | |
| 7297 return Fcons (Qt, Fcons (*backlist->function, tem)); | |
| 7298 } | |
| 7299 } | |
| 7300 | |
| 7301 | |
| 7302 /************************************************************************/ | |
| 7303 /* Warnings */ | |
| 7304 /************************************************************************/ | |
| 7305 | |
| 1123 | 7306 static int |
| 7307 warning_will_be_discarded (Lisp_Object level) | |
| 7308 { | |
| 7309 /* Don't even generate debug warnings if they're going to be discarded, | |
| 7310 to avoid excessive consing. */ | |
| 7311 return (EQ (level, Qdebug) && !NILP (Vlog_warning_minimum_level) && | |
| 7312 !EQ (Vlog_warning_minimum_level, Qdebug)); | |
| 7313 } | |
| 7314 | |
| 428 | 7315 void |
| 1204 | 7316 warn_when_safe_lispobj (Lisp_Object class_, Lisp_Object level, |
| 428 | 7317 Lisp_Object obj) |
| 7318 { | |
| 1123 | 7319 if (warning_will_be_discarded (level)) |
| 793 | 7320 return; |
| 1123 | 7321 |
| 1204 | 7322 obj = list1 (list3 (class_, level, obj)); |
| 428 | 7323 if (NILP (Vpending_warnings)) |
| 7324 Vpending_warnings = Vpending_warnings_tail = obj; | |
| 7325 else | |
| 7326 { | |
| 7327 Fsetcdr (Vpending_warnings_tail, obj); | |
| 7328 Vpending_warnings_tail = obj; | |
| 7329 } | |
| 7330 } | |
| 7331 | |
| 7332 /* #### This should probably accept Lisp objects; but then we have | |
| 7333 to make sure that Feval() isn't called, since it might not be safe. | |
| 7334 | |
| 7335 An alternative approach is to just pass some non-string type of | |
| 7336 Lisp_Object to warn_when_safe_lispobj(); `prin1-to-string' will | |
| 7337 automatically be called when it is safe to do so. */ | |
| 7338 | |
| 7339 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7340 warn_when_safe (Lisp_Object class_, Lisp_Object level, const Ascbyte *fmt, ...) |
| 428 | 7341 { |
| 7342 Lisp_Object obj; | |
| 7343 va_list args; | |
| 7344 | |
| 1123 | 7345 if (warning_will_be_discarded (level)) |
| 793 | 7346 return; |
| 1123 | 7347 |
| 428 | 7348 va_start (args, fmt); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7349 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 428 | 7350 va_end (args); |
| 7351 | |
| 1204 | 7352 warn_when_safe_lispobj (class_, level, obj); |
| 428 | 7353 } |
| 7354 | |
| 7355 | |
| 7356 | |
| 7357 | |
| 7358 /************************************************************************/ | |
| 7359 /* Initialization */ | |
| 7360 /************************************************************************/ | |
| 7361 | |
| 7362 void | |
| 7363 syms_of_eval (void) | |
| 7364 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
7365 INIT_LISP_OBJECT (subr); |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
7366 INIT_LISP_OBJECT (multiple_value); |
| 442 | 7367 |
| 563 | 7368 DEFSYMBOL (Qinhibit_quit); |
| 7369 DEFSYMBOL (Qautoload); | |
|
5615
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
7370 DEFSYMBOL (Qbyte_compile_macro_environment); |
| 563 | 7371 DEFSYMBOL (Qdebug_on_error); |
| 7372 DEFSYMBOL (Qstack_trace_on_error); | |
| 7373 DEFSYMBOL (Qdebug_on_signal); | |
| 7374 DEFSYMBOL (Qstack_trace_on_signal); | |
| 7375 DEFSYMBOL (Qdebugger); | |
| 7376 DEFSYMBOL (Qmacro); | |
| 428 | 7377 defsymbol (&Qand_rest, "&rest"); |
| 7378 defsymbol (&Qand_optional, "&optional"); | |
| 7379 /* Note that the process code also uses Qexit */ | |
| 563 | 7380 DEFSYMBOL (Qexit); |
|
5506
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
7381 DEFSYMBOL (Qdeclare); |
| 563 | 7382 DEFSYMBOL (Qsetq); |
| 7383 DEFSYMBOL (Qinteractive); | |
| 7384 DEFSYMBOL (Qcommandp); | |
| 7385 DEFSYMBOL (Qdefun); | |
| 7386 DEFSYMBOL (Qprogn); | |
| 7387 DEFSYMBOL (Qvalues); | |
| 7388 DEFSYMBOL (Qdisplay_warning); | |
| 7389 DEFSYMBOL (Qrun_hooks); | |
| 887 | 7390 DEFSYMBOL (Qfinalize_list); |
| 563 | 7391 DEFSYMBOL (Qif); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7392 DEFSYMBOL (Qthrow); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7393 DEFSYMBOL (Qobsolete_throw); |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
7394 DEFSYMBOL (Qmultiple_value_list_internal); |
| 428 | 7395 |
| 7396 DEFSUBR (For); | |
| 7397 DEFSUBR (Fand); | |
| 7398 DEFSUBR (Fif); | |
| 7399 DEFSUBR_MACRO (Fwhen); | |
| 7400 DEFSUBR_MACRO (Funless); | |
| 7401 DEFSUBR (Fcond); | |
| 7402 DEFSUBR (Fprogn); | |
| 7403 DEFSUBR (Fprog1); | |
| 7404 DEFSUBR (Fprog2); | |
| 7405 DEFSUBR (Fsetq); | |
| 7406 DEFSUBR (Fquote); | |
|
4744
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
7407 DEFSUBR (Fquote_maybe); |
| 428 | 7408 DEFSUBR (Ffunction); |
| 7409 DEFSUBR (Fdefun); | |
| 7410 DEFSUBR (Fdefmacro); | |
| 7411 DEFSUBR (Fdefvar); | |
| 7412 DEFSUBR (Fdefconst); | |
| 7413 DEFSUBR (Flet); | |
| 7414 DEFSUBR (FletX); | |
| 7415 DEFSUBR (Fwhile); | |
|
5615
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
7416 DEFSUBR (Fmacroexpand); |
| 428 | 7417 DEFSUBR (Fcatch); |
| 7418 DEFSUBR (Fthrow); | |
| 7419 DEFSUBR (Funwind_protect); | |
| 7420 DEFSUBR (Fcondition_case); | |
| 7421 DEFSUBR (Fcall_with_condition_handler); | |
| 7422 DEFSUBR (Fsignal); | |
| 7423 DEFSUBR (Finteractive_p); | |
| 7424 DEFSUBR (Fcommandp); | |
| 7425 DEFSUBR (Fcommand_execute); | |
| 7426 DEFSUBR (Fautoload); | |
| 7427 DEFSUBR (Feval); | |
| 7428 DEFSUBR (Fapply); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7429 DEFSUBR (Fmultiple_value_call); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7430 DEFSUBR (Fmultiple_value_list_internal); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7431 DEFSUBR (Fmultiple_value_prog1); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7432 DEFSUBR (Fvalues); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7433 DEFSUBR (Fvalues_list); |
| 428 | 7434 DEFSUBR (Ffuncall); |
| 7435 DEFSUBR (Ffunctionp); | |
| 7436 DEFSUBR (Ffunction_min_args); | |
| 7437 DEFSUBR (Ffunction_max_args); | |
| 7438 DEFSUBR (Frun_hooks); | |
| 7439 DEFSUBR (Frun_hook_with_args); | |
| 7440 DEFSUBR (Frun_hook_with_args_until_success); | |
| 7441 DEFSUBR (Frun_hook_with_args_until_failure); | |
| 7442 DEFSUBR (Fbacktrace_debug); | |
| 7443 DEFSUBR (Fbacktrace); | |
| 7444 DEFSUBR (Fbacktrace_frame); | |
| 7445 } | |
| 7446 | |
| 7447 void | |
| 814 | 7448 init_eval_semi_early (void) |
| 428 | 7449 { |
| 7450 specpdl_ptr = specpdl; | |
| 7451 specpdl_depth_counter = 0; | |
| 7452 catchlist = 0; | |
| 7453 Vcondition_handlers = Qnil; | |
| 7454 backtrace_list = 0; | |
| 7455 Vquit_flag = Qnil; | |
| 7456 debug_on_next_call = 0; | |
| 7457 lisp_eval_depth = 0; | |
| 7458 entering_debugger = 0; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7459 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7460 first_desired_multiple_value = 0; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7461 multiple_value_current_limit = 1; |
| 428 | 7462 } |
| 7463 | |
| 7464 void | |
| 7465 reinit_vars_of_eval (void) | |
| 7466 { | |
| 7467 preparing_for_armageddon = 0; | |
| 7468 in_warnings = 0; | |
| 7469 specpdl_size = 50; | |
| 7470 specpdl = xnew_array (struct specbinding, specpdl_size); | |
| 7471 /* XEmacs change: increase these values. */ | |
| 7472 max_specpdl_size = 3000; | |
| 442 | 7473 max_lisp_eval_depth = 1000; |
| 7474 #ifdef DEFEND_AGAINST_THROW_RECURSION | |
| 428 | 7475 throw_level = 0; |
| 7476 #endif | |
| 2367 | 7477 init_eval_semi_early (); |
| 428 | 7478 } |
| 7479 | |
| 7480 void | |
| 7481 vars_of_eval (void) | |
| 7482 { | |
| 7483 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size /* | |
| 7484 Limit on number of Lisp variable bindings & unwind-protects before error. | |
| 7485 */ ); | |
| 7486 | |
| 7487 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth /* | |
| 7488 Limit on depth in `eval', `apply' and `funcall' before error. | |
| 7489 This limit is to catch infinite recursions for you before they cause | |
| 7490 actual stack overflow in C, which would be fatal for Emacs. | |
| 7491 You can safely make it considerably larger than its default value, | |
| 7492 if that proves inconveniently small. | |
| 7493 */ ); | |
| 7494 | |
| 7495 DEFVAR_LISP ("quit-flag", &Vquit_flag /* | |
| 853 | 7496 t causes running Lisp code to abort, unless `inhibit-quit' is non-nil. |
| 7497 `critical' causes running Lisp code to abort regardless of `inhibit-quit'. | |
| 7498 Normally, you do not need to set this value yourself. It is set to | |
| 7499 t each time a Control-G is detected, and to `critical' each time a | |
| 7500 Shift-Control-G is detected. The XEmacs core C code is littered with | |
| 7501 calls to the QUIT; macro, which check the values of `quit-flag' and | |
| 2500 | 7502 `inhibit-quit' and ABORT (or more accurately, call (signal 'quit)) if |
| 853 | 7503 it's correct to do so. |
| 428 | 7504 */ ); |
| 7505 Vquit_flag = Qnil; | |
| 7506 | |
| 7507 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit /* | |
| 7508 Non-nil inhibits C-g quitting from happening immediately. | |
| 7509 Note that `quit-flag' will still be set by typing C-g, | |
| 7510 so a quit will be signalled as soon as `inhibit-quit' is nil. | |
| 7511 To prevent this happening, set `quit-flag' to nil | |
| 853 | 7512 before making `inhibit-quit' nil. |
| 7513 | |
| 7514 The value of `inhibit-quit' is ignored if a critical quit is | |
| 7515 requested by typing control-shift-G in a window-system frame; | |
| 7516 this is explained in more detail in `quit-flag'. | |
| 428 | 7517 */ ); |
| 7518 Vinhibit_quit = Qnil; | |
| 7519 | |
| 7520 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error /* | |
| 7521 *Non-nil means automatically display a backtrace buffer | |
| 7522 after any error that is not handled by a `condition-case'. | |
| 7523 If the value is a list, an error only means to display a backtrace | |
| 7524 if one of its condition symbols appears in the list. | |
| 7525 See also variable `stack-trace-on-signal'. | |
| 7526 */ ); | |
| 7527 Vstack_trace_on_error = Qnil; | |
| 7528 | |
| 7529 DEFVAR_LISP ("stack-trace-on-signal", &Vstack_trace_on_signal /* | |
| 7530 *Non-nil means automatically display a backtrace buffer | |
| 7531 after any error that is signalled, whether or not it is handled by | |
| 7532 a `condition-case'. | |
| 7533 If the value is a list, an error only means to display a backtrace | |
| 7534 if one of its condition symbols appears in the list. | |
| 7535 See also variable `stack-trace-on-error'. | |
| 7536 */ ); | |
| 7537 Vstack_trace_on_signal = Qnil; | |
| 7538 | |
| 7539 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors /* | |
| 7540 *List of errors for which the debugger should not be called. | |
| 7541 Each element may be a condition-name or a regexp that matches error messages. | |
| 7542 If any element applies to a given error, that error skips the debugger | |
| 7543 and just returns to top level. | |
| 7544 This overrides the variable `debug-on-error'. | |
| 7545 It does not apply to errors handled by `condition-case'. | |
| 7546 */ ); | |
| 7547 Vdebug_ignored_errors = Qnil; | |
| 7548 | |
| 7549 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error /* | |
| 7550 *Non-nil means enter debugger if an unhandled error is signalled. | |
| 7551 The debugger will not be entered if the error is handled by | |
| 7552 a `condition-case'. | |
| 7553 If the value is a list, an error only means to enter the debugger | |
| 7554 if one of its condition symbols appears in the list. | |
| 7555 This variable is overridden by `debug-ignored-errors'. | |
| 7556 See also variables `debug-on-quit' and `debug-on-signal'. | |
| 1123 | 7557 |
|
4657
f8d7d8202635
imported patch accept-process-output-docstring
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4642
diff
changeset
|
7558 Process filters are considered to be outside of condition-case forms |
|
f8d7d8202635
imported patch accept-process-output-docstring
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4642
diff
changeset
|
7559 (unless contained in the process filter itself). To prevent the |
|
f8d7d8202635
imported patch accept-process-output-docstring
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4642
diff
changeset
|
7560 debugger from being called from a process filter, use a list value, or |
|
f8d7d8202635
imported patch accept-process-output-docstring
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4642
diff
changeset
|
7561 put the expected error\(s) in `debug-ignored-errors'. |
|
f8d7d8202635
imported patch accept-process-output-docstring
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4642
diff
changeset
|
7562 |
| 1123 | 7563 If this variable is set while XEmacs is running noninteractively (using |
| 7564 `-batch'), and XEmacs was configured with `--debug' (#define XEMACS_DEBUG | |
| 7565 in the C code), instead of trying to invoke the Lisp debugger (which | |
| 7566 obviously won't work), XEmacs will break out to a C debugger using | |
| 7567 \(force-debugging-signal t). This is useful because debugging | |
| 7568 noninteractive runs of XEmacs is often very difficult, since they typically | |
| 7569 happen as part of sometimes large and complex make suites (e.g. rebuilding | |
| 2500 | 7570 the XEmacs packages). NOTE: This runs ABORT()!!! (As well as and after |
| 1123 | 7571 executing INT 3 under MS Windows, which should invoke a debugger if it's |
| 7572 active.) This is guaranteed to kill XEmacs! (But in this situation, XEmacs | |
| 7573 is about to die anyway, and if no debugger is present, this will usefully | |
| 7574 dump core.) The most useful way to set this flag when debugging | |
| 7575 noninteractive runs, especially in makefiles, is using the environment | |
| 7576 variable XEMACSDEBUG, like this: | |
| 771 | 7577 |
| 7578 \(using csh) setenv XEMACSDEBUG '(setq debug-on-error t)' | |
| 7579 \(using bash) export XEMACSDEBUG='(setq debug-on-error t)' | |
| 428 | 7580 */ ); |
| 7581 Vdebug_on_error = Qnil; | |
| 7582 | |
| 7583 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal /* | |
| 7584 *Non-nil means enter debugger if an error is signalled. | |
| 7585 The debugger will be entered whether or not the error is handled by | |
| 7586 a `condition-case'. | |
| 7587 If the value is a list, an error only means to enter the debugger | |
| 7588 if one of its condition symbols appears in the list. | |
| 7589 See also variable `debug-on-quit'. | |
| 1123 | 7590 |
| 7591 This will attempt to enter a C debugger when XEmacs is run noninteractively | |
| 7592 and under the same conditions as described in `debug-on-error'. | |
| 428 | 7593 */ ); |
| 7594 Vdebug_on_signal = Qnil; | |
| 7595 | |
| 7596 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit /* | |
| 7597 *Non-nil means enter debugger if quit is signalled (C-G, for example). | |
| 7598 Does not apply if quit is handled by a `condition-case'. Entering the | |
| 7599 debugger can also be achieved at any time (for X11 console) by typing | |
| 7600 control-shift-G to signal a critical quit. | |
| 7601 */ ); | |
| 7602 debug_on_quit = 0; | |
| 7603 | |
| 7604 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call /* | |
| 7605 Non-nil means enter debugger before next `eval', `apply' or `funcall'. | |
| 7606 */ ); | |
| 7607 | |
| 1292 | 7608 DEFVAR_BOOL ("backtrace-with-interal-sections", |
| 7609 &backtrace_with_internal_sections /* | |
| 7610 Non-nil means backtraces will contain additional information indicating | |
| 7611 when particular sections of the C code have been entered, e.g. redisplay(), | |
| 7612 byte-char conversion, internal-external conversion, etc. This can be | |
| 7613 particularly useful when XEmacs crashes, in helping to pinpoint the problem. | |
| 7614 */ ); | |
| 7615 #ifdef ERROR_CHECK_STRUCTURES | |
| 7616 backtrace_with_internal_sections = 1; | |
| 7617 #else | |
| 7618 backtrace_with_internal_sections = 0; | |
| 7619 #endif | |
| 7620 | |
| 428 | 7621 DEFVAR_LISP ("debugger", &Vdebugger /* |
| 7622 Function to call to invoke debugger. | |
| 7623 If due to frame exit, args are `exit' and the value being returned; | |
| 7624 this function's value will be returned instead of that. | |
| 7625 If due to error, args are `error' and a list of the args to `signal'. | |
| 7626 If due to `apply' or `funcall' entry, one arg, `lambda'. | |
| 7627 If due to `eval' entry, one arg, t. | |
| 7628 */ ); | |
| 7629 Vdebugger = Qnil; | |
| 7630 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7631 DEFVAR_CONST_INT ("multiple-values-limit", &Vmultiple_values_limit /* |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7632 The exclusive upper bound on the number of multiple values. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7633 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7634 This applies to `values', `values-list', `multiple-value-bind' and related |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
7635 macros and special operators. |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7636 */); |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5506
diff
changeset
|
7637 Vmultiple_values_limit = MOST_POSITIVE_FIXNUM > INT_MAX ? INT_MAX : MOST_POSITIVE_FIXNUM; |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7638 |
|
5506
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
7639 DEFVAR_LISP ("macro-declaration-function", &Vmacro_declaration_function /* |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
7640 Function to process declarations in a macro definition. |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
7641 The function will be called with two args MACRO and DECL. |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
7642 MACRO is the name of the macro being defined. |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
7643 DECL is a list `(declare ...)' containing the declarations. |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
7644 The value the function returns is not used. |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
7645 */); |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
7646 Vmacro_declaration_function = Qnil; |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
7647 |
|
5615
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
7648 DEFVAR_LISP ("byte-compile-macro-environment", &Vbyte_compile_macro_environment /* |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
7649 Alist of macros defined in the file being compiled. |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
7650 Each element looks like (MACRONAME . DEFINITION). It is |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
7651 \(MACRONAME . nil) when a macro is redefined as a function. |
|
5658
289cf21be887
Don't augment ENVIRONMENT when that's not indicated, #'macroexpand.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5630
diff
changeset
|
7652 |
|
289cf21be887
Don't augment ENVIRONMENT when that's not indicated, #'macroexpand.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5630
diff
changeset
|
7653 You should normally access this using the &environment argument to |
|
289cf21be887
Don't augment ENVIRONMENT when that's not indicated, #'macroexpand.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5630
diff
changeset
|
7654 #'macrolet, #'defmacro* and friends, and not directly; see the documentation |
|
289cf21be887
Don't augment ENVIRONMENT when that's not indicated, #'macroexpand.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5630
diff
changeset
|
7655 of those macros. |
|
5615
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
7656 */); |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
7657 Vbyte_compile_macro_environment = Qnil; |
|
5f4f92a31875
Move the functionality of #'cl-macroexpand into Fmacroexpand, eval.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5581
diff
changeset
|
7658 |
| 853 | 7659 staticpro (&Vcatch_everything_tag); |
| 7660 Vcatch_everything_tag = make_opaque (OPAQUE_CLEAR, 0); | |
| 7661 | |
| 428 | 7662 staticpro (&Vpending_warnings); |
| 7663 Vpending_warnings = Qnil; | |
| 1204 | 7664 dump_add_root_lisp_object (&Vpending_warnings_tail); |
| 428 | 7665 Vpending_warnings_tail = Qnil; |
| 7666 | |
| 793 | 7667 DEFVAR_LISP ("log-warning-minimum-level", &Vlog_warning_minimum_level); |
| 7668 Vlog_warning_minimum_level = Qinfo; | |
| 7669 | |
| 428 | 7670 staticpro (&Vautoload_queue); |
| 7671 Vautoload_queue = Qnil; | |
| 7672 | |
| 7673 staticpro (&Vcondition_handlers); | |
| 7674 | |
| 853 | 7675 staticpro (&Vdeletable_permanent_display_objects); |
| 7676 Vdeletable_permanent_display_objects = Qnil; | |
| 7677 | |
| 7678 staticpro (&Vmodifiable_buffers); | |
| 7679 Vmodifiable_buffers = Qnil; | |
| 7680 | |
| 7681 inhibit_flags = 0; | |
| 7682 } |