Mercurial > hg > xemacs-beta
annotate src/eval.c @ 5518:3cc7470ea71c
gnuclient: if TMPDIR was set and connect failed, try again with /tmp
2011-06-03 Aidan Kehoe <kehoea@parhasard.net>
* gnuslib.c (connect_to_unix_server):
Retry with /tmp as a directory in which to search for Unix sockets
if an attempt to connect with some other directory failed (which
may be because gnuclient and gnuserv don't share an environment
value for TMPDIR, or because gnuserv was compiled with USE_TMPDIR
turned off).
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Fri, 03 Jun 2011 18:40:57 +0100 |
| parents | b0d87f92e60b |
| children | 56144c8593a8 |
| 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; | |
| 233 Lisp_Object Qdebugger; | |
| 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 | |
|
5506
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
276 Lisp_Object Vmacro_declaration_function; |
|
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? */ | |
| 1245 Fsignal (Qwrong_number_of_arguments, list2 (Qsetq, make_int (nargs))); | |
| 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, |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1284 list2 (Qquote, make_int (nargs))); |
|
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, |
|
1096ef427b56
Error on too many arguments to #'function, #'quote.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
1366 list2 (Qfunction, make_int (nargs))); |
|
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 { |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1413 Lisp_Object declare = Fnth (make_int (2), args); |
|
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 { |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
1429 declare = Fnth (make_int (3), args); |
|
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 |
| 1552 DEFUN ("macroexpand-internal", Fmacroexpand_internal, 1, 2, 0, /* | |
| 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; | |
| 1566 | |
| 1567 while (1) | |
| 1568 { | |
| 1569 /* Come back here each time we expand a macro call, | |
| 1570 in case it expands into another macro call. */ | |
| 1571 if (!CONSP (form)) | |
| 1572 break; | |
| 1573 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */ | |
| 1574 def = sym = XCAR (form); | |
| 1575 tem = Qnil; | |
| 1576 /* Trace symbols aliases to other symbols | |
| 1577 until we get a symbol that is not an alias. */ | |
| 1578 while (SYMBOLP (def)) | |
| 1579 { | |
| 1580 QUIT; | |
| 1581 sym = def; | |
| 442 | 1582 tem = Fassq (sym, environment); |
| 428 | 1583 if (NILP (tem)) |
| 1584 { | |
| 1585 def = XSYMBOL (sym)->function; | |
| 1586 if (!UNBOUNDP (def)) | |
| 1587 continue; | |
| 1588 } | |
| 1589 break; | |
| 1590 } | |
| 442 | 1591 /* Right now TEM is the result from SYM in ENVIRONMENT, |
| 428 | 1592 and if TEM is nil then DEF is SYM's function definition. */ |
| 1593 if (NILP (tem)) | |
| 1594 { | |
| 442 | 1595 /* SYM is not mentioned in ENVIRONMENT. |
| 428 | 1596 Look at its function definition. */ |
| 1597 if (UNBOUNDP (def) | |
| 1598 || !CONSP (def)) | |
| 1599 /* Not defined or definition not suitable */ | |
| 1600 break; | |
| 1601 if (EQ (XCAR (def), Qautoload)) | |
| 1602 { | |
| 1603 /* Autoloading function: will it be a macro when loaded? */ | |
| 1604 tem = Felt (def, make_int (4)); | |
| 1605 if (EQ (tem, Qt) || EQ (tem, Qmacro)) | |
| 1606 { | |
| 1607 /* Yes, load it and try again. */ | |
| 970 | 1608 /* do_autoload GCPROs both arguments */ |
| 428 | 1609 do_autoload (def, sym); |
| 1610 continue; | |
| 1611 } | |
| 1612 else | |
| 1613 break; | |
| 1614 } | |
| 1615 else if (!EQ (XCAR (def), Qmacro)) | |
| 1616 break; | |
| 1617 else expander = XCDR (def); | |
| 1618 } | |
| 1619 else | |
| 1620 { | |
| 1621 expander = XCDR (tem); | |
| 1622 if (NILP (expander)) | |
| 1623 break; | |
| 1624 } | |
| 1625 form = apply1 (expander, XCDR (form)); | |
| 1626 } | |
| 1627 return form; | |
| 1628 } | |
| 1629 | |
| 1630 | |
| 1631 /************************************************************************/ | |
| 1632 /* Non-local exits */ | |
| 1633 /************************************************************************/ | |
| 1634 | |
| 1318 | 1635 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS |
| 1636 | |
| 1637 int | |
| 1638 proper_redisplay_wrapping_in_place (void) | |
| 1639 { | |
| 1640 return !in_display | |
| 1641 || ((get_inhibit_flags () & INTERNAL_INHIBIT_ERRORS) | |
| 1642 && (get_inhibit_flags () & INTERNAL_INHIBIT_THROWS)); | |
| 1643 } | |
| 1644 | |
| 1645 static void | |
| 1646 check_proper_critical_section_nonlocal_exit_protection (void) | |
| 1647 { | |
| 1648 assert_with_message | |
| 1649 (proper_redisplay_wrapping_in_place (), | |
| 1650 "Attempted non-local exit from within redisplay without being properly wrapped"); | |
| 1651 } | |
| 1652 | |
| 1653 static void | |
| 1654 check_proper_critical_section_lisp_protection (void) | |
| 1655 { | |
| 1656 assert_with_message | |
| 1657 (proper_redisplay_wrapping_in_place (), | |
| 1658 "Attempt to call Lisp code from within redisplay without being properly wrapped"); | |
| 1659 } | |
| 1660 | |
| 1661 #endif /* ERROR_CHECK_TRAPPING_PROBLEMS */ | |
| 1662 | |
| 428 | 1663 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
|
1664 Eval BODY allowing nonlocal exits using `throw'. |
| 428 | 1665 TAG is evalled to get the tag to use. Then the BODY is executed. |
| 3577 | 1666 Within BODY, (throw TAG VAL) with same (`eq') tag exits BODY and this `catch'. |
| 428 | 1667 If no throw happens, `catch' returns the value of the last BODY form. |
| 1668 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
|
1669 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1670 arguments: (TAG &rest BODY) |
| 428 | 1671 */ |
| 1672 (args)) | |
| 1673 { | |
| 1674 /* This function can GC */ | |
| 1675 Lisp_Object tag = Feval (XCAR (args)); | |
| 1676 Lisp_Object body = XCDR (args); | |
| 2532 | 1677 return internal_catch (tag, Fprogn, body, 0, 0, 0); |
| 428 | 1678 } |
| 1679 | |
| 1680 /* Set up a catch, then call C function FUNC on argument ARG. | |
| 1681 FUNC should return a Lisp_Object. | |
| 1682 This is how catches are done from within C code. */ | |
| 1683 | |
| 1684 Lisp_Object | |
| 1685 internal_catch (Lisp_Object tag, | |
| 1686 Lisp_Object (*func) (Lisp_Object arg), | |
| 1687 Lisp_Object arg, | |
| 853 | 1688 int * volatile threw, |
| 2532 | 1689 Lisp_Object * volatile thrown_tag, |
| 1690 Lisp_Object * volatile backtrace_before_throw) | |
| 428 | 1691 { |
| 1692 /* This structure is made part of the chain `catchlist'. */ | |
| 1693 struct catchtag c; | |
| 1694 | |
| 1695 /* Fill in the components of c, and put it on the list. */ | |
| 1696 c.next = catchlist; | |
| 1697 c.tag = tag; | |
| 853 | 1698 c.actual_tag = Qnil; |
| 2532 | 1699 c.backtrace = Qnil; |
| 428 | 1700 c.val = Qnil; |
| 1701 c.backlist = backtrace_list; | |
| 1702 #if 0 /* FSFmacs */ | |
| 1703 /* #### */ | |
| 1704 c.handlerlist = handlerlist; | |
| 1705 #endif | |
| 1706 c.lisp_eval_depth = lisp_eval_depth; | |
| 1707 c.pdlcount = specpdl_depth(); | |
| 1708 #if 0 /* FSFmacs */ | |
| 1709 c.poll_suppress_count = async_timer_suppress_count; | |
| 1710 #endif | |
| 1711 c.gcpro = gcprolist; | |
| 1712 catchlist = &c; | |
| 1713 | |
| 1714 /* Call FUNC. */ | |
| 1715 if (SETJMP (c.jmp)) | |
| 1716 { | |
| 1717 /* Throw works by a longjmp that comes right here. */ | |
| 1718 if (threw) *threw = 1; | |
| 853 | 1719 if (thrown_tag) *thrown_tag = c.actual_tag; |
| 2532 | 1720 if (backtrace_before_throw) *backtrace_before_throw = c.backtrace; |
| 428 | 1721 return c.val; |
| 1722 } | |
| 1723 c.val = (*func) (arg); | |
| 1724 if (threw) *threw = 0; | |
| 853 | 1725 if (thrown_tag) *thrown_tag = Qnil; |
| 428 | 1726 catchlist = c.next; |
| 853 | 1727 check_catchlist_sanity (); |
| 428 | 1728 return c.val; |
| 1729 } | |
| 1730 | |
| 1731 | |
| 1732 /* Unwind the specbind, catch, and handler stacks back to CATCH, and | |
| 1733 jump to that CATCH, returning VALUE as the value of that catch. | |
| 1734 | |
| 2297 | 1735 This is the guts of Fthrow and Fsignal; they differ only in the |
| 1736 way they choose the catch tag to throw to. A catch tag for a | |
| 428 | 1737 condition-case form has a TAG of Qnil. |
| 1738 | |
| 1739 Before each catch is discarded, unbind all special bindings and | |
| 1740 execute all unwind-protect clauses made above that catch. Unwind | |
| 1741 the handler stack as we go, so that the proper handlers are in | |
| 1742 effect for each unwind-protect clause we run. At the end, restore | |
| 1743 some static info saved in CATCH, and longjmp to the location | |
| 1744 specified in the | |
| 1745 | |
| 1746 This is used for correct unwinding in Fthrow and Fsignal. */ | |
| 1747 | |
| 2268 | 1748 static DECLARE_DOESNT_RETURN (unwind_to_catch (struct catchtag *, Lisp_Object, |
| 1749 Lisp_Object)); | |
| 1750 | |
| 1751 static DOESNT_RETURN | |
| 853 | 1752 unwind_to_catch (struct catchtag *c, Lisp_Object val, Lisp_Object tag) |
| 428 | 1753 { |
| 1754 REGISTER int last_time; | |
| 1755 | |
| 1756 /* Unwind the specbind, catch, and handler stacks back to CATCH | |
| 1757 Before each catch is discarded, unbind all special bindings | |
| 1758 and execute all unwind-protect clauses made above that catch. | |
| 1759 At the end, restore some static info saved in CATCH, | |
| 1760 and longjmp to the location specified. | |
| 1761 */ | |
| 1762 | |
| 1763 /* Save the value somewhere it will be GC'ed. | |
| 1764 (Can't overwrite tag slot because an unwind-protect may | |
| 1765 want to throw to this same tag, which isn't yet invalid.) */ | |
| 1766 c->val = val; | |
| 853 | 1767 c->actual_tag = tag; |
| 428 | 1768 |
| 1769 #if 0 /* FSFmacs */ | |
| 1770 /* Restore the polling-suppression count. */ | |
| 1771 set_poll_suppress_count (catch->poll_suppress_count); | |
| 1772 #endif | |
| 1773 | |
| 617 | 1774 #if 1 |
| 428 | 1775 do |
| 1776 { | |
| 1777 last_time = catchlist == c; | |
| 1778 | |
| 1779 /* Unwind the specpdl stack, and then restore the proper set of | |
| 1780 handlers. */ | |
| 771 | 1781 unbind_to (catchlist->pdlcount); |
| 428 | 1782 catchlist = catchlist->next; |
| 853 | 1783 check_catchlist_sanity (); |
| 428 | 1784 } |
| 1785 while (! last_time); | |
| 617 | 1786 #else |
| 1787 /* Former XEmacs code. This is definitely not as correct because | |
| 1788 there may be a number of catches we're unwinding, and a number | |
| 1789 of unwind-protects in the process. By not undoing the catches till | |
| 1790 the end, there may be invalid catches still current. (This would | |
| 1791 be a particular problem with code like this: | |
| 1792 | |
| 1793 (catch 'foo | |
| 1794 (call-some-code-which-does... | |
| 1795 (catch 'bar | |
| 1796 (unwind-protect | |
| 1797 (call-some-code-which-does... | |
| 1798 (catch 'bar | |
| 1799 (call-some-code-which-does... | |
| 1800 (throw 'foo nil)))) | |
| 1801 (throw 'bar nil))))) | |
| 1802 | |
| 1803 This would try to throw to the inner (catch 'bar)! | |
| 1804 | |
| 1805 --ben | |
| 1806 */ | |
| 428 | 1807 /* Unwind the specpdl stack */ |
| 771 | 1808 unbind_to (c->pdlcount); |
| 428 | 1809 catchlist = c->next; |
| 853 | 1810 check_catchlist_sanity (); |
| 617 | 1811 #endif /* Former code */ |
| 428 | 1812 |
| 1204 | 1813 UNWIND_GCPRO_TO (c->gcpro); |
| 1292 | 1814 if (profiling_active) |
| 1815 { | |
| 1816 while (backtrace_list != c->backlist) | |
| 1817 { | |
| 1818 profile_record_unwind (backtrace_list); | |
| 1819 backtrace_list = backtrace_list->next; | |
| 1820 } | |
| 1821 } | |
| 1822 else | |
| 1823 backtrace_list = c->backlist; | |
| 428 | 1824 lisp_eval_depth = c->lisp_eval_depth; |
| 1825 | |
| 442 | 1826 #ifdef DEFEND_AGAINST_THROW_RECURSION |
| 428 | 1827 throw_level = 0; |
| 1828 #endif | |
| 1829 LONGJMP (c->jmp, 1); | |
| 1830 } | |
| 1831 | |
|
5348
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1832 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
|
1833 Lisp_Object, Lisp_Object)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1834 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1835 DOESNT_RETURN |
|
5348
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1836 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
|
1837 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
|
1838 { |
| 428 | 1839 /* If bomb_out_p is t, this is being called from Fsignal as a |
| 1840 "last resort" when there is no handler for this error and | |
| 1841 the debugger couldn't be invoked, so we are throwing to | |
| 3025 | 1842 `top-level'. If this tag doesn't exist (happens during the |
| 428 | 1843 initialization stages) we would get in an infinite recursive |
| 1844 Fsignal/Fthrow loop, so instead we bomb out to the | |
| 1845 really-early-error-handler. | |
| 1846 | |
| 1847 Note that in fact the only time that the "last resort" | |
| 3025 | 1848 occurs is when there's no catch for `top-level' -- the |
| 1849 `top-level' catch and the catch-all error handler are | |
| 428 | 1850 established at the same time, in initial_command_loop/ |
| 1851 top_level_1. | |
| 1852 | |
| 853 | 1853 [[#### Fix this horrifitude!]] |
| 1854 | |
| 1855 I don't think this is horrifitude, just defensive programming. --ben | |
| 428 | 1856 */ |
| 1857 | |
| 1858 while (1) | |
| 1859 { | |
| 1860 REGISTER struct catchtag *c; | |
| 1861 | |
| 1862 #if 0 /* FSFmacs */ | |
| 1863 if (!NILP (tag)) /* #### */ | |
| 1864 #endif | |
| 1865 for (c = catchlist; c; c = c->next) | |
| 1866 { | |
| 2532 | 1867 if (EQ (c->tag, Vcatch_everything_tag)) |
| 1868 c->backtrace = maybe_get_trapping_problems_backtrace (); | |
| 853 | 1869 if (EQ (c->tag, tag) || EQ (c->tag, Vcatch_everything_tag)) |
| 1870 unwind_to_catch (c, val, tag); | |
| 428 | 1871 } |
| 1872 if (!bomb_out_p) | |
| 1873 tag = Fsignal (Qno_catch, list2 (tag, val)); | |
| 1874 else | |
| 1875 call1 (Qreally_early_error_handler, Fcons (sig, data)); | |
| 1876 } | |
| 1877 } | |
|
5348
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1878 |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1879 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
|
1880 Lisp_Object, Lisp_Object)); |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1881 |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1882 DOESNT_RETURN |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1883 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
|
1884 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
|
1885 { |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1886 #ifdef DEFEND_AGAINST_THROW_RECURSION |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1887 /* 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
|
1888 assert (++throw_level <= 20); |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1889 #endif |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1890 |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1891 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1892 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
|
1893 #endif |
|
39304a35b6b3
Don't commit suicide when an X device dies.
Mike Sperber <sperber@deinprogramm.de>
parents:
5307
diff
changeset
|
1894 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
|
1895 } |
| 428 | 1896 |
| 1897 /* See above, where CATCHLIST is defined, for a description of how | |
| 1898 Fthrow() works. | |
| 1899 | |
| 1900 Fthrow() is also called by Fsignal(), to do a non-local jump | |
| 1901 back to the appropriate condition-case handler after (maybe) | |
| 1902 the debugger is entered. In that case, TAG is the value | |
| 1903 of Vcondition_handlers that was in place just after the | |
| 1904 condition-case handler was set up. The car of this will be | |
| 1905 some data referring to the handler: Its car will be Qunbound | |
| 1906 (thus, this tag can never be generated by Lisp code), and | |
| 1907 its CDR will be the HANDLERS argument to condition_case_1() | |
| 1908 (either Qerror, Qt, or a list of handlers as in `condition-case'). | |
| 1909 This works fine because Fthrow() does not care what TAG was | |
| 1910 passed to it: it just looks up the catch list for something | |
| 1911 that is EQ() to TAG. When it finds it, it will longjmp() | |
| 1912 back to the place that established the catch (in this case, | |
| 1913 condition_case_1). See below for more info. | |
| 1914 */ | |
| 1915 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1916 DEFUN_NORETURN ("throw", Fthrow, 2, UNEVALLED, 0, /* |
| 444 | 1917 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
|
1918 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1919 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
|
1920 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
|
1921 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1922 arguments: (TAG VALUE) |
| 428 | 1923 */ |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1924 (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1925 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1926 int nargs; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1927 Lisp_Object tag, value; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1928 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1929 GET_LIST_LENGTH (args, nargs); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1930 if (nargs != 2) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1931 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1932 Fsignal (Qwrong_number_of_arguments, list2 (Qthrow, make_int (nargs))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1933 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1934 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1935 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
|
1936 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1937 value = Feval (XCAR (XCDR (args))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1938 |
| 444 | 1939 throw_or_bomb_out (tag, value, 0, Qnil, Qnil); /* Doesn't return */ |
| 2268 | 1940 RETURN_NOT_REACHED (Qnil); |
| 428 | 1941 } |
| 1942 | |
| 1943 DEFUN ("unwind-protect", Funwind_protect, 1, UNEVALLED, 0, /* | |
| 1944 Do BODYFORM, protecting with UNWINDFORMS. | |
| 1945 If BODYFORM completes normally, its value is returned | |
| 1946 after executing the UNWINDFORMS. | |
| 1947 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
|
1948 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1949 arguments: (BODYFORM &rest UNWINDFORMS) |
| 428 | 1950 */ |
| 1951 (args)) | |
| 1952 { | |
| 1953 /* This function can GC */ | |
| 1954 int speccount = specpdl_depth(); | |
| 1955 | |
| 1956 record_unwind_protect (Fprogn, XCDR (args)); | |
| 771 | 1957 return unbind_to_1 (speccount, Feval (XCAR (args))); |
| 428 | 1958 } |
| 1959 | |
| 1960 | |
| 1961 /************************************************************************/ | |
| 1292 | 1962 /* Trapping errors */ |
| 428 | 1963 /************************************************************************/ |
| 1964 | |
| 1965 static Lisp_Object | |
| 1966 condition_bind_unwind (Lisp_Object loser) | |
| 1967 { | |
| 617 | 1968 /* There is no problem freeing stuff here like there is in |
| 1969 condition_case_unwind(), because there are no outside pointers | |
| 1970 (like the tag below in the catchlist) pointing to the objects. */ | |
| 853 | 1971 |
| 428 | 1972 /* ((handler-fun . handler-args) ... other handlers) */ |
| 1973 Lisp_Object tem = XCAR (loser); | |
| 853 | 1974 int first = 1; |
| 428 | 1975 |
| 1976 while (CONSP (tem)) | |
| 1977 { | |
| 853 | 1978 Lisp_Object victim = tem; |
| 1979 if (first && OPAQUE_PTRP (XCAR (victim))) | |
| 1980 free_opaque_ptr (XCAR (victim)); | |
| 1981 first = 0; | |
| 1982 tem = XCDR (victim); | |
| 428 | 1983 free_cons (victim); |
| 1984 } | |
| 1985 | |
| 1986 if (EQ (loser, Vcondition_handlers)) /* may have been rebound to some tail */ | |
| 853 | 1987 Vcondition_handlers = XCDR (loser); |
| 1988 | |
| 1989 free_cons (loser); | |
| 428 | 1990 return Qnil; |
| 1991 } | |
| 1992 | |
| 1993 static Lisp_Object | |
| 1994 condition_case_unwind (Lisp_Object loser) | |
| 1995 { | |
| 1996 /* ((<unbound> . clauses) ... other handlers */ | |
| 617 | 1997 /* NO! Doing this now leaves the tag deleted in a still-active |
| 1998 catch. With the recent changes to unwind_to_catch(), the | |
| 1999 evil situation might not happen any more; it certainly could | |
| 2000 happen before because it did. But it's very precarious to rely | |
| 2001 on something like this. #### Instead we should rewrite, adopting | |
| 2002 the FSF's mechanism with a struct handler instead of | |
| 2003 Vcondition_handlers; then we have NO Lisp-object structures used | |
| 2004 to hold all of the values, and there's no possibility either of | |
| 2005 crashes from freeing objects too quickly, or objects not getting | |
| 2006 freed and hanging around till the next GC. | |
| 2007 | |
| 2008 In practice, the extra consing here should not matter because | |
| 2009 it only happens when we throw past the condition-case, which almost | |
| 2010 always is the result of an error. Most of the time, there will be | |
| 2011 no error, and we will free the objects below in the main function. | |
| 2012 | |
| 2013 --ben | |
| 2014 | |
| 2015 DO NOT DO: free_cons (XCAR (loser)); | |
| 2016 */ | |
| 2017 | |
| 428 | 2018 if (EQ (loser, Vcondition_handlers)) /* may have been rebound to some tail */ |
| 617 | 2019 Vcondition_handlers = XCDR (loser); |
| 2020 | |
| 2021 /* DO NOT DO: free_cons (loser); */ | |
| 428 | 2022 return Qnil; |
| 2023 } | |
| 2024 | |
| 2025 /* Split out from condition_case_3 so that primitive C callers | |
| 2026 don't have to cons up a lisp handler form to be evaluated. */ | |
| 2027 | |
| 2028 /* Call a function BFUN of one argument BARG, trapping errors as | |
| 2029 specified by HANDLERS. If no error occurs that is indicated by | |
| 2030 HANDLERS as something to be caught, the return value of this | |
| 2031 function is the return value from BFUN. If such an error does | |
| 2032 occur, HFUN is called, and its return value becomes the | |
| 2033 return value of condition_case_1(). The second argument passed | |
| 2034 to HFUN will always be HARG. The first argument depends on | |
| 2035 HANDLERS: | |
| 2036 | |
| 2037 If HANDLERS is Qt, all errors (this includes QUIT, but not | |
| 2038 non-local exits with `throw') cause HFUN to be invoked, and VAL | |
| 2039 (the first argument to HFUN) is a cons (SIG . DATA) of the | |
| 2040 arguments passed to `signal'. The debugger is not invoked even if | |
| 2041 `debug-on-error' was set. | |
| 2042 | |
| 2043 A HANDLERS value of Qerror is the same as Qt except that the | |
| 2044 debugger is invoked if `debug-on-error' was set. | |
| 2045 | |
| 2046 Otherwise, HANDLERS should be a list of lists (CONDITION-NAME BODY ...) | |
| 2047 exactly as in `condition-case', and errors will be trapped | |
| 2048 as indicated in HANDLERS. VAL (the first argument to HFUN) will | |
| 2049 be a cons whose car is the cons (SIG . DATA) and whose CDR is the | |
| 2050 list (BODY ...) from the appropriate slot in HANDLERS. | |
| 2051 | |
| 2052 This function pushes HANDLERS onto the front of Vcondition_handlers | |
| 2053 (actually with a Qunbound marker as well -- see Fthrow() above | |
| 2054 for why), establishes a catch whose tag is this new value of | |
| 2055 Vcondition_handlers, and calls BFUN. When Fsignal() is called, | |
| 2056 it calls Fthrow(), setting TAG to this same new value of | |
| 2057 Vcondition_handlers and setting VAL to the same thing that will | |
| 2058 be passed to HFUN, as above. Fthrow() longjmp()s back to the | |
| 2059 jump point we just established, and we in turn just call the | |
| 2060 HFUN and return its value. | |
| 2061 | |
| 2062 For a real condition-case, HFUN will always be | |
| 2063 run_condition_case_handlers() and HARG is the argument VAR | |
| 2064 to condition-case. That function just binds VAR to the cons | |
| 2065 (SIG . DATA) that is the CAR of VAL, and calls the handler | |
| 2066 (BODY ...) that is the CDR of VAL. Note that before calling | |
| 2067 Fthrow(), Fsignal() restored Vcondition_handlers to the value | |
| 2068 it had *before* condition_case_1() was called. This maintains | |
| 2069 consistency (so that the state of things at exit of | |
| 2070 condition_case_1() is the same as at entry), and implies | |
| 2071 that the handler can signal the same error again (possibly | |
| 2072 after processing of its own), without getting in an infinite | |
| 2073 loop. */ | |
| 2074 | |
| 2075 Lisp_Object | |
| 2076 condition_case_1 (Lisp_Object handlers, | |
| 2077 Lisp_Object (*bfun) (Lisp_Object barg), | |
| 2078 Lisp_Object barg, | |
| 2079 Lisp_Object (*hfun) (Lisp_Object val, Lisp_Object harg), | |
| 2080 Lisp_Object harg) | |
| 2081 { | |
| 2082 int speccount = specpdl_depth(); | |
| 2083 struct catchtag c; | |
| 617 | 2084 struct gcpro gcpro1, gcpro2, gcpro3; |
| 428 | 2085 |
| 2086 #if 0 /* FSFmacs */ | |
| 2087 c.tag = Qnil; | |
| 2088 #else | |
| 2089 /* Do consing now so out-of-memory error happens up front */ | |
| 2090 /* (unbound . stuff) is a special condition-case kludge marker | |
| 2091 which is known specially by Fsignal. | |
| 617 | 2092 [[ This is an abomination, but to fix it would require either |
| 428 | 2093 making condition_case cons (a union of the conditions of the clauses) |
| 617 | 2094 or changing the byte-compiler output (no thanks).]] |
| 2095 | |
| 2096 The above comment is clearly wrong. FSF does not do it this way | |
| 2097 and did not change the byte-compiler output. Instead they use a | |
| 2098 `struct handler' to hold the various values (in place of our | |
| 2099 Vcondition_handlers) and chain them together, with pointers from | |
| 2100 the `struct catchtag' to the `struct handler'. We should perhaps | |
| 2101 consider moving to something similar, but not before I merge my | |
| 2102 stderr-proc workspace, which contains changes to these | |
| 2103 functions. --ben */ | |
| 428 | 2104 c.tag = noseeum_cons (noseeum_cons (Qunbound, handlers), |
| 2105 Vcondition_handlers); | |
| 2106 #endif | |
| 2107 c.val = Qnil; | |
| 853 | 2108 c.actual_tag = Qnil; |
| 2532 | 2109 c.backtrace = Qnil; |
| 428 | 2110 c.backlist = backtrace_list; |
| 2111 #if 0 /* FSFmacs */ | |
| 2112 /* #### */ | |
| 2113 c.handlerlist = handlerlist; | |
| 2114 #endif | |
| 2115 c.lisp_eval_depth = lisp_eval_depth; | |
| 2116 c.pdlcount = specpdl_depth(); | |
| 2117 #if 0 /* FSFmacs */ | |
| 2118 c.poll_suppress_count = async_timer_suppress_count; | |
| 2119 #endif | |
| 2120 c.gcpro = gcprolist; | |
| 2121 /* #### FSFmacs does the following statement *after* the setjmp(). */ | |
| 2122 c.next = catchlist; | |
| 2123 | |
| 2124 if (SETJMP (c.jmp)) | |
| 2125 { | |
| 2126 /* throw does ungcpro, etc */ | |
| 2127 return (*hfun) (c.val, harg); | |
| 2128 } | |
| 2129 | |
| 2130 record_unwind_protect (condition_case_unwind, c.tag); | |
| 2131 | |
| 2132 catchlist = &c; | |
| 2133 #if 0 /* FSFmacs */ | |
| 2134 h.handler = handlers; | |
| 2135 h.var = Qnil; | |
| 2136 h.next = handlerlist; | |
| 2137 h.tag = &c; | |
| 2138 handlerlist = &h; | |
| 2139 #else | |
| 2140 Vcondition_handlers = c.tag; | |
| 2141 #endif | |
| 2142 GCPRO1 (harg); /* Somebody has to gc-protect */ | |
| 2143 c.val = ((*bfun) (barg)); | |
| 2144 UNGCPRO; | |
| 617 | 2145 |
| 2146 /* Once we change `catchlist' below, the stuff in c will not be GCPRO'd. */ | |
| 2147 GCPRO3 (harg, c.val, c.tag); | |
| 2148 | |
| 428 | 2149 catchlist = c.next; |
| 853 | 2150 check_catchlist_sanity (); |
| 617 | 2151 /* Note: The unbind also resets Vcondition_handlers. Maybe we should |
| 2152 delete this here. */ | |
| 428 | 2153 Vcondition_handlers = XCDR (c.tag); |
| 771 | 2154 unbind_to (speccount); |
| 617 | 2155 |
| 2156 UNGCPRO; | |
| 2157 /* free the conses *after* the unbind, because the unbind will run | |
| 2158 condition_case_unwind above. */ | |
| 853 | 2159 free_cons (XCAR (c.tag)); |
| 2160 free_cons (c.tag); | |
| 617 | 2161 return c.val; |
| 428 | 2162 } |
| 2163 | |
| 2164 static Lisp_Object | |
| 2165 run_condition_case_handlers (Lisp_Object val, Lisp_Object var) | |
| 2166 { | |
| 2167 /* This function can GC */ | |
| 2168 #if 0 /* FSFmacs */ | |
| 2169 if (!NILP (h.var)) | |
| 2170 specbind (h.var, c.val); | |
| 2171 val = Fprogn (Fcdr (h.chosen_clause)); | |
| 2172 | |
| 2173 /* Note that this just undoes the binding of h.var; whoever | |
| 2174 longjmp()ed to us unwound the stack to c.pdlcount before | |
| 2175 throwing. */ | |
| 771 | 2176 unbind_to (c.pdlcount); |
| 428 | 2177 return val; |
| 2178 #else | |
| 2179 int speccount; | |
| 2180 | |
| 2181 CHECK_TRUE_LIST (val); | |
| 2182 if (NILP (var)) | |
| 2183 return Fprogn (Fcdr (val)); /* tail call */ | |
| 2184 | |
| 2185 speccount = specpdl_depth(); | |
| 2186 specbind (var, Fcar (val)); | |
| 2187 val = Fprogn (Fcdr (val)); | |
| 771 | 2188 return unbind_to_1 (speccount, val); |
| 428 | 2189 #endif |
| 2190 } | |
| 2191 | |
| 2192 /* Here for bytecode to call non-consfully. This is exactly like | |
| 2193 condition-case except that it takes three arguments rather | |
| 2194 than a single list of arguments. */ | |
| 2195 Lisp_Object | |
| 2196 condition_case_3 (Lisp_Object bodyform, Lisp_Object var, Lisp_Object handlers) | |
| 2197 { | |
| 2198 /* This function can GC */ | |
| 2199 EXTERNAL_LIST_LOOP_2 (handler, handlers) | |
| 2200 { | |
| 2201 if (NILP (handler)) | |
| 2202 ; | |
| 2203 else if (CONSP (handler)) | |
| 2204 { | |
| 2205 Lisp_Object conditions = XCAR (handler); | |
| 2206 /* CONDITIONS must a condition name or a list of condition names */ | |
| 2207 if (SYMBOLP (conditions)) | |
| 2208 ; | |
| 2209 else | |
| 2210 { | |
| 2211 EXTERNAL_LIST_LOOP_2 (condition, conditions) | |
| 2212 if (!SYMBOLP (condition)) | |
| 2213 goto invalid_condition_handler; | |
| 2214 } | |
| 2215 } | |
| 2216 else | |
| 2217 { | |
| 2218 invalid_condition_handler: | |
| 563 | 2219 sferror ("Invalid condition handler", handler); |
| 428 | 2220 } |
| 2221 } | |
| 2222 | |
| 2223 CHECK_SYMBOL (var); | |
| 2224 | |
| 2225 return condition_case_1 (handlers, | |
| 2226 Feval, bodyform, | |
| 2227 run_condition_case_handlers, | |
| 2228 var); | |
| 2229 } | |
| 2230 | |
| 2231 DEFUN ("condition-case", Fcondition_case, 2, UNEVALLED, 0, /* | |
| 2232 Regain control when an error is signalled. | |
| 2233 Usage looks like (condition-case VAR BODYFORM HANDLERS...). | |
| 2234 Executes BODYFORM and returns its value if no error happens. | |
| 2235 Each element of HANDLERS looks like (CONDITION-NAME BODY...) | |
| 2236 where the BODY is made of Lisp expressions. | |
| 2237 | |
| 771 | 2238 A typical usage of `condition-case' looks like this: |
| 2239 | |
| 2240 (condition-case nil | |
| 2241 ;; you need a progn here if you want more than one statement ... | |
| 2242 (progn | |
| 2243 (do-something) | |
| 2244 (do-something-else)) | |
| 2245 (error | |
| 2246 (issue-warning-or) | |
| 2247 ;; but strangely, you don't need one here. | |
| 2248 (return-a-value-etc) | |
| 2249 )) | |
| 2250 | |
| 428 | 2251 A handler is applicable to an error if CONDITION-NAME is one of the |
| 2252 error's condition names. If an error happens, the first applicable | |
| 2253 handler is run. As a special case, a CONDITION-NAME of t matches | |
| 2254 all errors, even those without the `error' condition name on them | |
| 2255 \(e.g. `quit'). | |
| 2256 | |
| 2257 The car of a handler may be a list of condition names | |
| 2258 instead of a single condition name. | |
| 2259 | |
| 2260 When a handler handles an error, | |
| 2261 control returns to the condition-case and the handler BODY... is executed | |
| 2262 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA). | |
| 2263 VAR may be nil; then you do not get access to the signal information. | |
| 2264 | |
| 2265 The value of the last BODY form is returned from the condition-case. | |
| 2266 See also the function `signal' for more info. | |
| 2267 | |
| 2268 Note that at the time the condition handler is invoked, the Lisp stack | |
| 2269 and the current catches, condition-cases, and bindings have all been | |
| 2270 popped back to the state they were in just before the call to | |
| 2271 `condition-case'. This means that resignalling the error from | |
| 2272 within the handler will not result in an infinite loop. | |
| 2273 | |
| 2274 If you want to establish an error handler that is called with the | |
| 2275 Lisp stack, bindings, etc. as they were when `signal' was called, | |
| 2276 rather than when the handler was set, use `call-with-condition-handler'. | |
| 2277 */ | |
| 2278 (args)) | |
| 2279 { | |
| 2280 /* This function can GC */ | |
| 2281 Lisp_Object var = XCAR (args); | |
| 2282 Lisp_Object bodyform = XCAR (XCDR (args)); | |
| 2283 Lisp_Object handlers = XCDR (XCDR (args)); | |
| 2284 return condition_case_3 (bodyform, var, handlers); | |
| 2285 } | |
| 2286 | |
| 2287 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
|
2288 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
|
2289 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
2290 This function is similar to `condition-case', but HANDLER is invoked |
| 428 | 2291 with the same environment (Lisp stack, bindings, catches, condition-cases) |
| 2292 that was current when `signal' was called, rather than when the handler | |
| 2293 was established. | |
| 2294 | |
| 2295 HANDLER should be a function of one argument, which is a cons of the args | |
| 2296 \(SIG . DATA) that were passed to `signal'. It is invoked whenever | |
| 2297 `signal' is called (this differs from `condition-case', which allows | |
| 2298 you to specify which errors are trapped). If the handler function | |
| 2299 returns, `signal' continues as if the handler were never invoked. | |
| 2300 \(It continues to look for handlers established earlier than this one, | |
| 2301 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
|
2302 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
2303 arguments: (HANDLER FUNCTION &rest ARGS) |
| 428 | 2304 */ |
| 2305 (int nargs, Lisp_Object *args)) /* Note! Args side-effected! */ | |
| 2306 { | |
| 2307 /* This function can GC */ | |
| 2308 int speccount = specpdl_depth(); | |
| 2309 Lisp_Object tem; | |
| 2310 | |
| 853 | 2311 tem = Ffunction_max_args (args[0]); |
| 2312 if (! (XINT (Ffunction_min_args (args[0])) <= 1 | |
| 2313 && (NILP (tem) || 1 <= XINT (tem)))) | |
| 2314 invalid_argument ("Must be function of one argument", args[0]); | |
| 2315 | |
| 2316 /* (handler-fun . handler-args) but currently there are no handler-args */ | |
| 428 | 2317 tem = noseeum_cons (list1 (args[0]), Vcondition_handlers); |
| 2318 record_unwind_protect (condition_bind_unwind, tem); | |
| 2319 Vcondition_handlers = tem; | |
| 2320 | |
| 2321 /* Caller should have GC-protected args */ | |
| 771 | 2322 return unbind_to_1 (speccount, Ffuncall (nargs - 1, args + 1)); |
| 428 | 2323 } |
| 2324 | |
| 853 | 2325 /* This is the C version of the above function. It calls FUN, passing it |
| 2326 ARG, first setting up HANDLER to catch signals in the environment in | |
| 2327 which they were signalled. (HANDLER is only invoked if there was no | |
| 2328 handler (either from condition-case or call-with-condition-handler) set | |
| 2329 later on that handled the signal; therefore, this is a real error. | |
| 2330 | |
| 2331 HANDLER is invoked with three arguments: the ERROR-SYMBOL and DATA as | |
| 2332 passed to `signal', and HANDLER_ARG. Originally I made HANDLER_ARG and | |
| 2333 ARG be void * to facilitate passing structures, but I changed to | |
| 2334 Lisp_Objects because all the other C interfaces to catch/condition-case/etc. | |
| 2335 take Lisp_Objects, and it is easy enough to use make_opaque_ptr() et al. | |
| 2336 to convert between Lisp_Objects and structure pointers. */ | |
| 2337 | |
| 2338 Lisp_Object | |
| 2339 call_with_condition_handler (Lisp_Object (*handler) (Lisp_Object, Lisp_Object, | |
| 2340 Lisp_Object), | |
| 2341 Lisp_Object handler_arg, | |
| 2342 Lisp_Object (*fun) (Lisp_Object), | |
| 2343 Lisp_Object arg) | |
| 2344 { | |
| 2345 /* This function can GC */ | |
| 1111 | 2346 int speccount = specpdl_depth (); |
| 853 | 2347 Lisp_Object tem; |
| 2348 | |
| 2349 /* ((handler-fun . (handler-arg . nil)) ... ) */ | |
| 1111 | 2350 tem = noseeum_cons (noseeum_cons (make_opaque_ptr ((void *) handler), |
| 853 | 2351 noseeum_cons (handler_arg, Qnil)), |
| 2352 Vcondition_handlers); | |
| 2353 record_unwind_protect (condition_bind_unwind, tem); | |
| 2354 Vcondition_handlers = tem; | |
| 2355 | |
| 2356 return unbind_to_1 (speccount, (*fun) (arg)); | |
| 2357 } | |
| 2358 | |
| 428 | 2359 static int |
| 2360 condition_type_p (Lisp_Object type, Lisp_Object conditions) | |
| 2361 { | |
| 2362 if (EQ (type, Qt)) | |
| 2363 /* (condition-case c # (t c)) catches -all- signals | |
| 2364 * Use with caution! */ | |
| 2365 return 1; | |
| 2366 | |
| 2367 if (SYMBOLP (type)) | |
| 2368 return !NILP (Fmemq (type, conditions)); | |
| 2369 | |
| 2370 for (; CONSP (type); type = XCDR (type)) | |
| 2371 if (!NILP (Fmemq (XCAR (type), conditions))) | |
| 2372 return 1; | |
| 2373 | |
| 2374 return 0; | |
| 2375 } | |
| 2376 | |
| 2377 static Lisp_Object | |
| 2378 return_from_signal (Lisp_Object value) | |
| 2379 { | |
| 2380 #if 1 | |
| 2381 /* Most callers are not prepared to handle gc if this | |
| 2382 returns. So, since this feature is not very useful, | |
| 2383 take it out. */ | |
| 2384 /* Have called debugger; return value to signaller */ | |
| 2385 return value; | |
| 2386 #else /* But the reality is that that stinks, because: */ | |
| 2387 /* GACK!!! Really want some way for debug-on-quit errors | |
| 2388 to be continuable!! */ | |
| 563 | 2389 signal_error (Qunimplemented, |
| 2390 "Returning a value from an error is no longer supported", | |
| 2391 Qunbound); | |
| 428 | 2392 #endif |
| 2393 } | |
| 2394 | |
| 2395 | |
| 2396 /************************************************************************/ | |
| 2397 /* the workhorse error-signaling function */ | |
| 2398 /************************************************************************/ | |
| 2399 | |
| 853 | 2400 /* This exists only for debugging purposes, as a place to put a breakpoint |
| 2401 that won't get signalled for errors occurring when | |
| 2402 call_with_suspended_errors() was invoked. */ | |
| 2403 | |
| 872 | 2404 /* Don't make static or it might be compiled away */ |
| 2405 void signal_1 (void); | |
| 2406 | |
| 2407 void | |
| 853 | 2408 signal_1 (void) |
| 2409 { | |
| 2410 } | |
| 2411 | |
| 428 | 2412 /* #### This function has not been synched with FSF. It diverges |
| 2413 significantly. */ | |
| 2414 | |
| 853 | 2415 /* The simplest external error function: it would be called |
| 2416 signal_continuable_error() in the terminology below, but it's | |
| 2417 Lisp-callable. */ | |
| 2418 | |
| 2419 DEFUN ("signal", Fsignal, 2, 2, 0, /* | |
| 2420 Signal a continuable error. Args are ERROR-SYMBOL, and associated DATA. | |
| 2421 An error symbol is a symbol defined using `define-error'. | |
| 2422 DATA should be a list. Its elements are printed as part of the error message. | |
| 2423 If the signal is handled, DATA is made available to the handler. | |
| 2424 See also the function `signal-error', and the functions to handle errors: | |
| 2425 `condition-case' and `call-with-condition-handler'. | |
| 2426 | |
| 2427 Note that this function can return, if the debugger is invoked and the | |
| 2428 user invokes the "return from signal" option. | |
| 2429 */ | |
| 2430 (error_symbol, data)) | |
| 428 | 2431 { |
| 2432 /* This function can GC */ | |
| 853 | 2433 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; |
| 2434 Lisp_Object conditions = Qnil; | |
| 2435 Lisp_Object handlers = Qnil; | |
| 428 | 2436 /* signal_call_debugger() could get called more than once |
| 2437 (once when a call-with-condition-handler is about to | |
| 2438 be dealt with, and another when a condition-case handler | |
| 2439 is about to be invoked). So make sure the debugger and/or | |
| 2440 stack trace aren't done more than once. */ | |
| 2441 int stack_trace_displayed = 0; | |
| 2442 int debugger_entered = 0; | |
| 853 | 2443 |
| 2444 /* Fsignal() is one of these functions that's called all the time | |
| 2445 with newly-created Lisp objects. We allow this; but we must GC- | |
| 2446 protect the objects because all sorts of weird stuff could | |
| 2447 happen. */ | |
| 2448 | |
| 2449 GCPRO4 (conditions, handlers, error_symbol, data); | |
| 2450 | |
| 2451 if (!(inhibit_flags & CALL_WITH_SUSPENDED_ERRORS)) | |
| 2452 signal_1 (); | |
| 428 | 2453 |
| 2454 if (!initialized) | |
| 2455 { | |
| 2456 /* who knows how much has been initialized? Safest bet is | |
| 2457 just to bomb out immediately. */ | |
| 771 | 2458 stderr_out ("Error before initialization is complete!\n"); |
| 2500 | 2459 ABORT (); |
| 428 | 2460 } |
| 2461 | |
| 3092 | 2462 #ifndef NEW_GC |
| 1123 | 2463 assert (!gc_in_progress); |
| 3092 | 2464 #endif /* not NEW_GC */ |
| 1123 | 2465 |
| 2466 /* We abort if in_display and we are not protected, as garbage | |
| 2467 collections and non-local exits will invariably be fatal, but in | |
| 2468 messy, difficult-to-debug ways. See enter_redisplay_critical_section(). | |
| 2469 */ | |
| 2470 | |
| 1318 | 2471 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS |
| 1123 | 2472 check_proper_critical_section_nonlocal_exit_protection (); |
| 1318 | 2473 #endif |
| 428 | 2474 |
| 853 | 2475 conditions = Fget (error_symbol, Qerror_conditions, Qnil); |
| 428 | 2476 |
| 2477 for (handlers = Vcondition_handlers; | |
| 2478 CONSP (handlers); | |
| 2479 handlers = XCDR (handlers)) | |
| 2480 { | |
| 2481 Lisp_Object handler_fun = XCAR (XCAR (handlers)); | |
| 2482 Lisp_Object handler_data = XCDR (XCAR (handlers)); | |
| 2483 Lisp_Object outer_handlers = XCDR (handlers); | |
| 2484 | |
| 2485 if (!UNBOUNDP (handler_fun)) | |
| 2486 { | |
| 2487 /* call-with-condition-handler */ | |
| 2488 Lisp_Object tem; | |
| 2489 Lisp_Object all_handlers = Vcondition_handlers; | |
| 2490 struct gcpro ngcpro1; | |
| 2491 NGCPRO1 (all_handlers); | |
| 2492 Vcondition_handlers = outer_handlers; | |
| 2493 | |
| 853 | 2494 tem = signal_call_debugger (conditions, error_symbol, data, |
| 428 | 2495 outer_handlers, 1, |
| 2496 &stack_trace_displayed, | |
| 2497 &debugger_entered); | |
| 2498 if (!UNBOUNDP (tem)) | |
| 2499 RETURN_NUNGCPRO (return_from_signal (tem)); | |
| 2500 | |
| 853 | 2501 if (OPAQUE_PTRP (handler_fun)) |
| 2502 { | |
| 2503 if (NILP (handler_data)) | |
| 2504 { | |
| 2505 Lisp_Object (*hfun) (Lisp_Object, Lisp_Object) = | |
| 2506 (Lisp_Object (*) (Lisp_Object, Lisp_Object)) | |
| 2507 (get_opaque_ptr (handler_fun)); | |
| 2508 | |
| 2509 tem = (*hfun) (error_symbol, data); | |
| 2510 } | |
| 2511 else | |
| 2512 { | |
| 2513 Lisp_Object (*hfun) (Lisp_Object, Lisp_Object, Lisp_Object) = | |
| 2514 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object)) | |
| 2515 (get_opaque_ptr (handler_fun)); | |
| 2516 | |
| 2517 assert (NILP (XCDR (handler_data))); | |
| 2518 tem = (*hfun) (error_symbol, data, XCAR (handler_data)); | |
| 2519 } | |
| 2520 } | |
| 2521 else | |
| 2522 { | |
| 2523 tem = Fcons (error_symbol, data); | |
| 2524 if (NILP (handler_data)) | |
| 2525 tem = call1 (handler_fun, tem); | |
| 2526 else | |
| 2527 { | |
| 2528 /* (This code won't be used (for now?).) */ | |
| 2529 struct gcpro nngcpro1; | |
| 2530 Lisp_Object args[3]; | |
| 2531 NNGCPRO1 (args[0]); | |
| 2532 nngcpro1.nvars = 3; | |
| 2533 args[0] = handler_fun; | |
| 2534 args[1] = tem; | |
| 2535 args[2] = handler_data; | |
| 2536 nngcpro1.var = args; | |
| 2537 tem = Fapply (3, args); | |
| 2538 NNUNGCPRO; | |
| 2539 } | |
| 2540 } | |
| 428 | 2541 NUNGCPRO; |
| 2542 #if 0 | |
| 2543 if (!EQ (tem, Qsignal)) | |
| 2544 return return_from_signal (tem); | |
| 2545 #endif | |
| 2546 /* If handler didn't throw, try another handler */ | |
| 2547 Vcondition_handlers = all_handlers; | |
| 2548 } | |
| 2549 | |
| 2550 /* It's a condition-case handler */ | |
| 2551 | |
| 2552 /* t is used by handlers for all conditions, set up by C code. | |
| 2553 * debugger is not called even if debug_on_error */ | |
| 2554 else if (EQ (handler_data, Qt)) | |
| 2555 { | |
| 2556 UNGCPRO; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
2557 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
|
2558 0, Qnil, Qnil); |
| 428 | 2559 } |
| 2560 /* `error' is used similarly to the way `t' is used, but in | |
| 2561 addition it invokes the debugger if debug_on_error. | |
| 2562 This is normally used for the outer command-loop error | |
| 2563 handler. */ | |
| 2564 else if (EQ (handler_data, Qerror)) | |
| 2565 { | |
| 853 | 2566 Lisp_Object tem = signal_call_debugger (conditions, error_symbol, |
| 2567 data, | |
| 428 | 2568 outer_handlers, 0, |
| 2569 &stack_trace_displayed, | |
| 2570 &debugger_entered); | |
| 2571 | |
| 2572 UNGCPRO; | |
| 2573 if (!UNBOUNDP (tem)) | |
| 2574 return return_from_signal (tem); | |
| 2575 | |
| 853 | 2576 tem = Fcons (error_symbol, data); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
2577 throw_or_bomb_out (handlers, tem, 0, Qnil, Qnil); |
| 428 | 2578 } |
| 2579 else | |
| 2580 { | |
| 2581 /* handler established by real (Lisp) condition-case */ | |
| 2582 Lisp_Object h; | |
| 2583 | |
| 2584 for (h = handler_data; CONSP (h); h = Fcdr (h)) | |
| 2585 { | |
| 2586 Lisp_Object clause = Fcar (h); | |
| 2587 Lisp_Object tem = Fcar (clause); | |
| 2588 | |
| 2589 if (condition_type_p (tem, conditions)) | |
| 2590 { | |
| 853 | 2591 tem = signal_call_debugger (conditions, error_symbol, data, |
| 428 | 2592 outer_handlers, 1, |
| 2593 &stack_trace_displayed, | |
| 2594 &debugger_entered); | |
| 2595 UNGCPRO; | |
| 2596 if (!UNBOUNDP (tem)) | |
| 2597 return return_from_signal (tem); | |
| 2598 | |
| 2599 /* Doesn't return */ | |
| 853 | 2600 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
|
2601 throw_or_bomb_out (handlers, tem, 0, Qnil, Qnil); |
| 428 | 2602 } |
| 2603 } | |
| 2604 } | |
| 2605 } | |
| 2606 | |
| 2607 /* If no handler is present now, try to run the debugger, | |
| 2608 and if that fails, throw to top level. | |
| 2609 | |
| 2610 #### The only time that no handler is present is during | |
| 2611 temacs or perhaps very early in XEmacs. In both cases, | |
| 3025 | 2612 there is no `top-level' catch. (That's why the |
| 428 | 2613 "bomb-out" hack was added.) |
| 2614 | |
| 853 | 2615 [[#### Fix this horrifitude!]] |
| 2616 | |
| 2617 I don't think this is horrifitude, but just defensive coding. --ben */ | |
| 2618 | |
| 2619 signal_call_debugger (conditions, error_symbol, data, Qnil, 0, | |
| 428 | 2620 &stack_trace_displayed, |
| 2621 &debugger_entered); | |
| 2622 UNGCPRO; | |
| 853 | 2623 throw_or_bomb_out (Qtop_level, Qt, 1, error_symbol, |
| 2624 data); /* Doesn't return */ | |
| 2268 | 2625 RETURN_NOT_REACHED (Qnil); |
| 428 | 2626 } |
| 2627 | |
| 2628 /****************** Error functions class 1 ******************/ | |
| 2629 | |
| 2630 /* Class 1: General functions that signal an error. | |
| 2631 These functions take an error type and a list of associated error | |
| 2632 data. */ | |
| 2633 | |
| 853 | 2634 /* No signal_continuable_error_1(); it's called Fsignal(). */ |
| 428 | 2635 |
| 2636 /* Signal a non-continuable error. */ | |
| 2637 | |
| 2638 DOESNT_RETURN | |
| 563 | 2639 signal_error_1 (Lisp_Object sig, Lisp_Object data) |
| 428 | 2640 { |
| 2641 for (;;) | |
| 2642 Fsignal (sig, data); | |
| 2643 } | |
| 853 | 2644 |
| 2645 #ifdef ERROR_CHECK_CATCH | |
| 2646 | |
| 2647 void | |
| 2648 check_catchlist_sanity (void) | |
| 2649 { | |
| 2650 #if 0 | |
| 2651 /* vou me tomar no cu! i just masked andy's missing-unbind | |
| 2652 bug! */ | |
| 442 | 2653 struct catchtag *c; |
| 2654 int found_error_tag = 0; | |
| 2655 | |
| 2656 for (c = catchlist; c; c = c->next) | |
| 2657 { | |
| 2658 if (EQ (c->tag, Qunbound_suspended_errors_tag)) | |
| 2659 { | |
| 2660 found_error_tag = 1; | |
| 2661 break; | |
| 2662 } | |
| 2663 } | |
| 2664 | |
| 2665 assert (found_error_tag || NILP (Vcurrent_error_state)); | |
| 853 | 2666 #endif /* vou me tomar no cul */ |
| 2667 } | |
| 2668 | |
| 2669 void | |
| 2670 check_specbind_stack_sanity (void) | |
| 2671 { | |
| 2672 } | |
| 2673 | |
| 2674 #endif /* ERROR_CHECK_CATCH */ | |
| 428 | 2675 |
| 2676 /* Signal a non-continuable error or display a warning or do nothing, | |
| 2677 according to ERRB. CLASS is the class of warning and should | |
| 2678 refer to what sort of operation is being done (e.g. Qtoolbar, | |
| 2679 Qresource, etc.). */ | |
| 2680 | |
| 2681 void | |
| 1204 | 2682 maybe_signal_error_1 (Lisp_Object sig, Lisp_Object data, Lisp_Object class_, |
| 578 | 2683 Error_Behavior errb) |
| 428 | 2684 { |
| 2685 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2686 return; | |
| 793 | 2687 else if (ERRB_EQ (errb, ERROR_ME_DEBUG_WARN)) |
| 1204 | 2688 warn_when_safe_lispobj (class_, Qdebug, Fcons (sig, data)); |
| 428 | 2689 else if (ERRB_EQ (errb, ERROR_ME_WARN)) |
| 1204 | 2690 warn_when_safe_lispobj (class_, Qwarning, Fcons (sig, data)); |
| 428 | 2691 else |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2692 signal_error_1 (sig, data); |
| 428 | 2693 } |
| 2694 | |
| 2695 /* Signal a continuable error or display a warning or do nothing, | |
| 2696 according to ERRB. */ | |
| 2697 | |
| 2698 Lisp_Object | |
| 563 | 2699 maybe_signal_continuable_error_1 (Lisp_Object sig, Lisp_Object data, |
| 1204 | 2700 Lisp_Object class_, Error_Behavior errb) |
| 428 | 2701 { |
| 2702 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2703 return Qnil; | |
| 793 | 2704 else if (ERRB_EQ (errb, ERROR_ME_DEBUG_WARN)) |
| 2705 { | |
| 1204 | 2706 warn_when_safe_lispobj (class_, Qdebug, Fcons (sig, data)); |
| 793 | 2707 return Qnil; |
| 2708 } | |
| 428 | 2709 else if (ERRB_EQ (errb, ERROR_ME_WARN)) |
| 2710 { | |
| 1204 | 2711 warn_when_safe_lispobj (class_, Qwarning, Fcons (sig, data)); |
| 428 | 2712 return Qnil; |
| 2713 } | |
| 2714 else | |
| 2715 return Fsignal (sig, data); | |
| 2716 } | |
| 2717 | |
| 2718 | |
| 2719 /****************** Error functions class 2 ******************/ | |
| 2720 | |
| 563 | 2721 /* Class 2: Signal an error with a string and an associated object. |
| 2722 Normally these functions are used to attach one associated object, | |
| 2723 but to attach no objects, specify Qunbound for FROB, and for more | |
| 2724 than one object, make a list of the objects with Qunbound as the | |
| 2725 first element. (If you have specifically two objects to attach, | |
| 2726 consider using the function in class 3 below.) These functions | |
| 2727 signal an error of a specified type, whose data is one or more | |
| 2728 objects (usually two), a string the related Lisp object(s) | |
| 2729 specified as FROB. */ | |
| 2730 | |
| 2731 /* Out of REASON and FROB, return a list of elements suitable for passing | |
| 2732 to signal_error_1(). */ | |
| 2733 | |
| 2734 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2735 build_error_data (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 2736 { |
| 2737 if (EQ (frob, Qunbound)) | |
| 2738 frob = Qnil; | |
| 2739 else if (CONSP (frob) && EQ (XCAR (frob), Qunbound)) | |
| 2740 frob = XCDR (frob); | |
| 2741 else | |
| 2742 frob = list1 (frob); | |
| 2743 if (!reason) | |
| 2744 return frob; | |
| 2745 else | |
| 771 | 2746 return Fcons (build_msg_string (reason), frob); |
| 563 | 2747 } |
| 2748 | |
| 2749 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2750 signal_error (Lisp_Object type, const Ascbyte *reason, Lisp_Object frob) |
| 563 | 2751 { |
| 2752 signal_error_1 (type, build_error_data (reason, frob)); | |
| 2753 } | |
| 2754 | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2755 /* 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
|
2756 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
|
2757 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
|
2758 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
|
2759 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
|
2760 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
|
2761 |
| 563 | 2762 void |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2763 maybe_signal_error (Lisp_Object type, const Ascbyte *reason, |
| 1204 | 2764 Lisp_Object frob, Lisp_Object class_, |
| 578 | 2765 Error_Behavior errb) |
| 563 | 2766 { |
| 2767 /* Optimization: */ | |
| 2768 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2769 return; | |
| 1204 | 2770 maybe_signal_error_1 (type, build_error_data (reason, frob), class_, errb); |
| 563 | 2771 } |
| 2772 | |
| 2773 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2774 signal_continuable_error (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2775 Lisp_Object frob) |
| 2776 { | |
| 2777 return Fsignal (type, build_error_data (reason, frob)); | |
| 2778 } | |
| 2779 | |
| 2780 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2781 maybe_signal_continuable_error (Lisp_Object type, const Ascbyte *reason, |
| 1204 | 2782 Lisp_Object frob, Lisp_Object class_, |
| 578 | 2783 Error_Behavior errb) |
| 563 | 2784 { |
| 2785 /* Optimization: */ | |
| 2786 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2787 return Qnil; | |
| 2788 return maybe_signal_continuable_error_1 (type, | |
| 2789 build_error_data (reason, frob), | |
| 1204 | 2790 class_, errb); |
| 563 | 2791 } |
| 2792 | |
| 2793 | |
| 2794 /****************** Error functions class 3 ******************/ | |
| 2795 | |
| 2796 /* Class 3: Signal an error with a string and two associated objects. | |
| 2797 These functions signal an error of a specified type, whose data | |
| 2798 is three objects, a string and two related Lisp objects. | |
| 2799 (The equivalent could be accomplished using the class 2 functions, | |
| 2800 but these are more convenient in this particular case.) */ | |
| 2801 | |
| 2802 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2803 signal_error_2 (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2804 Lisp_Object frob0, Lisp_Object frob1) |
| 2805 { | |
| 771 | 2806 signal_error_1 (type, list3 (build_msg_string (reason), frob0, |
| 563 | 2807 frob1)); |
| 2808 } | |
| 2809 | |
| 2810 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2811 maybe_signal_error_2 (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2812 Lisp_Object frob0, Lisp_Object frob1, |
| 1204 | 2813 Lisp_Object class_, Error_Behavior errb) |
| 563 | 2814 { |
| 2815 /* Optimization: */ | |
| 2816 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2817 return; | |
| 771 | 2818 maybe_signal_error_1 (type, list3 (build_msg_string (reason), frob0, |
| 1204 | 2819 frob1), class_, errb); |
| 563 | 2820 } |
| 2821 | |
| 2822 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2823 signal_continuable_error_2 (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2824 Lisp_Object frob0, Lisp_Object frob1) |
| 2825 { | |
| 771 | 2826 return Fsignal (type, list3 (build_msg_string (reason), frob0, |
| 563 | 2827 frob1)); |
| 2828 } | |
| 2829 | |
| 2830 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2831 maybe_signal_continuable_error_2 (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2832 Lisp_Object frob0, Lisp_Object frob1, |
| 1204 | 2833 Lisp_Object class_, Error_Behavior errb) |
| 563 | 2834 { |
| 2835 /* Optimization: */ | |
| 2836 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2837 return Qnil; | |
| 2838 return maybe_signal_continuable_error_1 | |
| 771 | 2839 (type, list3 (build_msg_string (reason), frob0, frob1), |
| 1204 | 2840 class_, errb); |
| 563 | 2841 } |
| 2842 | |
| 2843 | |
| 2844 /****************** Error functions class 4 ******************/ | |
| 2845 | |
| 2846 /* Class 4: Printf-like functions that signal an error. | |
| 442 | 2847 These functions signal an error of a specified type, whose data |
| 428 | 2848 is a single string, created using the arguments. */ |
| 2849 | |
| 2850 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2851 signal_ferror (Lisp_Object type, const Ascbyte *fmt, ...) |
| 442 | 2852 { |
| 2853 Lisp_Object obj; | |
| 2854 va_list args; | |
| 2855 | |
| 2856 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2857 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 442 | 2858 va_end (args); |
| 2859 | |
| 2860 /* Fsignal GC-protects its args */ | |
| 563 | 2861 signal_error (type, 0, obj); |
| 442 | 2862 } |
| 2863 | |
| 2864 void | |
| 1204 | 2865 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
|
2866 const Ascbyte *fmt, ...) |
| 442 | 2867 { |
| 2868 Lisp_Object obj; | |
| 2869 va_list args; | |
| 2870 | |
| 2871 /* Optimization: */ | |
| 2872 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2873 return; | |
| 2874 | |
| 2875 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2876 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 442 | 2877 va_end (args); |
| 2878 | |
| 2879 /* Fsignal GC-protects its args */ | |
| 1204 | 2880 maybe_signal_error (type, 0, obj, class_, errb); |
| 442 | 2881 } |
| 2882 | |
| 2883 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2884 signal_continuable_ferror (Lisp_Object type, const Ascbyte *fmt, ...) |
| 428 | 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 */ | |
| 2894 return Fsignal (type, list1 (obj)); | |
| 2895 } | |
| 2896 | |
| 2897 Lisp_Object | |
| 1204 | 2898 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
|
2899 Error_Behavior errb, 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 Qnil; | |
| 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 return maybe_signal_continuable_error (type, 0, obj, class_, errb); |
| 442 | 2914 } |
| 2915 | |
| 2916 | |
| 2917 /****************** Error functions class 5 ******************/ | |
| 2918 | |
| 563 | 2919 /* Class 5: Printf-like functions that signal an error. |
| 442 | 2920 These functions signal an error of a specified type, whose data |
| 563 | 2921 is a one or more objects, a string (created using the arguments) |
| 2922 and additional Lisp objects specified in FROB. (The syntax of FROB | |
| 2923 is the same as for class 2.) | |
| 2924 | |
| 2925 There is no need for a class 6 because you can always attach 2 | |
| 2926 objects using class 5 (for FROB, specify a list with three | |
| 2927 elements, the first of which is Qunbound), and these functions are | |
| 2928 not commonly used. | |
| 2929 */ | |
| 442 | 2930 |
| 2931 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2932 signal_ferror_with_frob (Lisp_Object type, Lisp_Object frob, const Ascbyte *fmt, |
| 563 | 2933 ...) |
| 442 | 2934 { |
| 2935 Lisp_Object obj; | |
| 2936 va_list args; | |
| 2937 | |
| 2938 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2939 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 442 | 2940 va_end (args); |
| 2941 | |
| 2942 /* Fsignal GC-protects its args */ | |
| 563 | 2943 signal_error_1 (type, Fcons (obj, build_error_data (0, frob))); |
| 442 | 2944 } |
| 2945 | |
| 2946 void | |
| 563 | 2947 maybe_signal_ferror_with_frob (Lisp_Object type, Lisp_Object frob, |
| 1204 | 2948 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
|
2949 const Ascbyte *fmt, ...) |
| 442 | 2950 { |
| 2951 Lisp_Object obj; | |
| 2952 va_list args; | |
| 2953 | |
| 2954 /* Optimization: */ | |
| 2955 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2956 return; | |
| 2957 | |
| 2958 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2959 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 428 | 2960 va_end (args); |
| 2961 | |
| 2962 /* Fsignal GC-protects its args */ | |
| 1204 | 2963 maybe_signal_error_1 (type, Fcons (obj, build_error_data (0, frob)), class_, |
| 563 | 2964 errb); |
| 428 | 2965 } |
| 2966 | |
| 2967 Lisp_Object | |
| 563 | 2968 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
|
2969 const Ascbyte *fmt, ...) |
| 428 | 2970 { |
| 2971 Lisp_Object obj; | |
| 2972 va_list args; | |
| 2973 | |
| 2974 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2975 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 428 | 2976 va_end (args); |
| 2977 | |
| 2978 /* Fsignal GC-protects its args */ | |
| 563 | 2979 return Fsignal (type, Fcons (obj, build_error_data (0, frob))); |
| 428 | 2980 } |
| 2981 | |
| 2982 Lisp_Object | |
| 563 | 2983 maybe_signal_continuable_ferror_with_frob (Lisp_Object type, Lisp_Object frob, |
| 1204 | 2984 Lisp_Object class_, |
| 578 | 2985 Error_Behavior errb, |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2986 const Ascbyte *fmt, ...) |
| 428 | 2987 { |
| 2988 Lisp_Object obj; | |
| 2989 va_list args; | |
| 2990 | |
| 2991 /* Optimization: */ | |
| 2992 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2993 return Qnil; | |
| 2994 | |
| 2995 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2996 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 428 | 2997 va_end (args); |
| 2998 | |
| 2999 /* Fsignal GC-protects its args */ | |
| 563 | 3000 return maybe_signal_continuable_error_1 (type, |
| 3001 Fcons (obj, | |
| 3002 build_error_data (0, frob)), | |
| 1204 | 3003 class_, errb); |
| 428 | 3004 } |
| 3005 | |
| 3006 | |
| 3007 /* This is what the QUIT macro calls to signal a quit */ | |
| 3008 void | |
| 3009 signal_quit (void) | |
| 3010 { | |
| 853 | 3011 /* This function cannot GC. GC is prohibited because most callers do |
| 3012 not expect GC occurring in QUIT. Remove this if/when that gets fixed. | |
| 3013 --ben */ | |
| 3014 | |
| 3015 int count; | |
| 3016 | |
| 428 | 3017 if (EQ (Vquit_flag, Qcritical)) |
| 3018 debug_on_quit |= 2; /* set critical bit. */ | |
| 3019 Vquit_flag = Qnil; | |
| 853 | 3020 count = begin_gc_forbidden (); |
| 428 | 3021 /* note that this is continuable. */ |
| 3022 Fsignal (Qquit, Qnil); | |
| 853 | 3023 unbind_to (count); |
| 428 | 3024 } |
| 3025 | |
| 3026 | |
| 563 | 3027 /************************ convenience error functions ***********************/ |
| 3028 | |
| 436 | 3029 Lisp_Object |
| 428 | 3030 signal_void_function_error (Lisp_Object function) |
| 3031 { | |
| 436 | 3032 return Fsignal (Qvoid_function, list1 (function)); |
| 428 | 3033 } |
| 3034 | |
| 436 | 3035 Lisp_Object |
| 428 | 3036 signal_invalid_function_error (Lisp_Object function) |
| 3037 { | |
| 436 | 3038 return Fsignal (Qinvalid_function, list1 (function)); |
| 428 | 3039 } |
| 3040 | |
| 436 | 3041 Lisp_Object |
| 428 | 3042 signal_wrong_number_of_arguments_error (Lisp_Object function, int nargs) |
| 3043 { | |
| 436 | 3044 return Fsignal (Qwrong_number_of_arguments, |
| 3045 list2 (function, make_int (nargs))); | |
| 428 | 3046 } |
| 3047 | |
| 3048 /* Used in list traversal macros for efficiency. */ | |
| 436 | 3049 DOESNT_RETURN |
| 428 | 3050 signal_malformed_list_error (Lisp_Object list) |
| 3051 { | |
| 563 | 3052 signal_error (Qmalformed_list, 0, list); |
| 428 | 3053 } |
| 3054 | |
| 436 | 3055 DOESNT_RETURN |
| 428 | 3056 signal_malformed_property_list_error (Lisp_Object list) |
| 3057 { | |
| 563 | 3058 signal_error (Qmalformed_property_list, 0, list); |
| 428 | 3059 } |
| 3060 | |
| 436 | 3061 DOESNT_RETURN |
| 428 | 3062 signal_circular_list_error (Lisp_Object list) |
| 3063 { | |
| 563 | 3064 signal_error (Qcircular_list, 0, list); |
| 428 | 3065 } |
| 3066 | |
| 436 | 3067 DOESNT_RETURN |
| 428 | 3068 signal_circular_property_list_error (Lisp_Object list) |
| 3069 { | |
| 563 | 3070 signal_error (Qcircular_property_list, 0, list); |
| 428 | 3071 } |
| 442 | 3072 |
| 2267 | 3073 /* Called from within emacs_doprnt_1, so REASON is not formatted. */ |
| 442 | 3074 DOESNT_RETURN |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3075 syntax_error (const Ascbyte *reason, Lisp_Object frob) |
| 442 | 3076 { |
| 563 | 3077 signal_error (Qsyntax_error, reason, frob); |
| 442 | 3078 } |
| 3079 | |
| 3080 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3081 syntax_error_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2) |
| 442 | 3082 { |
| 563 | 3083 signal_error_2 (Qsyntax_error, reason, frob1, frob2); |
| 3084 } | |
| 3085 | |
| 3086 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3087 maybe_syntax_error (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3088 Lisp_Object class_, Error_Behavior errb) |
| 3089 { | |
| 3090 maybe_signal_error (Qsyntax_error, reason, frob, class_, errb); | |
| 563 | 3091 } |
| 3092 | |
| 3093 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3094 sferror (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3095 { |
| 3096 signal_error (Qstructure_formation_error, reason, frob); | |
| 3097 } | |
| 3098 | |
| 3099 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3100 sferror_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2) |
| 563 | 3101 { |
| 3102 signal_error_2 (Qstructure_formation_error, reason, frob1, frob2); | |
| 3103 } | |
| 3104 | |
| 3105 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3106 maybe_sferror (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3107 Lisp_Object class_, Error_Behavior errb) |
| 3108 { | |
| 3109 maybe_signal_error (Qstructure_formation_error, reason, frob, class_, errb); | |
| 442 | 3110 } |
| 3111 | |
| 3112 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3113 invalid_argument (const Ascbyte *reason, Lisp_Object frob) |
| 442 | 3114 { |
| 563 | 3115 signal_error (Qinvalid_argument, reason, frob); |
| 442 | 3116 } |
| 3117 | |
| 3118 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3119 invalid_argument_2 (const Ascbyte *reason, Lisp_Object frob1, |
| 609 | 3120 Lisp_Object frob2) |
| 442 | 3121 { |
| 563 | 3122 signal_error_2 (Qinvalid_argument, reason, frob1, frob2); |
| 3123 } | |
| 3124 | |
| 3125 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3126 maybe_invalid_argument (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3127 Lisp_Object class_, Error_Behavior errb) |
| 3128 { | |
| 3129 maybe_signal_error (Qinvalid_argument, reason, frob, class_, errb); | |
| 563 | 3130 } |
| 3131 | |
| 3132 DOESNT_RETURN | |
|
5084
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
3133 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
|
3134 { |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
3135 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
|
3136 } |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
3137 |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5050
diff
changeset
|
3138 DOESNT_RETURN |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3139 invalid_constant (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3140 { |
| 3141 signal_error (Qinvalid_constant, reason, frob); | |
| 3142 } | |
| 3143 | |
| 3144 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3145 invalid_constant_2 (const Ascbyte *reason, Lisp_Object frob1, |
| 609 | 3146 Lisp_Object frob2) |
| 563 | 3147 { |
| 3148 signal_error_2 (Qinvalid_constant, reason, frob1, frob2); | |
| 3149 } | |
| 3150 | |
| 3151 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3152 maybe_invalid_constant (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3153 Lisp_Object class_, Error_Behavior errb) |
| 3154 { | |
| 3155 maybe_signal_error (Qinvalid_constant, reason, frob, class_, errb); | |
| 442 | 3156 } |
| 3157 | |
| 3158 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3159 invalid_operation (const Ascbyte *reason, Lisp_Object frob) |
| 442 | 3160 { |
| 563 | 3161 signal_error (Qinvalid_operation, reason, frob); |
| 442 | 3162 } |
| 3163 | |
| 3164 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3165 invalid_operation_2 (const Ascbyte *reason, Lisp_Object frob1, |
| 609 | 3166 Lisp_Object frob2) |
| 442 | 3167 { |
| 563 | 3168 signal_error_2 (Qinvalid_operation, reason, frob1, frob2); |
| 3169 } | |
| 3170 | |
| 3171 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3172 maybe_invalid_operation (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3173 Lisp_Object class_, Error_Behavior errb) |
| 3174 { | |
| 3175 maybe_signal_error (Qinvalid_operation, reason, frob, class_, errb); | |
| 442 | 3176 } |
| 3177 | |
| 3178 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3179 invalid_change (const Ascbyte *reason, Lisp_Object frob) |
| 442 | 3180 { |
| 563 | 3181 signal_error (Qinvalid_change, reason, frob); |
| 442 | 3182 } |
| 3183 | |
| 3184 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3185 invalid_change_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2) |
| 442 | 3186 { |
| 563 | 3187 signal_error_2 (Qinvalid_change, reason, frob1, frob2); |
| 3188 } | |
| 3189 | |
| 3190 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3191 maybe_invalid_change (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3192 Lisp_Object class_, Error_Behavior errb) |
| 3193 { | |
| 3194 maybe_signal_error (Qinvalid_change, reason, frob, class_, errb); | |
| 563 | 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_state (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3199 { |
| 3200 signal_error (Qinvalid_state, reason, frob); | |
| 3201 } | |
| 3202 | |
| 3203 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3204 invalid_state_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2) |
| 563 | 3205 { |
| 3206 signal_error_2 (Qinvalid_state, reason, frob1, frob2); | |
| 3207 } | |
| 3208 | |
| 3209 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3210 maybe_invalid_state (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3211 Lisp_Object class_, Error_Behavior errb) |
| 3212 { | |
| 3213 maybe_signal_error (Qinvalid_state, reason, frob, class_, errb); | |
| 563 | 3214 } |
| 3215 | |
| 3216 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3217 wtaerror (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3218 { |
| 3219 signal_error (Qwrong_type_argument, reason, frob); | |
| 3220 } | |
| 3221 | |
| 3222 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3223 stack_overflow (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3224 { |
| 3225 signal_error (Qstack_overflow, reason, frob); | |
| 3226 } | |
| 3227 | |
| 3228 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3229 out_of_memory (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3230 { |
| 3231 signal_error (Qout_of_memory, reason, frob); | |
| 3232 } | |
| 3233 | |
| 428 | 3234 |
| 3235 /************************************************************************/ | |
| 3236 /* User commands */ | |
| 3237 /************************************************************************/ | |
| 3238 | |
| 3239 DEFUN ("commandp", Fcommandp, 1, 1, 0, /* | |
| 3240 Return t if FUNCTION makes provisions for interactive calling. | |
| 3241 This means it contains a description for how to read arguments to give it. | |
| 3242 The value is nil for an invalid function or a symbol with no function | |
| 3243 definition. | |
| 3244 | |
| 3245 Interactively callable functions include | |
| 3246 | |
| 3247 -- strings and vectors (treated as keyboard macros) | |
| 3248 -- lambda-expressions that contain a top-level call to `interactive' | |
| 3249 -- autoload definitions made by `autoload' with non-nil fourth argument | |
| 3250 (i.e. the interactive flag) | |
| 3251 -- compiled-function objects with a non-nil `compiled-function-interactive' | |
| 3252 value | |
| 3253 -- subrs (built-in functions) that are interactively callable | |
| 3254 | |
| 3255 Also, a symbol satisfies `commandp' if its function definition does so. | |
| 3256 */ | |
| 3257 (function)) | |
| 3258 { | |
| 3259 Lisp_Object fun = indirect_function (function, 0); | |
| 3260 | |
| 3261 if (COMPILED_FUNCTIONP (fun)) | |
| 3262 return XCOMPILED_FUNCTION (fun)->flags.interactivep ? Qt : Qnil; | |
| 3263 | |
| 3264 /* Lists may represent commands. */ | |
| 3265 if (CONSP (fun)) | |
| 3266 { | |
| 3267 Lisp_Object funcar = XCAR (fun); | |
| 3268 if (EQ (funcar, Qlambda)) | |
| 3269 return Fassq (Qinteractive, Fcdr (Fcdr (fun))); | |
| 3270 if (EQ (funcar, Qautoload)) | |
| 3271 return Fcar (Fcdr (Fcdr (Fcdr (fun)))); | |
| 3272 else | |
| 3273 return Qnil; | |
| 3274 } | |
| 3275 | |
| 3276 /* Emacs primitives are interactive if their DEFUN specifies an | |
| 3277 interactive spec. */ | |
| 3278 if (SUBRP (fun)) | |
| 3279 return XSUBR (fun)->prompt ? Qt : Qnil; | |
| 3280 | |
| 3281 /* Strings and vectors are keyboard macros. */ | |
| 3282 if (VECTORP (fun) || STRINGP (fun)) | |
| 3283 return Qt; | |
| 3284 | |
| 3285 /* Everything else (including Qunbound) is not a command. */ | |
| 3286 return Qnil; | |
| 3287 } | |
| 3288 | |
| 3289 DEFUN ("command-execute", Fcommand_execute, 1, 3, 0, /* | |
| 3290 Execute CMD as an editor command. | |
| 3291 CMD must be an object that satisfies the `commandp' predicate. | |
| 3292 Optional second arg RECORD-FLAG is as in `call-interactively'. | |
| 3293 The argument KEYS specifies the value to use instead of (this-command-keys) | |
| 3294 when reading the arguments. | |
| 3295 */ | |
| 444 | 3296 (cmd, record_flag, keys)) |
| 428 | 3297 { |
| 3298 /* This function can GC */ | |
| 3299 Lisp_Object prefixarg; | |
| 3300 Lisp_Object final = cmd; | |
| 4162 | 3301 PROFILE_DECLARE(); |
| 428 | 3302 struct console *con = XCONSOLE (Vselected_console); |
| 3303 | |
| 3304 prefixarg = con->prefix_arg; | |
| 3305 con->prefix_arg = Qnil; | |
| 3306 Vcurrent_prefix_arg = prefixarg; | |
| 3307 debug_on_next_call = 0; /* #### from FSFmacs; correct? */ | |
| 3308 | |
| 3309 if (SYMBOLP (cmd) && !NILP (Fget (cmd, Qdisabled, Qnil))) | |
| 733 | 3310 return run_hook (Qdisabled_command_hook); |
| 428 | 3311 |
| 3312 for (;;) | |
| 3313 { | |
| 3314 final = indirect_function (cmd, 1); | |
| 3315 if (CONSP (final) && EQ (Fcar (final), Qautoload)) | |
| 970 | 3316 { |
| 3317 /* do_autoload GCPROs both arguments */ | |
| 3318 do_autoload (final, cmd); | |
| 3319 } | |
| 428 | 3320 else |
| 3321 break; | |
| 3322 } | |
| 3323 | |
| 3324 if (CONSP (final) || SUBRP (final) || COMPILED_FUNCTIONP (final)) | |
| 3325 { | |
| 3326 backtrace.function = &Qcall_interactively; | |
| 3327 backtrace.args = &cmd; | |
| 3328 backtrace.nargs = 1; | |
| 3329 backtrace.evalargs = 0; | |
| 1292 | 3330 backtrace.pdlcount = specpdl_depth (); |
| 428 | 3331 backtrace.debug_on_exit = 0; |
| 1292 | 3332 backtrace.function_being_called = 0; |
| 428 | 3333 PUSH_BACKTRACE (backtrace); |
| 3334 | |
| 1292 | 3335 PROFILE_ENTER_FUNCTION (); |
| 444 | 3336 final = Fcall_interactively (cmd, record_flag, keys); |
| 1292 | 3337 PROFILE_EXIT_FUNCTION (); |
| 428 | 3338 |
| 3339 POP_BACKTRACE (backtrace); | |
| 3340 return final; | |
| 3341 } | |
| 3342 else if (STRINGP (final) || VECTORP (final)) | |
| 3343 { | |
| 3344 return Fexecute_kbd_macro (final, prefixarg); | |
| 3345 } | |
| 3346 else | |
| 3347 { | |
| 3348 Fsignal (Qwrong_type_argument, | |
| 3349 Fcons (Qcommandp, | |
| 3350 (EQ (cmd, final) | |
| 3351 ? list1 (cmd) | |
| 3352 : list2 (cmd, final)))); | |
| 3353 return Qnil; | |
| 3354 } | |
| 3355 } | |
| 3356 | |
| 3357 DEFUN ("interactive-p", Finteractive_p, 0, 0, 0, /* | |
| 3358 Return t if function in which this appears was called interactively. | |
| 3359 This means that the function was called with call-interactively (which | |
| 3360 includes being called as the binding of a key) | |
| 3361 and input is currently coming from the keyboard (not in keyboard macro). | |
| 3362 */ | |
| 3363 ()) | |
| 3364 { | |
| 3365 REGISTER struct backtrace *btp; | |
| 3366 REGISTER Lisp_Object fun; | |
| 3367 | |
| 3368 if (!INTERACTIVE) | |
| 3369 return Qnil; | |
| 3370 | |
| 3371 /* Unless the object was compiled, skip the frame of interactive-p itself | |
| 3372 (if interpreted) or the frame of byte-code (if called from a compiled | |
| 3373 function). Note that *btp->function may be a symbol pointing at a | |
| 3374 compiled function. */ | |
| 3375 btp = backtrace_list; | |
| 3376 | |
| 3377 #if 0 /* FSFmacs */ | |
| 3378 | |
| 3379 /* #### FSFmacs does the following instead. I can't figure | |
| 3380 out which one is more correct. */ | |
| 3381 /* If this isn't a byte-compiled function, there may be a frame at | |
| 3382 the top for Finteractive_p itself. If so, skip it. */ | |
| 3383 fun = Findirect_function (*btp->function); | |
| 3384 if (SUBRP (fun) && XSUBR (fun) == &Sinteractive_p) | |
| 3385 btp = btp->next; | |
| 3386 | |
| 3387 /* If we're running an Emacs 18-style byte-compiled function, there | |
| 3388 may be a frame for Fbyte_code. Now, given the strictest | |
| 3389 definition, this function isn't really being called | |
| 3390 interactively, but because that's the way Emacs 18 always builds | |
| 3391 byte-compiled functions, we'll accept it for now. */ | |
| 3392 if (EQ (*btp->function, Qbyte_code)) | |
| 3393 btp = btp->next; | |
| 3394 | |
| 3395 /* 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
|
3396 looking at several frames for special operators. Skip past them. */ |
| 428 | 3397 while (btp && |
| 3398 btp->nargs == UNEVALLED) | |
| 3399 btp = btp->next; | |
| 3400 | |
| 3401 #else | |
| 3402 | |
| 3403 if (! (COMPILED_FUNCTIONP (Findirect_function (*btp->function)))) | |
| 3404 btp = btp->next; | |
| 3405 for (; | |
| 3406 btp && (btp->nargs == UNEVALLED | |
| 3407 || EQ (*btp->function, Qbyte_code)); | |
| 3408 btp = btp->next) | |
| 3409 {} | |
| 3410 /* btp now points at the frame of the innermost function | |
| 3411 that DOES eval its args. | |
| 3412 If it is a built-in function (such as load or eval-region) | |
| 3413 return nil. */ | |
| 3414 /* Beats me why this is necessary, but it is */ | |
| 3415 if (btp && EQ (*btp->function, Qcall_interactively)) | |
| 3416 return Qt; | |
| 3417 | |
| 3418 #endif | |
| 3419 | |
| 3420 fun = Findirect_function (*btp->function); | |
| 3421 if (SUBRP (fun)) | |
| 3422 return Qnil; | |
| 3423 /* btp points to the frame of a Lisp function that called interactive-p. | |
| 3424 Return t if that function was called interactively. */ | |
| 3425 if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively)) | |
| 3426 return Qt; | |
| 3427 return Qnil; | |
| 3428 } | |
| 3429 | |
| 3430 | |
| 3431 /************************************************************************/ | |
| 3432 /* Autoloading */ | |
| 3433 /************************************************************************/ | |
| 3434 | |
| 3435 DEFUN ("autoload", Fautoload, 2, 5, 0, /* | |
| 444 | 3436 Define FUNCTION to autoload from FILENAME. |
| 3437 FUNCTION is a symbol; FILENAME is a file name string to pass to `load'. | |
| 3438 The remaining optional arguments provide additional info about the | |
| 3439 real definition. | |
| 3440 DOCSTRING is documentation for FUNCTION. | |
| 3441 INTERACTIVE, if non-nil, says FUNCTION can be called interactively. | |
| 3442 TYPE indicates the type of the object: | |
| 428 | 3443 nil or omitted says FUNCTION is a function, |
| 3444 `keymap' says FUNCTION is really a keymap, and | |
| 3445 `macro' or t says FUNCTION is really a macro. | |
| 444 | 3446 If FUNCTION already has a non-void function definition that is not an |
| 3447 autoload object, this function does nothing and returns nil. | |
| 428 | 3448 */ |
| 444 | 3449 (function, filename, docstring, interactive, type)) |
| 428 | 3450 { |
| 3451 /* This function can GC */ | |
| 3452 CHECK_SYMBOL (function); | |
| 444 | 3453 CHECK_STRING (filename); |
| 428 | 3454 |
| 3455 /* If function is defined and not as an autoload, don't override */ | |
| 3456 { | |
| 3457 Lisp_Object f = XSYMBOL (function)->function; | |
| 3458 if (!UNBOUNDP (f) && !(CONSP (f) && EQ (XCAR (f), Qautoload))) | |
| 3459 return Qnil; | |
| 3460 } | |
| 3461 | |
| 3462 if (purify_flag) | |
| 3463 { | |
| 3464 /* Attempt to avoid consing identical (string=) pure strings. */ | |
| 444 | 3465 filename = Fsymbol_name (Fintern (filename, Qnil)); |
| 428 | 3466 } |
| 440 | 3467 |
| 444 | 3468 return Ffset (function, Fcons (Qautoload, list4 (filename, |
| 428 | 3469 docstring, |
| 3470 interactive, | |
| 3471 type))); | |
| 3472 } | |
| 3473 | |
| 3474 Lisp_Object | |
| 3475 un_autoload (Lisp_Object oldqueue) | |
| 3476 { | |
| 3477 /* This function can GC */ | |
| 3478 REGISTER Lisp_Object queue, first, second; | |
| 3479 | |
| 3480 /* Queue to unwind is current value of Vautoload_queue. | |
| 3481 oldqueue is the shadowed value to leave in Vautoload_queue. */ | |
| 3482 queue = Vautoload_queue; | |
| 3483 Vautoload_queue = oldqueue; | |
| 3484 while (CONSP (queue)) | |
| 3485 { | |
| 3486 first = XCAR (queue); | |
| 3487 second = Fcdr (first); | |
| 3488 first = Fcar (first); | |
| 3489 if (NILP (second)) | |
| 3490 Vfeatures = first; | |
| 3491 else | |
| 3492 Ffset (first, second); | |
| 3493 queue = Fcdr (queue); | |
| 3494 } | |
| 3495 return Qnil; | |
| 3496 } | |
| 3497 | |
| 970 | 3498 /* do_autoload GCPROs both arguments */ |
| 428 | 3499 void |
| 3500 do_autoload (Lisp_Object fundef, | |
| 3501 Lisp_Object funname) | |
| 3502 { | |
| 3503 /* This function can GC */ | |
| 3504 int speccount = specpdl_depth(); | |
| 3505 Lisp_Object fun = funname; | |
| 970 | 3506 struct gcpro gcpro1, gcpro2, gcpro3; |
| 428 | 3507 |
| 3508 CHECK_SYMBOL (funname); | |
| 970 | 3509 GCPRO3 (fundef, funname, fun); |
| 428 | 3510 |
| 3511 /* Value saved here is to be restored into Vautoload_queue */ | |
| 3512 record_unwind_protect (un_autoload, Vautoload_queue); | |
| 3513 Vautoload_queue = Qt; | |
| 3514 call4 (Qload, Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, Qnil); | |
| 3515 | |
| 3516 { | |
| 3517 Lisp_Object queue; | |
| 3518 | |
| 3519 /* Save the old autoloads, in case we ever do an unload. */ | |
| 3520 for (queue = Vautoload_queue; CONSP (queue); queue = XCDR (queue)) | |
| 3521 { | |
| 3522 Lisp_Object first = XCAR (queue); | |
| 3523 Lisp_Object second = Fcdr (first); | |
| 3524 | |
| 3525 first = Fcar (first); | |
| 3526 | |
| 3527 /* Note: This test is subtle. The cdr of an autoload-queue entry | |
| 3528 may be an atom if the autoload entry was generated by a defalias | |
| 3529 or fset. */ | |
| 3530 if (CONSP (second)) | |
| 3531 Fput (first, Qautoload, (XCDR (second))); | |
| 3532 } | |
| 3533 } | |
| 3534 | |
| 3535 /* Once loading finishes, don't undo it. */ | |
| 3536 Vautoload_queue = Qt; | |
| 771 | 3537 unbind_to (speccount); |
| 428 | 3538 |
| 3539 fun = indirect_function (fun, 0); | |
| 3540 | |
| 3541 #if 0 /* FSFmacs */ | |
| 3542 if (!NILP (Fequal (fun, fundef))) | |
| 3543 #else | |
| 3544 if (UNBOUNDP (fun) | |
| 3545 || (CONSP (fun) | |
| 3546 && EQ (XCAR (fun), Qautoload))) | |
| 3547 #endif | |
| 563 | 3548 invalid_state ("Autoloading failed to define function", funname); |
| 428 | 3549 UNGCPRO; |
| 3550 } | |
| 3551 | |
| 3552 | |
| 3553 /************************************************************************/ | |
| 3554 /* eval, funcall, apply */ | |
| 3555 /************************************************************************/ | |
| 3556 | |
| 814 | 3557 /* NOTE: If you are hearing the endless complaint that function calls in |
| 3558 elisp are extremely slow, it just isn't true any more! The stuff below | |
| 3559 -- in particular, the calling of subrs and compiled functions, the most | |
| 3560 common cases -- has been highly optimized. There isn't a whole lot left | |
| 3561 to do to squeeze more speed out except by switching to lexical | |
| 3562 variables, which would eliminate the specbind loop. (But the real gain | |
| 3563 from lexical variables would come from better optimization -- with | |
| 3564 dynamic binding, you have the constant problem that any function call | |
| 3565 that you haven't explicitly proven to be side-effect-free might | |
| 3566 potentially side effect your local variables, which makes optimization | |
| 3567 extremely difficult when there are function calls anywhere in a chunk of | |
| 3568 code to be optimized. Even worse, you don't know that *your* local | |
| 3569 variables aren't side-effecting an outer function's local variables, so | |
| 3570 it's impossible to optimize away almost *any* variable assignment.) */ | |
| 3571 | |
| 428 | 3572 static Lisp_Object funcall_lambda (Lisp_Object fun, |
| 442 | 3573 int nargs, Lisp_Object args[]); |
| 428 | 3574 static int in_warnings; |
| 3575 | |
| 3576 | |
| 814 | 3577 void handle_compiled_function_with_and_rest (Lisp_Compiled_Function *f, |
| 3578 int nargs, | |
| 3579 Lisp_Object args[]); | |
| 3580 | |
| 3581 /* The theory behind making this a separate function is to shrink | |
| 3582 funcall_compiled_function() so as to increase the likelihood of a cache | |
| 3583 hit in the L1 cache -- &rest processing is not going to be fast anyway. | |
| 3584 The idea is the same as with execute_rare_opcode() in bytecode.c. We | |
| 3585 make this non-static to ensure the compiler doesn't inline it. */ | |
| 3586 | |
| 3587 void | |
| 3588 handle_compiled_function_with_and_rest (Lisp_Compiled_Function *f, int nargs, | |
| 3589 Lisp_Object args[]) | |
| 3590 { | |
| 3591 REGISTER int i = 0; | |
| 3592 int max_non_rest_args = f->args_in_array - 1; | |
| 3593 int bindargs = min (nargs, max_non_rest_args); | |
| 3594 | |
| 3595 for (i = 0; i < bindargs; i++) | |
| 3092 | 3596 #ifdef NEW_GC |
| 3597 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3598 args[i]); | |
| 3599 #else /* not NEW_GC */ | |
| 814 | 3600 SPECBIND_FAST_UNSAFE (f->args[i], args[i]); |
| 3092 | 3601 #endif /* not NEW_GC */ |
| 814 | 3602 for (i = bindargs; i < max_non_rest_args; i++) |
| 3092 | 3603 #ifdef NEW_GC |
| 3604 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3605 Qnil); | |
| 3606 #else /* not NEW_GC */ | |
| 814 | 3607 SPECBIND_FAST_UNSAFE (f->args[i], Qnil); |
| 3092 | 3608 #endif /* not NEW_GC */ |
| 3609 #ifdef NEW_GC | |
| 3610 SPECBIND_FAST_UNSAFE | |
| 3611 (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[max_non_rest_args], | |
| 3612 nargs > max_non_rest_args ? | |
| 3613 Flist (nargs - max_non_rest_args, &args[max_non_rest_args]) : | |
| 3614 Qnil); | |
| 3615 #else /* not NEW_GC */ | |
| 814 | 3616 SPECBIND_FAST_UNSAFE |
| 3617 (f->args[max_non_rest_args], | |
| 3618 nargs > max_non_rest_args ? | |
| 3619 Flist (nargs - max_non_rest_args, &args[max_non_rest_args]) : | |
| 3620 Qnil); | |
| 3092 | 3621 #endif /* not NEW_GC */ |
| 814 | 3622 } |
| 3623 | |
| 3624 /* Apply compiled-function object FUN to the NARGS evaluated arguments | |
| 3625 in ARGS, and return the result of evaluation. */ | |
| 3626 inline static Lisp_Object | |
| 3627 funcall_compiled_function (Lisp_Object fun, int nargs, Lisp_Object args[]) | |
| 3628 { | |
| 3629 /* This function can GC */ | |
| 3630 int speccount = specpdl_depth(); | |
| 3631 REGISTER int i = 0; | |
| 3632 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun); | |
| 3633 | |
| 3634 if (!OPAQUEP (f->instructions)) | |
| 3635 /* Lazily munge the instructions into a more efficient form */ | |
| 3636 optimize_compiled_function (fun); | |
| 3637 | |
| 3638 /* optimize_compiled_function() guaranteed that f->specpdl_depth is | |
| 3639 the required space on the specbinding stack for binding the args | |
| 3640 and local variables of fun. So just reserve it once. */ | |
| 3641 SPECPDL_RESERVE (f->specpdl_depth); | |
| 3642 | |
| 3643 if (nargs == f->max_args) /* Optimize for the common case -- no unspecified | |
| 3644 optional arguments. */ | |
| 3645 { | |
| 3646 #if 1 | |
| 3647 for (i = 0; i < nargs; i++) | |
| 3092 | 3648 #ifdef NEW_GC |
| 3649 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3650 args[i]); | |
| 3651 #else /* not NEW_GC */ | |
| 814 | 3652 SPECBIND_FAST_UNSAFE (f->args[i], args[i]); |
| 3092 | 3653 #endif /* not NEW_GC */ |
| 814 | 3654 #else |
| 3655 /* Here's an alternate way to write the loop that tries to further | |
| 3656 optimize funcalls for functions with few arguments by partially | |
| 3657 unrolling the loop. It's not clear whether this is a win since it | |
| 3658 increases the size of the function and the possibility of L1 cache | |
| 3659 misses. (Microsoft VC++ 6 with /O2 /G5 generates 0x90 == 144 bytes | |
| 3660 per SPECBIND_FAST_UNSAFE().) Tests under VC++ 6, running the byte | |
| 3661 compiler repeatedly and looking at the total time, show very | |
| 3662 little difference between the simple loop above, the unrolled code | |
| 3663 below, and a "partly unrolled" solution with only cases 0-2 below | |
| 3664 instead of 0-4. Therefore, I'm keeping it at the simple loop | |
| 3665 because it's smaller. */ | |
| 3666 switch (nargs) | |
| 3667 { | |
| 3668 default: | |
| 3669 for (i = nargs - 1; i >= 4; i--) | |
| 3670 SPECBIND_FAST_UNSAFE (f->args[i], args[i]); | |
| 3671 case 4: SPECBIND_FAST_UNSAFE (f->args[3], args[3]); | |
| 3672 case 3: SPECBIND_FAST_UNSAFE (f->args[2], args[2]); | |
| 3673 case 2: SPECBIND_FAST_UNSAFE (f->args[1], args[1]); | |
| 3674 case 1: SPECBIND_FAST_UNSAFE (f->args[0], args[0]); | |
| 3675 case 0: break; | |
| 3676 } | |
| 3677 #endif | |
| 3678 } | |
| 3679 else if (nargs < f->min_args) | |
| 3680 goto wrong_number_of_arguments; | |
| 3681 else if (nargs < f->max_args) | |
| 3682 { | |
| 3683 for (i = 0; i < nargs; i++) | |
| 3092 | 3684 #ifdef NEW_GC |
| 3685 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3686 args[i]); | |
| 3687 #else /* not NEW_GC */ | |
| 814 | 3688 SPECBIND_FAST_UNSAFE (f->args[i], args[i]); |
| 3092 | 3689 #endif /* not NEW_GC */ |
| 814 | 3690 for (i = nargs; i < f->max_args; i++) |
| 3092 | 3691 #ifdef NEW_GC |
| 3692 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3693 Qnil); | |
| 3694 #else /* not NEW_GC */ | |
| 814 | 3695 SPECBIND_FAST_UNSAFE (f->args[i], Qnil); |
| 3092 | 3696 #endif /* not NEW_GC */ |
| 814 | 3697 } |
| 3698 else if (f->max_args == MANY) | |
| 3699 handle_compiled_function_with_and_rest (f, nargs, args); | |
| 3700 else | |
| 3701 { | |
| 3702 wrong_number_of_arguments: | |
| 3703 /* The actual printed compiled_function object is incomprehensible. | |
| 3704 Check the backtrace to see if we can get a more meaningful symbol. */ | |
| 3705 if (EQ (fun, indirect_function (*backtrace_list->function, 0))) | |
| 3706 fun = *backtrace_list->function; | |
| 3707 return Fsignal (Qwrong_number_of_arguments, | |
| 3708 list2 (fun, make_int (nargs))); | |
| 3709 } | |
| 3710 | |
| 3711 { | |
| 3712 Lisp_Object value = | |
| 3713 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
|
3714 #ifdef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4905
diff
changeset
|
3715 XOPAQUE_SIZE (f->instructions) / |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4905
diff
changeset
|
3716 sizeof (Opbyte), |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4905
diff
changeset
|
3717 #endif |
| 814 | 3718 f->stack_depth, |
| 3719 XVECTOR_DATA (f->constants)); | |
| 3720 | |
| 3721 /* The attempt to optimize this by only unbinding variables failed | |
| 3722 because using buffer-local variables as function parameters | |
| 3723 leads to specpdl_ptr->func != 0 */ | |
| 3724 /* UNBIND_TO_GCPRO_VARIABLES_ONLY (speccount, value); */ | |
| 3725 UNBIND_TO_GCPRO (speccount, value); | |
| 3726 return value; | |
| 3727 } | |
| 3728 } | |
| 3729 | |
| 428 | 3730 DEFUN ("eval", Feval, 1, 1, 0, /* |
| 3731 Evaluate FORM and return its value. | |
| 3732 */ | |
| 3733 (form)) | |
| 3734 { | |
| 3735 /* This function can GC */ | |
| 3736 Lisp_Object fun, val, original_fun, original_args; | |
| 3737 int nargs; | |
| 4162 | 3738 PROFILE_DECLARE(); |
| 428 | 3739 |
| 1318 | 3740 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS |
| 3741 check_proper_critical_section_lisp_protection (); | |
| 3742 #endif | |
| 3743 | |
| 3989 | 3744 if (!CONSP (form)) |
| 3745 { | |
| 3746 if (SYMBOLP (form)) | |
| 3747 { | |
| 3748 return Fsymbol_value (form); | |
| 3749 } | |
| 3750 | |
| 3751 return form; | |
| 3752 } | |
| 3753 | |
| 428 | 3754 /* I think this is a pretty safe place to call Lisp code, don't you? */ |
| 853 | 3755 while (!in_warnings && !NILP (Vpending_warnings) |
| 3756 /* well, perhaps not so safe after all! */ | |
| 3757 && !(inhibit_flags & INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY)) | |
| 428 | 3758 { |
| 3759 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; | |
| 1204 | 3760 Lisp_Object this_warning_cons, this_warning, class_, level, messij; |
| 853 | 3761 int speccount = internal_bind_int (&in_warnings, 1); |
| 3762 | |
| 428 | 3763 this_warning_cons = Vpending_warnings; |
| 3764 this_warning = XCAR (this_warning_cons); | |
| 3765 /* in case an error occurs in the warn function, at least | |
| 3766 it won't happen infinitely */ | |
| 3767 Vpending_warnings = XCDR (Vpending_warnings); | |
| 853 | 3768 free_cons (this_warning_cons); |
| 1204 | 3769 class_ = XCAR (this_warning); |
| 428 | 3770 level = XCAR (XCDR (this_warning)); |
| 3771 messij = XCAR (XCDR (XCDR (this_warning))); | |
| 3772 free_list (this_warning); | |
| 3773 | |
| 3774 if (NILP (Vpending_warnings)) | |
| 3775 Vpending_warnings_tail = Qnil; /* perhaps not strictly necessary, | |
| 3776 but safer */ | |
| 3777 | |
| 1204 | 3778 GCPRO4 (form, class_, level, messij); |
| 428 | 3779 if (!STRINGP (messij)) |
| 3780 messij = Fprin1_to_string (messij, Qnil); | |
| 1204 | 3781 call3 (Qdisplay_warning, class_, messij, level); |
| 428 | 3782 UNGCPRO; |
| 771 | 3783 unbind_to (speccount); |
| 428 | 3784 } |
| 3785 | |
| 3786 QUIT; | |
| 814 | 3787 if (need_to_garbage_collect) |
| 428 | 3788 { |
| 3789 struct gcpro gcpro1; | |
| 3790 GCPRO1 (form); | |
| 3092 | 3791 #ifdef NEW_GC |
| 3792 gc_incremental (); | |
| 3793 #else /* not NEW_GC */ | |
| 428 | 3794 garbage_collect_1 (); |
| 3092 | 3795 #endif /* not NEW_GC */ |
| 428 | 3796 UNGCPRO; |
| 3797 } | |
| 3798 | |
| 3799 if (++lisp_eval_depth > max_lisp_eval_depth) | |
| 3800 { | |
| 3801 if (max_lisp_eval_depth < 100) | |
| 3802 max_lisp_eval_depth = 100; | |
| 3803 if (lisp_eval_depth > max_lisp_eval_depth) | |
| 563 | 3804 stack_overflow ("Lisp nesting exceeds `max-lisp-eval-depth'", |
| 3805 Qunbound); | |
| 428 | 3806 } |
| 3807 | |
| 3808 /* We guaranteed CONSP (form) above */ | |
| 3809 original_fun = XCAR (form); | |
| 3810 original_args = XCDR (form); | |
| 3811 | |
| 3812 GET_EXTERNAL_LIST_LENGTH (original_args, nargs); | |
| 3813 | |
| 3814 backtrace.pdlcount = specpdl_depth(); | |
| 3815 backtrace.function = &original_fun; /* This also protects them from gc */ | |
| 3816 backtrace.args = &original_args; | |
| 3817 backtrace.nargs = UNEVALLED; | |
| 3818 backtrace.evalargs = 1; | |
| 3819 backtrace.debug_on_exit = 0; | |
| 1292 | 3820 backtrace.function_being_called = 0; |
| 428 | 3821 PUSH_BACKTRACE (backtrace); |
| 3822 | |
| 3823 if (debug_on_next_call) | |
| 3824 do_debug_on_call (Qt); | |
| 3825 | |
| 3826 /* At this point, only original_fun and original_args | |
| 3827 have values that will be used below. */ | |
| 3828 retry: | |
| 3989 | 3829 /* Optimise for no indirection. */ |
| 3830 fun = original_fun; | |
| 3831 if (SYMBOLP (fun) && !EQ (fun, Qunbound) | |
| 3832 && (fun = XSYMBOL (fun)->function, SYMBOLP (fun))) | |
| 3833 { | |
| 3834 fun = indirect_function(original_fun, 1); | |
| 3835 } | |
| 428 | 3836 |
| 3837 if (SUBRP (fun)) | |
| 3838 { | |
| 3839 Lisp_Subr *subr = XSUBR (fun); | |
| 3840 int max_args = subr->max_args; | |
| 3841 | |
| 3842 if (nargs < subr->min_args) | |
| 3843 goto wrong_number_of_arguments; | |
| 3844 | |
| 3845 if (max_args == UNEVALLED) /* Optimize for the common case */ | |
| 3846 { | |
| 3847 backtrace.evalargs = 0; | |
| 1292 | 3848 PROFILE_ENTER_FUNCTION (); |
| 428 | 3849 val = (((Lisp_Object (*) (Lisp_Object)) subr_function (subr)) |
| 3850 (original_args)); | |
| 1292 | 3851 PROFILE_EXIT_FUNCTION (); |
| 428 | 3852 } |
| 3853 else if (nargs <= max_args) | |
| 3854 { | |
| 3855 struct gcpro gcpro1; | |
| 3856 Lisp_Object args[SUBR_MAX_ARGS]; | |
| 3857 REGISTER Lisp_Object *p = args; | |
| 3858 | |
| 3859 GCPRO1 (args[0]); | |
| 3860 gcpro1.nvars = 0; | |
| 3861 | |
| 3862 { | |
| 3863 LIST_LOOP_2 (arg, original_args) | |
| 3864 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
3865 *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); |
| 428 | 3866 gcpro1.nvars++; |
| 3867 } | |
| 3868 } | |
| 3869 | |
| 3870 /* &optional args default to nil. */ | |
| 3871 while (p - args < max_args) | |
| 3872 *p++ = Qnil; | |
| 3873 | |
| 3874 backtrace.args = args; | |
| 3875 backtrace.nargs = nargs; | |
| 3876 | |
| 1292 | 3877 PROFILE_ENTER_FUNCTION (); |
| 428 | 3878 FUNCALL_SUBR (val, subr, args, max_args); |
| 1292 | 3879 PROFILE_EXIT_FUNCTION (); |
| 428 | 3880 |
| 3881 UNGCPRO; | |
| 3882 } | |
| 3883 else if (max_args == MANY) | |
| 3884 { | |
| 3885 /* Pass a vector of evaluated arguments */ | |
| 3886 struct gcpro gcpro1; | |
| 3887 Lisp_Object *args = alloca_array (Lisp_Object, nargs); | |
| 3888 REGISTER Lisp_Object *p = args; | |
| 3889 | |
| 3890 GCPRO1 (args[0]); | |
| 3891 gcpro1.nvars = 0; | |
| 3892 | |
| 3893 { | |
| 3894 LIST_LOOP_2 (arg, original_args) | |
| 3895 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
3896 *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); |
| 428 | 3897 gcpro1.nvars++; |
| 3898 } | |
| 3899 } | |
| 3900 | |
| 3901 backtrace.args = args; | |
| 3902 backtrace.nargs = nargs; | |
| 3903 | |
| 1292 | 3904 PROFILE_ENTER_FUNCTION (); |
| 428 | 3905 val = (((Lisp_Object (*) (int, Lisp_Object *)) subr_function (subr)) |
| 3906 (nargs, args)); | |
| 1292 | 3907 PROFILE_EXIT_FUNCTION (); |
| 428 | 3908 |
| 3909 UNGCPRO; | |
| 3910 } | |
| 3911 else | |
| 3912 { | |
| 3913 wrong_number_of_arguments: | |
| 440 | 3914 val = signal_wrong_number_of_arguments_error (original_fun, nargs); |
| 428 | 3915 } |
| 3916 } | |
| 3917 else if (COMPILED_FUNCTIONP (fun)) | |
| 3918 { | |
| 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 backtrace.evalargs = 0; | |
| 3937 | |
| 1292 | 3938 PROFILE_ENTER_FUNCTION (); |
| 428 | 3939 val = funcall_compiled_function (fun, nargs, args); |
| 1292 | 3940 PROFILE_EXIT_FUNCTION (); |
| 428 | 3941 |
| 3942 /* Do the debug-on-exit now, while args is still GCPROed. */ | |
| 3943 if (backtrace.debug_on_exit) | |
| 3944 val = do_debug_on_exit (val); | |
| 3945 /* Don't do it again when we return to eval. */ | |
| 3946 backtrace.debug_on_exit = 0; | |
| 3947 | |
| 3948 UNGCPRO; | |
| 3949 } | |
| 3950 else if (CONSP (fun)) | |
| 3951 { | |
| 3952 Lisp_Object funcar = XCAR (fun); | |
| 3953 | |
| 3954 if (EQ (funcar, Qautoload)) | |
| 3955 { | |
| 970 | 3956 /* do_autoload GCPROs both arguments */ |
| 428 | 3957 do_autoload (fun, original_fun); |
| 3958 goto retry; | |
| 3959 } | |
| 3960 else if (EQ (funcar, Qmacro)) | |
| 3961 { | |
| 1292 | 3962 PROFILE_ENTER_FUNCTION (); |
| 428 | 3963 val = Feval (apply1 (XCDR (fun), original_args)); |
| 1292 | 3964 PROFILE_EXIT_FUNCTION (); |
| 428 | 3965 } |
| 3966 else if (EQ (funcar, Qlambda)) | |
| 3967 { | |
| 3968 struct gcpro gcpro1; | |
| 3969 Lisp_Object *args = alloca_array (Lisp_Object, nargs); | |
| 3970 REGISTER Lisp_Object *p = args; | |
| 3971 | |
| 3972 GCPRO1 (args[0]); | |
| 3973 gcpro1.nvars = 0; | |
| 3974 | |
| 3975 { | |
| 3976 LIST_LOOP_2 (arg, original_args) | |
| 3977 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
3978 *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); |
| 428 | 3979 gcpro1.nvars++; |
| 3980 } | |
| 3981 } | |
| 3982 | |
| 3983 UNGCPRO; | |
| 3984 | |
| 3985 backtrace.args = args; /* this also GCPROs `args' */ | |
| 3986 backtrace.nargs = nargs; | |
| 3987 backtrace.evalargs = 0; | |
| 3988 | |
| 1292 | 3989 PROFILE_ENTER_FUNCTION (); |
| 428 | 3990 val = funcall_lambda (fun, nargs, args); |
| 1292 | 3991 PROFILE_EXIT_FUNCTION (); |
| 428 | 3992 |
| 3993 /* Do the debug-on-exit now, while args is still GCPROed. */ | |
| 3994 if (backtrace.debug_on_exit) | |
| 3995 val = do_debug_on_exit (val); | |
| 3996 /* Don't do it again when we return to eval. */ | |
| 3997 backtrace.debug_on_exit = 0; | |
| 3998 } | |
| 3999 else | |
| 4000 { | |
| 4001 goto invalid_function; | |
| 4002 } | |
| 4003 } | |
| 4104 | 4004 else if (UNBOUNDP (fun)) |
| 4005 { | |
| 4006 val = signal_void_function_error (original_fun); | |
| 4007 } | |
| 4008 else /* ! (SUBRP (fun) || COMPILED_FUNCTIONP (fun) || CONSP (fun) | |
| 4009 UNBOUNDP (fun)) */ | |
| 428 | 4010 { |
| 4011 invalid_function: | |
| 436 | 4012 val = signal_invalid_function_error (fun); |
| 428 | 4013 } |
| 4014 | |
| 4015 lisp_eval_depth--; | |
| 4016 if (backtrace.debug_on_exit) | |
| 4017 val = do_debug_on_exit (val); | |
| 4018 POP_BACKTRACE (backtrace); | |
| 4019 return val; | |
| 4020 } | |
| 4021 | |
| 4022 | |
| 1111 | 4023 |
| 4024 static void | |
| 4025 run_post_gc_hook (void) | |
| 4026 { | |
| 4027 Lisp_Object args[2]; | |
| 4028 | |
| 4029 args[0] = Qpost_gc_hook; | |
| 4030 args[1] = Fcons (Fcons (Qfinalize_list, zap_finalize_list ()), Qnil); | |
| 4031 | |
| 4032 run_hook_with_args_trapping_problems | |
| 1333 | 4033 (Qgarbage_collecting, 2, args, RUN_HOOKS_TO_COMPLETION, |
| 1111 | 4034 INHIBIT_QUIT | NO_INHIBIT_ERRORS); |
| 4035 } | |
| 4036 | |
| 428 | 4037 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
|
4038 Call FUNCTION as a function, passing the remaining arguments to it. |
| 428 | 4039 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
|
4040 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
4041 arguments: (FUNCTION &rest ARGS) |
| 428 | 4042 */ |
| 4043 (int nargs, Lisp_Object *args)) | |
| 4044 { | |
| 4045 /* This function can GC */ | |
| 4046 Lisp_Object fun; | |
| 4047 Lisp_Object val; | |
| 4162 | 4048 PROFILE_DECLARE(); |
| 428 | 4049 int fun_nargs = nargs - 1; |
| 4050 Lisp_Object *fun_args = args + 1; | |
| 4051 | |
| 1318 | 4052 /* QUIT will check for proper redisplay wrapping */ |
| 4053 | |
| 428 | 4054 QUIT; |
| 851 | 4055 |
| 4056 if (funcall_allocation_flag) | |
| 4057 { | |
| 4058 if (need_to_garbage_collect) | |
| 4059 /* Callers should gcpro lexpr args */ | |
| 3092 | 4060 #ifdef NEW_GC |
| 4061 gc_incremental (); | |
| 4062 #else /* not NEW_GC */ | |
| 851 | 4063 garbage_collect_1 (); |
| 3092 | 4064 #endif /* not NEW_GC */ |
| 851 | 4065 if (need_to_check_c_alloca) |
| 4066 { | |
| 4067 if (++funcall_alloca_count >= MAX_FUNCALLS_BETWEEN_ALLOCA_CLEANUP) | |
| 4068 { | |
| 4069 xemacs_c_alloca (0); | |
| 4070 funcall_alloca_count = 0; | |
| 4071 } | |
| 4072 } | |
| 887 | 4073 if (need_to_signal_post_gc) |
| 4074 { | |
| 4075 need_to_signal_post_gc = 0; | |
| 1111 | 4076 recompute_funcall_allocation_flag (); |
| 3263 | 4077 #ifdef NEW_GC |
| 4078 run_finalizers (); | |
| 4079 #endif /* NEW_GC */ | |
| 1111 | 4080 run_post_gc_hook (); |
| 887 | 4081 } |
| 851 | 4082 } |
| 428 | 4083 |
| 4084 if (++lisp_eval_depth > max_lisp_eval_depth) | |
| 4085 { | |
| 4086 if (max_lisp_eval_depth < 100) | |
| 4087 max_lisp_eval_depth = 100; | |
| 4088 if (lisp_eval_depth > max_lisp_eval_depth) | |
| 563 | 4089 stack_overflow ("Lisp nesting exceeds `max-lisp-eval-depth'", |
| 4090 Qunbound); | |
| 428 | 4091 } |
| 4092 | |
| 1292 | 4093 backtrace.pdlcount = specpdl_depth (); |
| 428 | 4094 backtrace.function = &args[0]; |
| 4095 backtrace.args = fun_args; | |
| 4096 backtrace.nargs = fun_nargs; | |
| 4097 backtrace.evalargs = 0; | |
| 4098 backtrace.debug_on_exit = 0; | |
| 1292 | 4099 backtrace.function_being_called = 0; |
| 428 | 4100 PUSH_BACKTRACE (backtrace); |
| 4101 | |
| 4102 if (debug_on_next_call) | |
| 4103 do_debug_on_call (Qlambda); | |
| 4104 | |
| 4105 retry: | |
| 4106 | |
| 4107 fun = args[0]; | |
| 4108 | |
| 4109 /* We could call indirect_function directly, but profiling shows | |
| 4110 this is worth optimizing by partially unrolling the loop. */ | |
| 4111 if (SYMBOLP (fun)) | |
| 4112 { | |
| 4113 fun = XSYMBOL (fun)->function; | |
| 4114 if (SYMBOLP (fun)) | |
| 4115 { | |
| 4116 fun = XSYMBOL (fun)->function; | |
| 4117 if (SYMBOLP (fun)) | |
| 4118 fun = indirect_function (fun, 1); | |
| 4119 } | |
| 4120 } | |
| 4121 | |
| 4122 if (SUBRP (fun)) | |
| 4123 { | |
| 4124 Lisp_Subr *subr = XSUBR (fun); | |
| 4125 int max_args = subr->max_args; | |
| 4126 Lisp_Object spacious_args[SUBR_MAX_ARGS]; | |
| 4127 | |
| 4128 if (fun_nargs == max_args) /* Optimize for the common case */ | |
| 4129 { | |
| 4130 funcall_subr: | |
| 1292 | 4131 PROFILE_ENTER_FUNCTION (); |
| 428 | 4132 FUNCALL_SUBR (val, subr, fun_args, max_args); |
| 1292 | 4133 PROFILE_EXIT_FUNCTION (); |
| 428 | 4134 } |
| 436 | 4135 else if (fun_nargs < subr->min_args) |
| 4136 { | |
| 4137 goto wrong_number_of_arguments; | |
| 4138 } | |
| 428 | 4139 else if (fun_nargs < max_args) |
| 4140 { | |
| 4141 Lisp_Object *p = spacious_args; | |
| 4142 | |
| 4143 /* Default optionals to nil */ | |
| 4144 while (fun_nargs--) | |
| 4145 *p++ = *fun_args++; | |
| 4146 while (p - spacious_args < max_args) | |
| 4147 *p++ = Qnil; | |
| 4148 | |
| 4149 fun_args = spacious_args; | |
| 4150 goto funcall_subr; | |
| 4151 } | |
| 4152 else if (max_args == MANY) | |
| 4153 { | |
| 1292 | 4154 PROFILE_ENTER_FUNCTION (); |
| 436 | 4155 val = SUBR_FUNCTION (subr, MANY) (fun_nargs, fun_args); |
| 1292 | 4156 PROFILE_EXIT_FUNCTION (); |
| 428 | 4157 } |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
4158 else if (max_args == UNEVALLED) /* Can't funcall a special operator */ |
| 428 | 4159 { |
|
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
|
4160 |
|
18c0b5909d16
Use keywords in structure syntax; new #define, NEED_TO_HANDLE_21_4_CODE 1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5207
diff
changeset
|
4161 #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
|
4162 /* Ugh, ugh, ugh. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4163 if (EQ (fun, XSYMBOL_FUNCTION (Qthrow))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4164 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4165 args[0] = Qobsolete_throw; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4166 goto retry; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4167 } |
|
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
|
4168 #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
|
4169 |
| 428 | 4170 goto invalid_function; |
| 4171 } | |
| 4172 else | |
| 4173 { | |
| 4174 wrong_number_of_arguments: | |
| 436 | 4175 val = signal_wrong_number_of_arguments_error (fun, fun_nargs); |
| 428 | 4176 } |
| 4177 } | |
| 4178 else if (COMPILED_FUNCTIONP (fun)) | |
| 4179 { | |
| 1292 | 4180 PROFILE_ENTER_FUNCTION (); |
| 428 | 4181 val = funcall_compiled_function (fun, fun_nargs, fun_args); |
| 1292 | 4182 PROFILE_EXIT_FUNCTION (); |
| 428 | 4183 } |
| 4184 else if (CONSP (fun)) | |
| 4185 { | |
| 4186 Lisp_Object funcar = XCAR (fun); | |
| 4187 | |
| 4188 if (EQ (funcar, Qlambda)) | |
| 4189 { | |
| 1292 | 4190 PROFILE_ENTER_FUNCTION (); |
| 428 | 4191 val = funcall_lambda (fun, fun_nargs, fun_args); |
| 1292 | 4192 PROFILE_EXIT_FUNCTION (); |
| 428 | 4193 } |
| 4194 else if (EQ (funcar, Qautoload)) | |
| 4195 { | |
| 970 | 4196 /* do_autoload GCPROs both arguments */ |
| 428 | 4197 do_autoload (fun, args[0]); |
| 4198 goto retry; | |
| 4199 } | |
| 4200 else /* Can't funcall a macro */ | |
| 4201 { | |
| 4202 goto invalid_function; | |
| 4203 } | |
| 4204 } | |
| 4205 else if (UNBOUNDP (fun)) | |
| 4206 { | |
| 436 | 4207 val = signal_void_function_error (args[0]); |
| 428 | 4208 } |
| 4209 else | |
| 4210 { | |
| 4211 invalid_function: | |
| 436 | 4212 val = signal_invalid_function_error (fun); |
| 428 | 4213 } |
| 4214 | |
| 4215 lisp_eval_depth--; | |
| 4216 if (backtrace.debug_on_exit) | |
| 4217 val = do_debug_on_exit (val); | |
| 4218 POP_BACKTRACE (backtrace); | |
| 4219 return val; | |
| 4220 } | |
| 4221 | |
| 4222 DEFUN ("functionp", Ffunctionp, 1, 1, 0, /* | |
| 4223 Return t if OBJECT can be called as a function, else nil. | |
| 4224 A function is an object that can be applied to arguments, | |
| 4225 using for example `funcall' or `apply'. | |
| 4226 */ | |
| 4227 (object)) | |
| 4228 { | |
| 4229 if (SYMBOLP (object)) | |
| 4230 object = indirect_function (object, 0); | |
| 4231 | |
|
4795
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4744
diff
changeset
|
4232 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
|
4233 || (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
|
4234 && (XSUBR (object)->max_args != UNEVALLED))) |
| 919 | 4235 return Qt; |
| 4236 if (CONSP (object)) | |
| 4237 { | |
| 4238 Lisp_Object car = XCAR (object); | |
| 4239 if (EQ (car, Qlambda)) | |
| 4240 return Qt; | |
| 4241 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
|
4242 && 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
|
4243 (Fcdr_safe (XCDR (object))))))) |
| 919 | 4244 return Qt; |
| 4245 } | |
| 4246 return Qnil; | |
| 428 | 4247 } |
| 4248 | |
| 4249 static Lisp_Object | |
| 4250 function_argcount (Lisp_Object function, int function_min_args_p) | |
| 4251 { | |
| 4252 Lisp_Object orig_function = function; | |
| 4253 Lisp_Object arglist; | |
| 4254 | |
| 4255 retry: | |
| 4256 | |
| 4257 if (SYMBOLP (function)) | |
| 4258 function = indirect_function (function, 1); | |
| 4259 | |
| 4260 if (SUBRP (function)) | |
| 4261 { | |
| 442 | 4262 /* Using return with the ?: operator tickles a DEC CC compiler bug. */ |
| 4263 if (function_min_args_p) | |
| 4264 return Fsubr_min_args (function); | |
| 4265 else | |
| 4266 return Fsubr_max_args (function); | |
| 428 | 4267 } |
| 4268 else if (COMPILED_FUNCTIONP (function)) | |
| 4269 { | |
| 814 | 4270 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (function); |
| 4271 | |
| 1737 | 4272 if (!OPAQUEP (f->instructions)) |
| 4273 /* Lazily munge the instructions into a more efficient form */ | |
| 4274 /* Needed to set max_args */ | |
| 4275 optimize_compiled_function (function); | |
| 4276 | |
| 814 | 4277 if (function_min_args_p) |
| 4278 return make_int (f->min_args); | |
| 4279 else if (f->max_args == MANY) | |
| 4280 return Qnil; | |
| 4281 else | |
| 4282 return make_int (f->max_args); | |
| 428 | 4283 } |
| 4284 else if (CONSP (function)) | |
| 4285 { | |
| 4286 Lisp_Object funcar = XCAR (function); | |
| 4287 | |
| 4288 if (EQ (funcar, Qmacro)) | |
| 4289 { | |
| 4290 function = XCDR (function); | |
| 4291 goto retry; | |
| 4292 } | |
| 4293 else if (EQ (funcar, Qautoload)) | |
| 4294 { | |
| 970 | 4295 /* do_autoload GCPROs both arguments */ |
| 428 | 4296 do_autoload (function, orig_function); |
| 442 | 4297 function = orig_function; |
| 428 | 4298 goto retry; |
| 4299 } | |
| 4300 else if (EQ (funcar, Qlambda)) | |
| 4301 { | |
| 4302 arglist = Fcar (XCDR (function)); | |
| 4303 } | |
| 4304 else | |
| 4305 { | |
| 4306 goto invalid_function; | |
| 4307 } | |
| 4308 } | |
| 4309 else | |
| 4310 { | |
| 4311 invalid_function: | |
| 442 | 4312 return signal_invalid_function_error (orig_function); |
| 428 | 4313 } |
| 4314 | |
| 4315 { | |
| 4316 int argcount = 0; | |
| 4317 | |
| 4318 EXTERNAL_LIST_LOOP_2 (arg, arglist) | |
| 4319 { | |
| 4320 if (EQ (arg, Qand_optional)) | |
| 4321 { | |
| 4322 if (function_min_args_p) | |
| 4323 break; | |
| 4324 } | |
| 4325 else if (EQ (arg, Qand_rest)) | |
| 4326 { | |
| 4327 if (function_min_args_p) | |
| 4328 break; | |
| 4329 else | |
| 4330 return Qnil; | |
| 4331 } | |
| 4332 else | |
| 4333 { | |
| 4334 argcount++; | |
| 4335 } | |
| 4336 } | |
| 4337 | |
| 4338 return make_int (argcount); | |
| 4339 } | |
| 4340 } | |
| 4341 | |
| 4342 DEFUN ("function-min-args", Ffunction_min_args, 1, 1, 0, /* | |
| 617 | 4343 Return the minimum number of arguments a function may be called with. |
| 428 | 4344 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
|
4345 any special operator, or any macro. |
| 853 | 4346 |
| 4347 To check if a function can be called with a specified number of | |
| 4348 arguments, use `function-allows-args'. | |
| 428 | 4349 */ |
| 4350 (function)) | |
| 4351 { | |
| 4352 return function_argcount (function, 1); | |
| 4353 } | |
| 4354 | |
| 4355 DEFUN ("function-max-args", Ffunction_max_args, 1, 1, 0, /* | |
| 617 | 4356 Return the maximum number of arguments a function may be called with. |
| 428 | 4357 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
|
4358 any special operator, or any macro. |
| 428 | 4359 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
|
4360 a built-in special operator, nil is returned. |
| 853 | 4361 |
| 4362 To check if a function can be called with a specified number of | |
| 4363 arguments, use `function-allows-args'. | |
| 428 | 4364 */ |
| 4365 (function)) | |
| 4366 { | |
| 4367 return function_argcount (function, 0); | |
| 4368 } | |
| 4369 | |
| 4370 | |
| 4371 DEFUN ("apply", Fapply, 2, MANY, 0, /* | |
| 4372 Call FUNCTION with the remaining args, using the last arg as a list of args. | |
| 4373 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
|
4374 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
4375 arguments: (FUNCTION &rest ARGS) |
| 428 | 4376 */ |
| 4377 (int nargs, Lisp_Object *args)) | |
| 4378 { | |
| 4379 /* This function can GC */ | |
| 4380 Lisp_Object fun = args[0]; | |
| 4381 Lisp_Object spread_arg = args [nargs - 1]; | |
| 4382 int numargs; | |
| 4383 int funcall_nargs; | |
| 4384 | |
| 4385 GET_EXTERNAL_LIST_LENGTH (spread_arg, numargs); | |
| 4386 | |
| 4387 if (numargs == 0) | |
| 4388 /* (apply foo 0 1 '()) */ | |
| 4389 return Ffuncall (nargs - 1, args); | |
| 4390 else if (numargs == 1) | |
| 4391 { | |
| 4392 /* (apply foo 0 1 '(2)) */ | |
| 4393 args [nargs - 1] = XCAR (spread_arg); | |
| 4394 return Ffuncall (nargs, args); | |
| 4395 } | |
| 4396 | |
| 4397 /* -1 for function, -1 for spread arg */ | |
| 4398 numargs = nargs - 2 + numargs; | |
| 4399 /* +1 for function */ | |
| 4400 funcall_nargs = 1 + numargs; | |
| 4401 | |
| 4402 if (SYMBOLP (fun)) | |
| 4403 fun = indirect_function (fun, 0); | |
| 4404 | |
| 4405 if (SUBRP (fun)) | |
| 4406 { | |
| 4407 Lisp_Subr *subr = XSUBR (fun); | |
| 4408 int max_args = subr->max_args; | |
| 4409 | |
| 4410 if (numargs < subr->min_args | |
| 4411 || (max_args >= 0 && max_args < numargs)) | |
| 4412 { | |
| 4413 /* Let funcall get the error */ | |
| 4414 } | |
| 4415 else if (max_args > numargs) | |
| 4416 { | |
| 4417 /* Avoid having funcall cons up yet another new vector of arguments | |
| 4418 by explicitly supplying nil's for optional values */ | |
| 4419 funcall_nargs += (max_args - numargs); | |
| 4420 } | |
| 4421 } | |
| 4422 else if (UNBOUNDP (fun)) | |
| 4423 { | |
| 4424 /* Let funcall get the error */ | |
| 4425 fun = args[0]; | |
| 4426 } | |
| 4427 | |
| 4428 { | |
| 4429 REGISTER int i; | |
| 4430 Lisp_Object *funcall_args = alloca_array (Lisp_Object, funcall_nargs); | |
| 4431 struct gcpro gcpro1; | |
| 4432 | |
| 4433 GCPRO1 (*funcall_args); | |
| 4434 gcpro1.nvars = funcall_nargs; | |
| 4435 | |
| 4436 /* Copy in the unspread args */ | |
| 4437 memcpy (funcall_args, args, (nargs - 1) * sizeof (Lisp_Object)); | |
| 4438 /* Spread the last arg we got. Its first element goes in | |
| 4439 the slot that it used to occupy, hence this value of I. */ | |
| 4440 for (i = nargs - 1; | |
| 4441 !NILP (spread_arg); /* i < 1 + numargs */ | |
| 4442 i++, spread_arg = XCDR (spread_arg)) | |
| 4443 { | |
| 4444 funcall_args [i] = XCAR (spread_arg); | |
| 4445 } | |
| 4446 /* Supply nil for optional args (to subrs) */ | |
| 4447 for (; i < funcall_nargs; i++) | |
| 4448 funcall_args[i] = Qnil; | |
| 4449 | |
| 4450 | |
| 4451 RETURN_UNGCPRO (Ffuncall (funcall_nargs, funcall_args)); | |
| 4452 } | |
| 4453 } | |
| 4454 | |
| 4455 /* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and | |
| 4456 return the result of evaluation. */ | |
| 4457 | |
| 4458 static Lisp_Object | |
| 4459 funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object args[]) | |
| 4460 { | |
| 4461 /* This function can GC */ | |
| 442 | 4462 Lisp_Object arglist, body, tail; |
| 428 | 4463 int speccount = specpdl_depth(); |
| 4464 REGISTER int i = 0; | |
| 4465 | |
| 4466 tail = XCDR (fun); | |
| 4467 | |
| 4468 if (!CONSP (tail)) | |
| 4469 goto invalid_function; | |
| 4470 | |
| 4471 arglist = XCAR (tail); | |
| 4472 body = XCDR (tail); | |
| 4473 | |
| 4474 { | |
| 4475 int optional = 0, rest = 0; | |
| 4476 | |
| 442 | 4477 EXTERNAL_LIST_LOOP_2 (symbol, arglist) |
| 428 | 4478 { |
| 4479 if (!SYMBOLP (symbol)) | |
| 4480 goto invalid_function; | |
| 4481 if (EQ (symbol, Qand_rest)) | |
| 4482 rest = 1; | |
| 4483 else if (EQ (symbol, Qand_optional)) | |
| 4484 optional = 1; | |
| 4485 else if (rest) | |
| 4486 { | |
| 4487 specbind (symbol, Flist (nargs - i, &args[i])); | |
| 4488 i = nargs; | |
| 4489 } | |
| 4490 else if (i < nargs) | |
| 4491 specbind (symbol, args[i++]); | |
| 4492 else if (!optional) | |
| 4493 goto wrong_number_of_arguments; | |
| 4494 else | |
| 4495 specbind (symbol, Qnil); | |
| 4496 } | |
| 4497 } | |
| 4498 | |
| 4499 if (i < nargs) | |
| 4500 goto wrong_number_of_arguments; | |
| 4501 | |
| 771 | 4502 return unbind_to_1 (speccount, Fprogn (body)); |
| 428 | 4503 |
| 4504 wrong_number_of_arguments: | |
| 436 | 4505 return signal_wrong_number_of_arguments_error (fun, nargs); |
| 428 | 4506 |
| 4507 invalid_function: | |
| 436 | 4508 return signal_invalid_function_error (fun); |
| 428 | 4509 } |
| 4510 | |
| 4511 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4512 /* Multiple values. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4513 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4514 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
|
4515 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4516 -- 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
|
4517 -- 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
|
4518 one multiple value. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4519 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4520 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
|
4521 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4522 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
|
4523 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
|
4524 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
|
4525 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
|
4526 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
|
4527 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
|
4528 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
|
4529 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
|
4530 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4531 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
|
4532 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
|
4533 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
|
4534 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
|
4535 #'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
|
4536 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
|
4537 be saved and returned. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4538 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4539 (#'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
|
4540 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
|
4541 #'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
|
4542 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
|
4543 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
|
4544 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4545 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
|
4546 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
|
4547 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
|
4548 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
|
4549 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4550 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
|
4551 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
|
4552 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
|
4553 on being printed from within GDB. |
|
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 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
|
4556 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
|
4557 #'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
|
4558 #'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
|
4559 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
|
4560 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
|
4561 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
|
4562 *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
|
4563 not have this penalty. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4564 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4565 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
|
4566 admirable clarity by CLTL2: |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4567 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4568 "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
|
4569 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
|
4570 used." |
|
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 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
|
4573 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
|
4574 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
|
4575 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
|
4576 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4577 static Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4578 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
|
4579 Elemcount first_desired, Elemcount upper_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4580 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4581 Bytecount sizem; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4582 struct multiple_value *mv; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4583 Elemcount i, allocated_count; |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
4584 Lisp_Object mvobj; |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4585 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4586 assert (count != 1); |
|
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 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
|
4589 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4590 /* 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
|
4591 working out allocated_count: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4592 first_desired = 1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4593 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4594 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4595 if (first_desired >= count) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4596 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4597 /* 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
|
4598 allocate for the first argument. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4599 allocated_count = 1; |
|
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 else |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4602 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4603 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
|
4604 - first_desired); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4605 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4606 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4607 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
|
4608 Lisp_Object, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4609 contents, allocated_count); |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
4610 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
|
4611 mv = XMULTIPLE_VALUE (mvobj); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4612 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4613 mv->count = count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4614 mv->first_desired = first_desired; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4615 mv->allocated_count = allocated_count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4616 mv->contents[0] = first_value; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4617 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4618 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
|
4619 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4620 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
|
4621 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4622 |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
4623 return mvobj; |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4624 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4625 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4626 void |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4627 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
|
4628 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4629 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
|
4630 Elemcount first_desired = mv->first_desired; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4631 Elemcount allocated_count = mv->allocated_count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4632 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4633 if (index != 0 && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4634 (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
|
4635 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4636 args_out_of_range (make_int (first_desired), |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4637 make_int (first_desired + allocated_count)); |
|
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 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
|
4641 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4642 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4643 Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4644 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
|
4645 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4646 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
|
4647 Elemcount first_desired = mv->first_desired; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4648 Elemcount allocated_count = mv->allocated_count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4649 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4650 if (index != 0 && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4651 (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
|
4652 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4653 args_out_of_range (make_int (first_desired), |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4654 make_int (first_desired + allocated_count)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4655 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4656 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4657 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
|
4658 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4659 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4660 static void |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4661 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
|
4662 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4663 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
|
4664 Elemcount first_desired = mv->first_desired; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4665 Elemcount allocated_count = mv->allocated_count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4666 Elemcount count = mv->count, index; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4667 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4668 if (print_readably) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4669 { |
|
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
|
4670 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
|
4671 LISP_OBJECT_UID (obj)); |
|
4677
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 |
|
5086
47bcef7b0b44
Print multiple values with #<INTERNAL OBJECT (XEmacs bug?) ...>, too
Aidan Kehoe <kehoea@parhasard.net>
parents:
5084
diff
changeset
|
4674 write_fmt_string (printcharfun, |
|
47bcef7b0b44
Print multiple values with #<INTERNAL OBJECT (XEmacs bug?) ...>, too
Aidan Kehoe <kehoea@parhasard.net>
parents:
5084
diff
changeset
|
4675 "#<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
|
4676 " data (", count); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4677 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4678 for (index = 0; index < count;) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4679 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4680 if (index != 0 && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4681 (index < first_desired || |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4682 index >= (first_desired + (allocated_count - 1)))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4683 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4684 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
|
4685 index); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4686 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4687 else |
|
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 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
|
4690 printcharfun, escapeflag); |
|
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 ++index; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4694 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4695 if (count > 1 && index < count) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4696 { |
|
5086
47bcef7b0b44
Print multiple values with #<INTERNAL OBJECT (XEmacs bug?) ...>, too
Aidan Kehoe <kehoea@parhasard.net>
parents:
5084
diff
changeset
|
4697 write_ascstring (printcharfun, " "); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4698 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4699 } |
|
5086
47bcef7b0b44
Print multiple values with #<INTERNAL OBJECT (XEmacs bug?) ...>, too
Aidan Kehoe <kehoea@parhasard.net>
parents:
5084
diff
changeset
|
4700 |
|
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
|
4701 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
|
4702 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4703 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4704 static Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4705 mark_multiple_value (Lisp_Object obj) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4706 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4707 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
|
4708 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
|
4709 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4710 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
|
4711 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4712 mark_object (mv->contents[index]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4713 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4714 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4715 return Qnil; |
|
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 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4718 static Bytecount |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
4719 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
|
4720 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4721 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
|
4722 Lisp_Object, contents, |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
4723 XMULTIPLE_VALUE (obj)->allocated_count); |
|
4677
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 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
|
4727 { 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
|
4728 { 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
|
4729 { 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
|
4730 { 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
|
4731 XD_INDIRECT (1, 0) }, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4732 { XD_END } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4733 }; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4734 |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
4735 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
|
4736 mark_multiple_value, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4737 print_multiple_value, 0, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4738 0, /* No equal method. */ |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4739 0, /* No hash method. */ |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4740 multiple_value_description, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4741 size_multiple_value, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4742 struct multiple_value); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4743 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4744 /* 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
|
4745 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
|
4746 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
|
4747 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
|
4748 int |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4749 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
|
4750 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4751 int result = specpdl_depth(); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4752 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4753 if (!(upper > first)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4754 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4755 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
|
4756 " FIRST-DESIRED-MULTIPLE-VALUE", Qunbound); |
|
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 if (upper > Vmultiple_values_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4760 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4761 args_out_of_range (make_int (upper), make_int (Vmultiple_values_limit)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4762 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4763 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4764 /* 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
|
4765 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
|
4766 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
|
4767 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
|
4768 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4769 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
|
4770 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
|
4771 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4772 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
|
4773 if (0 == first) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4774 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4775 first = 1; |
|
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 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4778 if (0 == first_desired_multiple_value |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4779 || first < first_desired_multiple_value) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4780 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4781 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
|
4782 } |
|
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 if (upper > multiple_value_current_limit) |
|
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 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
|
4787 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4788 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4789 return result; |
|
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 Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4793 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
|
4794 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4795 /* The argument order here is horrible: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4796 int i, speccount = XINT (args[3]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4797 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
|
4798 struct gcpro gcpro1, gcpro2; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4799 Lisp_Object apply_args[2]; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4800 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4801 GCPRO2 (head, result); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4802 list_offset = head; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4803 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4804 assert (!(MULTIPLE_VALUEP (args[0]))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4805 CHECK_FUNCTION (args[0]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4806 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4807 /* 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
|
4808 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
|
4809 #'multiple-value-list-internal needs them): */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4810 for (i = 4; i < nargs; ++i) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4811 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4812 result = args[i]; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4813 if (MULTIPLE_VALUEP (result)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4814 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4815 Lisp_Object val; |
|
5016
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
4816 Elemcount j, count = XMULTIPLE_VALUE_COUNT (result); |
|
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
4817 |
|
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
4818 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
|
4819 { |
|
5016
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
4820 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
|
4821 assert (!UNBOUNDP (val)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4822 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4823 XSETCDR (list_offset, Fcons (val, Qnil)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4824 list_offset = XCDR (list_offset); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4825 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4826 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4827 else |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4828 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4829 XSETCDR (list_offset, Fcons (result, Qnil)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4830 list_offset = XCDR (list_offset); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4831 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4832 } |
|
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 apply_args [0] = XCAR (head); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4835 apply_args [1] = XCDR (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 unbind_to (speccount); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4838 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4839 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
|
4840 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4841 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4842 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
|
4843 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
|
4844 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4845 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
|
4846 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
|
4847 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
|
4848 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
|
4849 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4850 arguments: (FUNCTION &rest FORMS) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4851 */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4852 (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4853 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4854 int listcount, i = 0, speccount; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4855 Lisp_Object *constructed_args; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4856 struct gcpro gcpro1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4857 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4858 GET_EXTERNAL_LIST_LENGTH (args, listcount); |
|
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 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
|
4861 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4862 /* 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
|
4863 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
|
4864 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4865 GCPRO1 (*constructed_args); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4866 gcpro1.nvars = ++i; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4867 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4868 /* The argument order is horrible here. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4869 constructed_args[i] = make_int (0); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4870 gcpro1.nvars = ++i; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4871 constructed_args[i] = make_int (Vmultiple_values_limit); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4872 gcpro1.nvars = ++i; |
|
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 speccount = bind_multiple_value_limits (0, Vmultiple_values_limit); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4875 constructed_args[i] = make_int (speccount); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4876 gcpro1.nvars = ++i; |
|
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 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4879 LIST_LOOP_2 (elt, XCDR (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4880 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4881 constructed_args[i] = Feval (elt); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4882 gcpro1.nvars = ++i; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4883 } |
|
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 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4886 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
|
4887 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4888 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4889 Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4890 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
|
4891 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4892 int first = XINT (args[0]), upper = XINT (args[1]), |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4893 speccount = XINT(args[2]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4894 Lisp_Object result = Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4895 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4896 assert (nargs == 4); |
|
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 result = args[3]; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4899 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4900 unbind_to (speccount); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4901 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4902 if (MULTIPLE_VALUEP (result)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4903 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4904 Lisp_Object head = Fcons (Qnil, Qnil); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4905 Lisp_Object list_offset = head, val; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4906 Elemcount count = XMULTIPLE_VALUE_COUNT(result); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4907 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4908 for (; first < upper && first < count; ++first) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4909 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4910 val = multiple_value_aref (result, first); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4911 assert (!UNBOUNDP (val)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4912 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4913 XSETCDR (list_offset, Fcons (val, Qnil)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4914 list_offset = XCDR (list_offset); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4915 } |
|
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 return XCDR (head); |
|
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 else |
|
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 if (first == 0) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4922 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4923 return Fcons (result, Qnil); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4924 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4925 else |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4926 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4927 return 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 } |
|
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 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4932 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
|
4933 UNEVALLED, 0, /* |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4934 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
|
4935 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4936 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
|
4937 Lisp, instead. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4938 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4939 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
|
4940 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
|
4941 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
|
4942 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
|
4943 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
|
4944 `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
|
4945 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4946 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
|
4947 */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4948 (args)) |
|
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 Lisp_Object argv[4]; |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4951 int first, upper, nargs; |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4952 struct gcpro gcpro1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4953 |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4954 GET_LIST_LENGTH (args, nargs); |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4955 if (nargs != 3) |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4956 { |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4957 Fsignal (Qwrong_number_of_arguments, |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4958 list2 (Qmultiple_value_list_internal, make_int (nargs))); |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4959 } |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4960 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4961 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
|
4962 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4963 GCPRO1 (argv[0]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4964 gcpro1.nvars = 1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4965 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4966 args = XCDR (args); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4967 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
|
4968 |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5265
diff
changeset
|
4969 check_integer_range (argv[1], Qzero, make_int (EMACS_INT_MAX)); |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5265
diff
changeset
|
4970 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
|
4971 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4972 upper = XINT (argv[1]); |
|
5307
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5265
diff
changeset
|
4973 first = XINT (argv[0]); |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5265
diff
changeset
|
4974 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4975 gcpro1.nvars = 2; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4976 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4977 /* 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
|
4978 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
|
4979 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
|
4980 arguments. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4981 argv[2] = make_int (bind_multiple_value_limits (first, upper)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4982 gcpro1.nvars = 3; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4983 args = XCDR (args); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4984 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4985 /* 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
|
4986 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
|
4987 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
|
4988 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
|
4989 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
|
4990 it doesn't matter for performance. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4991 argv[3] = Feval (XCAR (args)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4992 gcpro1.nvars = 4; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4993 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4994 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
|
4995 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4996 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4997 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
|
4998 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
|
4999 `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
|
5000 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5001 arguments: (FIRST &rest BODY) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5002 */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5003 (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5004 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5005 /* This function can GC */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5006 Lisp_Object val; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5007 struct gcpro gcpro1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5008 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5009 val = Feval (XCAR (args)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5010 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5011 GCPRO1 (val); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5012 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5013 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5014 LIST_LOOP_2 (form, XCDR (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5015 Feval (form); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5016 } |
|
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 RETURN_UNGCPRO (val); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5019 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5020 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5021 DEFUN ("values", Fvalues, 0, MANY, 0, /* |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5022 Return all ARGS as multiple values. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5023 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5024 arguments: (&rest ARGS) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5025 */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5026 (int nargs, Lisp_Object *args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5027 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5028 Lisp_Object result = Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5029 int counting = 1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5030 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5031 /* 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
|
5032 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
|
5033 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5034 return nargs ? args[0] : Qnil; |
|
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 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5037 /* 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
|
5038 #'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
|
5039 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
|
5040 transform them to nil. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5041 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
|
5042 first_desired_multiple_value, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5043 multiple_value_current_limit); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5044 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5045 for (; counting < nargs; ++counting) |
|
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 if (counting >= first_desired_multiple_value && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5048 counting < multiple_value_current_limit) |
|
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 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
|
5051 } |
|
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 return result; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5055 } |
|
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 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
|
5058 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
|
5059 */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5060 (list)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5061 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5062 Lisp_Object result = Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5063 int counting = 1, listcount; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5064 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5065 GET_EXTERNAL_LIST_LENGTH (list, listcount); |
|
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 /* 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
|
5068 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
|
5069 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5070 return Fcar_safe (list); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5071 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5072 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5073 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
|
5074 first_desired_multiple_value, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5075 multiple_value_current_limit); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5076 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5077 list = Fcdr_safe (list); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5078 |
|
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 EXTERNAL_LIST_LOOP_2 (elt, list) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5081 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5082 if (counting >= first_desired_multiple_value && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5083 counting < multiple_value_current_limit) |
|
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 multiple_value_aset (result, counting, elt); |
|
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 ++counting; |
|
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 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5091 return result; |
|
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 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5094 Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5095 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
|
5096 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5097 Lisp_Object argv[2]; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5098 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5099 argv[0] = first; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5100 argv[1] = second; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5101 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5102 return Fvalues (countof (argv), argv); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5103 } |
|
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 |
| 428 | 5106 /************************************************************************/ |
| 5107 /* Run hook variables in various ways. */ | |
| 5108 /************************************************************************/ | |
| 5109 | |
| 5110 DEFUN ("run-hooks", Frun_hooks, 1, MANY, 0, /* | |
| 5111 Run each hook in HOOKS. Major mode functions use this. | |
| 5112 Each argument should be a symbol, a hook variable. | |
| 5113 These symbols are processed in the order specified. | |
| 5114 If a hook symbol has a non-nil value, that value may be a function | |
| 5115 or a list of functions to be called to run the hook. | |
| 5116 If the value is a function, it is called with no arguments. | |
| 5117 If it is a list, the elements are called, in order, with no arguments. | |
| 5118 | |
| 5119 To make a hook variable buffer-local, use `make-local-hook', | |
| 5120 not `make-local-variable'. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5121 |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
5122 arguments: (FIRST &rest REST) |
| 428 | 5123 */ |
| 5124 (int nargs, Lisp_Object *args)) | |
| 5125 { | |
| 5126 REGISTER int i; | |
| 5127 | |
| 5128 for (i = 0; i < nargs; i++) | |
| 5129 run_hook_with_args (1, args + i, RUN_HOOKS_TO_COMPLETION); | |
| 5130 | |
| 5131 return Qnil; | |
| 5132 } | |
| 5133 | |
| 5134 DEFUN ("run-hook-with-args", Frun_hook_with_args, 1, MANY, 0, /* | |
| 5135 Run HOOK with the specified arguments ARGS. | |
| 5136 HOOK should be a symbol, a hook variable. If HOOK has a non-nil | |
| 5137 value, that value may be a function or a list of functions to be | |
| 5138 called to run the hook. If the value is a function, it is called with | |
| 5139 the given arguments and its return value is returned. If it is a list | |
| 5140 of functions, those functions are called, in order, | |
| 5141 with the given arguments ARGS. | |
| 444 | 5142 It is best not to depend on the value returned by `run-hook-with-args', |
| 428 | 5143 as that may change. |
| 5144 | |
| 5145 To make a hook variable buffer-local, use `make-local-hook', | |
| 5146 not `make-local-variable'. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5147 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5148 arguments: (HOOK &rest ARGS) |
| 428 | 5149 */ |
| 5150 (int nargs, Lisp_Object *args)) | |
| 5151 { | |
| 5152 return run_hook_with_args (nargs, args, RUN_HOOKS_TO_COMPLETION); | |
| 5153 } | |
| 5154 | |
| 5155 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success, 1, MANY, 0, /* | |
| 5156 Run HOOK with the specified arguments ARGS. | |
| 5157 HOOK should be a symbol, a hook variable. Its value should | |
| 5158 be a list of functions. We call those functions, one by one, | |
| 5159 passing arguments ARGS to each of them, until one of them | |
| 5160 returns a non-nil value. Then we return that value. | |
| 5161 If all the functions return nil, we return nil. | |
| 5162 | |
| 5163 To make a hook variable buffer-local, use `make-local-hook', | |
| 5164 not `make-local-variable'. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5165 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5166 arguments: (HOOK &rest ARGS) |
| 428 | 5167 */ |
| 5168 (int nargs, Lisp_Object *args)) | |
| 5169 { | |
| 5170 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_SUCCESS); | |
| 5171 } | |
| 5172 | |
| 5173 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure, 1, MANY, 0, /* | |
| 5174 Run HOOK with the specified arguments ARGS. | |
| 5175 HOOK should be a symbol, a hook variable. Its value should | |
| 5176 be a list of functions. We call those functions, one by one, | |
| 5177 passing arguments ARGS to each of them, until one of them | |
| 5178 returns nil. Then we return nil. | |
| 5179 If all the functions return non-nil, we return non-nil. | |
| 5180 | |
| 5181 To make a hook variable buffer-local, use `make-local-hook', | |
| 5182 not `make-local-variable'. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5183 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5184 arguments: (HOOK &rest ARGS) |
| 428 | 5185 */ |
| 5186 (int nargs, Lisp_Object *args)) | |
| 5187 { | |
| 5188 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_FAILURE); | |
| 5189 } | |
| 5190 | |
| 5191 /* ARGS[0] should be a hook symbol. | |
| 5192 Call each of the functions in the hook value, passing each of them | |
| 5193 as arguments all the rest of ARGS (all NARGS - 1 elements). | |
| 5194 COND specifies a condition to test after each call | |
| 5195 to decide whether to stop. | |
| 5196 The caller (or its caller, etc) must gcpro all of ARGS, | |
| 5197 except that it isn't necessary to gcpro ARGS[0]. */ | |
| 5198 | |
| 5199 Lisp_Object | |
| 5200 run_hook_with_args_in_buffer (struct buffer *buf, int nargs, Lisp_Object *args, | |
| 5201 enum run_hooks_condition cond) | |
| 5202 { | |
| 5203 Lisp_Object sym, val, ret; | |
| 5204 | |
| 5205 if (!initialized || preparing_for_armageddon) | |
| 5206 /* We need to bail out of here pronto. */ | |
| 5207 return Qnil; | |
| 5208 | |
| 3092 | 5209 #ifndef NEW_GC |
| 428 | 5210 /* Whenever gc_in_progress is true, preparing_for_armageddon |
| 5211 will also be true unless something is really hosed. */ | |
| 5212 assert (!gc_in_progress); | |
| 3092 | 5213 #endif /* not NEW_GC */ |
| 428 | 5214 |
| 5215 sym = args[0]; | |
| 771 | 5216 val = symbol_value_in_buffer (sym, wrap_buffer (buf)); |
| 428 | 5217 ret = (cond == RUN_HOOKS_UNTIL_FAILURE ? Qt : Qnil); |
| 5218 | |
| 5219 if (UNBOUNDP (val) || NILP (val)) | |
| 5220 return ret; | |
| 5221 else if (!CONSP (val) || EQ (XCAR (val), Qlambda)) | |
| 5222 { | |
| 5223 args[0] = val; | |
| 5224 return Ffuncall (nargs, args); | |
| 5225 } | |
| 5226 else | |
| 5227 { | |
| 5228 struct gcpro gcpro1, gcpro2, gcpro3; | |
| 5229 Lisp_Object globals = Qnil; | |
| 5230 GCPRO3 (sym, val, globals); | |
| 5231 | |
| 5232 for (; | |
| 5233 CONSP (val) && ((cond == RUN_HOOKS_TO_COMPLETION) | |
| 5234 || (cond == RUN_HOOKS_UNTIL_SUCCESS ? NILP (ret) | |
| 5235 : !NILP (ret))); | |
| 5236 val = XCDR (val)) | |
| 5237 { | |
| 5238 if (EQ (XCAR (val), Qt)) | |
| 5239 { | |
| 5240 /* t indicates this hook has a local binding; | |
| 5241 it means to run the global binding too. */ | |
| 5242 globals = Fdefault_value (sym); | |
| 5243 | |
| 5244 if ((! CONSP (globals) || EQ (XCAR (globals), Qlambda)) && | |
| 5245 ! NILP (globals)) | |
| 5246 { | |
| 5247 args[0] = globals; | |
| 5248 ret = Ffuncall (nargs, args); | |
| 5249 } | |
| 5250 else | |
| 5251 { | |
| 5252 for (; | |
| 5253 CONSP (globals) && ((cond == RUN_HOOKS_TO_COMPLETION) | |
| 5254 || (cond == RUN_HOOKS_UNTIL_SUCCESS | |
| 5255 ? NILP (ret) | |
| 5256 : !NILP (ret))); | |
| 5257 globals = XCDR (globals)) | |
| 5258 { | |
| 5259 args[0] = XCAR (globals); | |
| 5260 /* In a global value, t should not occur. If it does, we | |
| 5261 must ignore it to avoid an endless loop. */ | |
| 5262 if (!EQ (args[0], Qt)) | |
| 5263 ret = Ffuncall (nargs, args); | |
| 5264 } | |
| 5265 } | |
| 5266 } | |
| 5267 else | |
| 5268 { | |
| 5269 args[0] = XCAR (val); | |
| 5270 ret = Ffuncall (nargs, args); | |
| 5271 } | |
| 5272 } | |
| 5273 | |
| 5274 UNGCPRO; | |
| 5275 return ret; | |
| 5276 } | |
| 5277 } | |
| 5278 | |
| 5279 Lisp_Object | |
| 5280 run_hook_with_args (int nargs, Lisp_Object *args, | |
| 5281 enum run_hooks_condition cond) | |
| 5282 { | |
| 5283 return run_hook_with_args_in_buffer (current_buffer, nargs, args, cond); | |
| 5284 } | |
| 5285 | |
| 5286 #if 0 | |
| 5287 | |
| 853 | 5288 /* From FSF 19.30, not currently used; seems like a big kludge. */ |
| 428 | 5289 |
| 5290 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual | |
| 5291 present value of that symbol. | |
| 5292 Call each element of FUNLIST, | |
| 5293 passing each of them the rest of ARGS. | |
| 5294 The caller (or its caller, etc) must gcpro all of ARGS, | |
| 5295 except that it isn't necessary to gcpro ARGS[0]. */ | |
| 5296 | |
| 5297 Lisp_Object | |
| 5298 run_hook_list_with_args (Lisp_Object funlist, int nargs, Lisp_Object *args) | |
| 5299 { | |
| 853 | 5300 omitted; |
| 428 | 5301 } |
| 5302 | |
| 5303 #endif /* 0 */ | |
| 5304 | |
| 5305 void | |
| 5306 va_run_hook_with_args (Lisp_Object hook_var, int nargs, ...) | |
| 5307 { | |
| 5308 /* This function can GC */ | |
| 5309 struct gcpro gcpro1; | |
| 5310 int i; | |
| 5311 va_list vargs; | |
| 5312 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs); | |
| 5313 | |
| 5314 va_start (vargs, nargs); | |
| 5315 funcall_args[0] = hook_var; | |
| 5316 for (i = 0; i < nargs; i++) | |
| 5317 funcall_args[i + 1] = va_arg (vargs, Lisp_Object); | |
| 5318 va_end (vargs); | |
| 5319 | |
| 5320 GCPRO1 (*funcall_args); | |
| 5321 gcpro1.nvars = nargs + 1; | |
| 5322 run_hook_with_args (nargs + 1, funcall_args, RUN_HOOKS_TO_COMPLETION); | |
| 5323 UNGCPRO; | |
| 5324 } | |
| 5325 | |
| 5326 void | |
| 5327 va_run_hook_with_args_in_buffer (struct buffer *buf, Lisp_Object hook_var, | |
| 5328 int nargs, ...) | |
| 5329 { | |
| 5330 /* This function can GC */ | |
| 5331 struct gcpro gcpro1; | |
| 5332 int i; | |
| 5333 va_list vargs; | |
| 5334 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs); | |
| 5335 | |
| 5336 va_start (vargs, nargs); | |
| 5337 funcall_args[0] = hook_var; | |
| 5338 for (i = 0; i < nargs; i++) | |
| 5339 funcall_args[i + 1] = va_arg (vargs, Lisp_Object); | |
| 5340 va_end (vargs); | |
| 5341 | |
| 5342 GCPRO1 (*funcall_args); | |
| 5343 gcpro1.nvars = nargs + 1; | |
| 5344 run_hook_with_args_in_buffer (buf, nargs + 1, funcall_args, | |
| 5345 RUN_HOOKS_TO_COMPLETION); | |
| 5346 UNGCPRO; | |
| 5347 } | |
| 5348 | |
| 5349 Lisp_Object | |
| 5350 run_hook (Lisp_Object hook) | |
| 5351 { | |
| 853 | 5352 return run_hook_with_args (1, &hook, RUN_HOOKS_TO_COMPLETION); |
| 428 | 5353 } |
| 5354 | |
| 5355 | |
| 5356 /************************************************************************/ | |
| 5357 /* Front-ends to eval, funcall, apply */ | |
| 5358 /************************************************************************/ | |
| 5359 | |
| 5360 /* Apply fn to arg */ | |
| 5361 Lisp_Object | |
| 5362 apply1 (Lisp_Object fn, Lisp_Object arg) | |
| 5363 { | |
| 5364 /* This function can GC */ | |
| 5365 struct gcpro gcpro1; | |
| 5366 Lisp_Object args[2]; | |
| 5367 | |
| 5368 if (NILP (arg)) | |
| 5369 return Ffuncall (1, &fn); | |
| 5370 GCPRO1 (args[0]); | |
| 5371 gcpro1.nvars = 2; | |
| 5372 args[0] = fn; | |
| 5373 args[1] = arg; | |
| 5374 RETURN_UNGCPRO (Fapply (2, args)); | |
| 5375 } | |
| 5376 | |
| 5377 /* Call function fn on no arguments */ | |
| 5378 Lisp_Object | |
| 5379 call0 (Lisp_Object fn) | |
| 5380 { | |
| 5381 /* This function can GC */ | |
| 5382 struct gcpro gcpro1; | |
| 5383 | |
| 5384 GCPRO1 (fn); | |
| 5385 RETURN_UNGCPRO (Ffuncall (1, &fn)); | |
| 5386 } | |
| 5387 | |
| 5388 /* Call function fn with argument arg0 */ | |
| 5389 Lisp_Object | |
| 5390 call1 (Lisp_Object fn, | |
| 5391 Lisp_Object arg0) | |
| 5392 { | |
| 5393 /* This function can GC */ | |
| 5394 struct gcpro gcpro1; | |
| 5395 Lisp_Object args[2]; | |
| 5396 args[0] = fn; | |
| 5397 args[1] = arg0; | |
| 5398 GCPRO1 (args[0]); | |
| 5399 gcpro1.nvars = 2; | |
| 5400 RETURN_UNGCPRO (Ffuncall (2, args)); | |
| 5401 } | |
| 5402 | |
| 5403 /* Call function fn with arguments arg0, arg1 */ | |
| 5404 Lisp_Object | |
| 5405 call2 (Lisp_Object fn, | |
| 5406 Lisp_Object arg0, Lisp_Object arg1) | |
| 5407 { | |
| 5408 /* This function can GC */ | |
| 5409 struct gcpro gcpro1; | |
| 5410 Lisp_Object args[3]; | |
| 5411 args[0] = fn; | |
| 5412 args[1] = arg0; | |
| 5413 args[2] = arg1; | |
| 5414 GCPRO1 (args[0]); | |
| 5415 gcpro1.nvars = 3; | |
| 5416 RETURN_UNGCPRO (Ffuncall (3, args)); | |
| 5417 } | |
| 5418 | |
| 5419 /* Call function fn with arguments arg0, arg1, arg2 */ | |
| 5420 Lisp_Object | |
| 5421 call3 (Lisp_Object fn, | |
| 5422 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2) | |
| 5423 { | |
| 5424 /* This function can GC */ | |
| 5425 struct gcpro gcpro1; | |
| 5426 Lisp_Object args[4]; | |
| 5427 args[0] = fn; | |
| 5428 args[1] = arg0; | |
| 5429 args[2] = arg1; | |
| 5430 args[3] = arg2; | |
| 5431 GCPRO1 (args[0]); | |
| 5432 gcpro1.nvars = 4; | |
| 5433 RETURN_UNGCPRO (Ffuncall (4, args)); | |
| 5434 } | |
| 5435 | |
| 5436 /* Call function fn with arguments arg0, arg1, arg2, arg3 */ | |
| 5437 Lisp_Object | |
| 5438 call4 (Lisp_Object fn, | |
| 5439 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5440 Lisp_Object arg3) | |
| 5441 { | |
| 5442 /* This function can GC */ | |
| 5443 struct gcpro gcpro1; | |
| 5444 Lisp_Object args[5]; | |
| 5445 args[0] = fn; | |
| 5446 args[1] = arg0; | |
| 5447 args[2] = arg1; | |
| 5448 args[3] = arg2; | |
| 5449 args[4] = arg3; | |
| 5450 GCPRO1 (args[0]); | |
| 5451 gcpro1.nvars = 5; | |
| 5452 RETURN_UNGCPRO (Ffuncall (5, args)); | |
| 5453 } | |
| 5454 | |
| 5455 /* Call function fn with arguments arg0, arg1, arg2, arg3, arg4 */ | |
| 5456 Lisp_Object | |
| 5457 call5 (Lisp_Object fn, | |
| 5458 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5459 Lisp_Object arg3, Lisp_Object arg4) | |
| 5460 { | |
| 5461 /* This function can GC */ | |
| 5462 struct gcpro gcpro1; | |
| 5463 Lisp_Object args[6]; | |
| 5464 args[0] = fn; | |
| 5465 args[1] = arg0; | |
| 5466 args[2] = arg1; | |
| 5467 args[3] = arg2; | |
| 5468 args[4] = arg3; | |
| 5469 args[5] = arg4; | |
| 5470 GCPRO1 (args[0]); | |
| 5471 gcpro1.nvars = 6; | |
| 5472 RETURN_UNGCPRO (Ffuncall (6, args)); | |
| 5473 } | |
| 5474 | |
| 5475 Lisp_Object | |
| 5476 call6 (Lisp_Object fn, | |
| 5477 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5478 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5) | |
| 5479 { | |
| 5480 /* This function can GC */ | |
| 5481 struct gcpro gcpro1; | |
| 5482 Lisp_Object args[7]; | |
| 5483 args[0] = fn; | |
| 5484 args[1] = arg0; | |
| 5485 args[2] = arg1; | |
| 5486 args[3] = arg2; | |
| 5487 args[4] = arg3; | |
| 5488 args[5] = arg4; | |
| 5489 args[6] = arg5; | |
| 5490 GCPRO1 (args[0]); | |
| 5491 gcpro1.nvars = 7; | |
| 5492 RETURN_UNGCPRO (Ffuncall (7, args)); | |
| 5493 } | |
| 5494 | |
| 5495 Lisp_Object | |
| 5496 call7 (Lisp_Object fn, | |
| 5497 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5498 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5, | |
| 5499 Lisp_Object arg6) | |
| 5500 { | |
| 5501 /* This function can GC */ | |
| 5502 struct gcpro gcpro1; | |
| 5503 Lisp_Object args[8]; | |
| 5504 args[0] = fn; | |
| 5505 args[1] = arg0; | |
| 5506 args[2] = arg1; | |
| 5507 args[3] = arg2; | |
| 5508 args[4] = arg3; | |
| 5509 args[5] = arg4; | |
| 5510 args[6] = arg5; | |
| 5511 args[7] = arg6; | |
| 5512 GCPRO1 (args[0]); | |
| 5513 gcpro1.nvars = 8; | |
| 5514 RETURN_UNGCPRO (Ffuncall (8, args)); | |
| 5515 } | |
| 5516 | |
| 5517 Lisp_Object | |
| 5518 call8 (Lisp_Object fn, | |
| 5519 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5520 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5, | |
| 5521 Lisp_Object arg6, Lisp_Object arg7) | |
| 5522 { | |
| 5523 /* This function can GC */ | |
| 5524 struct gcpro gcpro1; | |
| 5525 Lisp_Object args[9]; | |
| 5526 args[0] = fn; | |
| 5527 args[1] = arg0; | |
| 5528 args[2] = arg1; | |
| 5529 args[3] = arg2; | |
| 5530 args[4] = arg3; | |
| 5531 args[5] = arg4; | |
| 5532 args[6] = arg5; | |
| 5533 args[7] = arg6; | |
| 5534 args[8] = arg7; | |
| 5535 GCPRO1 (args[0]); | |
| 5536 gcpro1.nvars = 9; | |
| 5537 RETURN_UNGCPRO (Ffuncall (9, args)); | |
| 5538 } | |
| 5539 | |
| 5540 Lisp_Object | |
| 5541 call0_in_buffer (struct buffer *buf, Lisp_Object fn) | |
| 5542 { | |
| 5543 if (current_buffer == buf) | |
| 5544 return call0 (fn); | |
| 5545 else | |
| 5546 { | |
| 5547 Lisp_Object val; | |
| 5548 int speccount = specpdl_depth(); | |
| 5549 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5550 set_buffer_internal (buf); | |
| 5551 val = call0 (fn); | |
| 771 | 5552 unbind_to (speccount); |
| 428 | 5553 return val; |
| 5554 } | |
| 5555 } | |
| 5556 | |
| 5557 Lisp_Object | |
| 5558 call1_in_buffer (struct buffer *buf, Lisp_Object fn, | |
| 5559 Lisp_Object arg0) | |
| 5560 { | |
| 5561 if (current_buffer == buf) | |
| 5562 return call1 (fn, arg0); | |
| 5563 else | |
| 5564 { | |
| 5565 Lisp_Object val; | |
| 5566 int speccount = specpdl_depth(); | |
| 5567 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5568 set_buffer_internal (buf); | |
| 5569 val = call1 (fn, arg0); | |
| 771 | 5570 unbind_to (speccount); |
| 428 | 5571 return val; |
| 5572 } | |
| 5573 } | |
| 5574 | |
| 5575 Lisp_Object | |
| 5576 call2_in_buffer (struct buffer *buf, Lisp_Object fn, | |
| 5577 Lisp_Object arg0, Lisp_Object arg1) | |
| 5578 { | |
| 5579 if (current_buffer == buf) | |
| 5580 return call2 (fn, arg0, arg1); | |
| 5581 else | |
| 5582 { | |
| 5583 Lisp_Object val; | |
| 5584 int speccount = specpdl_depth(); | |
| 5585 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5586 set_buffer_internal (buf); | |
| 5587 val = call2 (fn, arg0, arg1); | |
| 771 | 5588 unbind_to (speccount); |
| 428 | 5589 return val; |
| 5590 } | |
| 5591 } | |
| 5592 | |
| 5593 Lisp_Object | |
| 5594 call3_in_buffer (struct buffer *buf, Lisp_Object fn, | |
| 5595 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2) | |
| 5596 { | |
| 5597 if (current_buffer == buf) | |
| 5598 return call3 (fn, arg0, arg1, arg2); | |
| 5599 else | |
| 5600 { | |
| 5601 Lisp_Object val; | |
| 5602 int speccount = specpdl_depth(); | |
| 5603 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5604 set_buffer_internal (buf); | |
| 5605 val = call3 (fn, arg0, arg1, arg2); | |
| 771 | 5606 unbind_to (speccount); |
| 428 | 5607 return val; |
| 5608 } | |
| 5609 } | |
| 5610 | |
| 5611 Lisp_Object | |
| 5612 call4_in_buffer (struct buffer *buf, Lisp_Object fn, | |
| 5613 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5614 Lisp_Object arg3) | |
| 5615 { | |
| 5616 if (current_buffer == buf) | |
| 5617 return call4 (fn, arg0, arg1, arg2, arg3); | |
| 5618 else | |
| 5619 { | |
| 5620 Lisp_Object val; | |
| 5621 int speccount = specpdl_depth(); | |
| 5622 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5623 set_buffer_internal (buf); | |
| 5624 val = call4 (fn, arg0, arg1, arg2, arg3); | |
| 771 | 5625 unbind_to (speccount); |
| 428 | 5626 return val; |
| 5627 } | |
| 5628 } | |
| 5629 | |
| 5630 Lisp_Object | |
| 5631 eval_in_buffer (struct buffer *buf, Lisp_Object form) | |
| 5632 { | |
| 5633 if (current_buffer == buf) | |
| 5634 return Feval (form); | |
| 5635 else | |
| 5636 { | |
| 5637 Lisp_Object val; | |
| 5638 int speccount = specpdl_depth(); | |
| 5639 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5640 set_buffer_internal (buf); | |
| 5641 val = Feval (form); | |
| 771 | 5642 unbind_to (speccount); |
| 428 | 5643 return val; |
| 5644 } | |
| 5645 } | |
| 5646 | |
| 5647 | |
| 5648 /************************************************************************/ | |
| 5649 /* Error-catching front-ends to eval, funcall, apply */ | |
| 5650 /************************************************************************/ | |
| 5651 | |
| 853 | 5652 int |
| 5653 get_inhibit_flags (void) | |
| 5654 { | |
| 5655 return inhibit_flags; | |
| 5656 } | |
| 5657 | |
| 5658 void | |
| 2286 | 5659 check_allowed_operation (int what, Lisp_Object obj, Lisp_Object UNUSED (prop)) |
| 853 | 5660 { |
| 5661 if (inhibit_flags & INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION) | |
| 5662 { | |
| 5663 if (what == OPERATION_MODIFY_BUFFER_TEXT && BUFFERP (obj) | |
| 5664 && NILP (memq_no_quit (obj, Vmodifiable_buffers))) | |
| 5665 invalid_change | |
| 5666 ("Modification of this buffer not currently permitted", obj); | |
| 5667 } | |
| 5668 if (inhibit_flags & INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION) | |
| 5669 { | |
| 5670 if (what == OPERATION_DELETE_OBJECT | |
| 5671 && (BUFFERP (obj) || WINDOWP (obj) || FRAMEP (obj) || DEVICEP (obj) | |
| 5672 || CONSOLEP (obj)) | |
| 5673 && NILP (memq_no_quit (obj, Vdeletable_permanent_display_objects))) | |
| 5674 invalid_change | |
| 5675 ("Deletion of this object not currently permitted", obj); | |
| 5676 } | |
| 5677 } | |
| 5678 | |
| 5679 void | |
| 5680 note_object_created (Lisp_Object obj) | |
| 5681 { | |
| 5682 if (inhibit_flags & INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION) | |
| 5683 { | |
| 5684 if (BUFFERP (obj)) | |
| 5685 Vmodifiable_buffers = Fcons (obj, Vmodifiable_buffers); | |
| 5686 } | |
| 5687 if (inhibit_flags & INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION) | |
| 5688 { | |
| 5689 if (BUFFERP (obj) || WINDOWP (obj) || FRAMEP (obj) || DEVICEP (obj) | |
| 5690 || CONSOLEP (obj)) | |
| 5691 Vdeletable_permanent_display_objects = | |
| 5692 Fcons (obj, Vdeletable_permanent_display_objects); | |
| 5693 } | |
| 5694 } | |
| 5695 | |
| 5696 void | |
| 5697 note_object_deleted (Lisp_Object obj) | |
| 5698 { | |
| 5699 if (inhibit_flags & INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION) | |
| 5700 { | |
| 5701 if (BUFFERP (obj)) | |
| 5702 Vmodifiable_buffers = delq_no_quit (obj, Vmodifiable_buffers); | |
| 5703 } | |
| 5704 if (inhibit_flags & INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION) | |
| 5705 { | |
| 5706 if (BUFFERP (obj) || WINDOWP (obj) || FRAMEP (obj) || DEVICEP (obj) | |
| 5707 || CONSOLEP (obj)) | |
| 5708 Vdeletable_permanent_display_objects = | |
| 5709 delq_no_quit (obj, Vdeletable_permanent_display_objects); | |
| 5710 } | |
| 5711 } | |
| 5712 | |
| 5713 struct call_trapping_problems | |
| 5714 { | |
| 5715 Lisp_Object catchtag; | |
| 5716 Lisp_Object error_conditions; | |
| 5717 Lisp_Object data; | |
| 5718 Lisp_Object backtrace; | |
| 5719 Lisp_Object warning_class; | |
| 5720 | |
| 867 | 5721 const CIbyte *warning_string; |
| 853 | 5722 Lisp_Object (*fun) (void *); |
| 5723 void *arg; | |
| 5724 }; | |
| 428 | 5725 |
| 2532 | 5726 static Lisp_Object |
| 5727 maybe_get_trapping_problems_backtrace (void) | |
| 5728 { | |
| 5729 Lisp_Object backtrace; | |
| 853 | 5730 |
| 1123 | 5731 if (!(inhibit_flags & INHIBIT_WARNING_ISSUE) |
| 2532 | 5732 && !warning_will_be_discarded (current_warning_level ())) |
| 428 | 5733 { |
| 1333 | 5734 struct gcpro gcpro1; |
| 5735 Lisp_Object lstream = Qnil; | |
| 5736 int speccount = specpdl_depth (); | |
| 5737 | |
| 853 | 5738 /* We're no longer protected against errors or quit here, so at |
| 5739 least let's temporarily inhibit quit. We definitely do not | |
| 5740 want to inhibit quit during the calling of the function | |
| 5741 itself!!!!!!!!!!! */ | |
| 5742 | |
| 5743 specbind (Qinhibit_quit, Qt); | |
| 5744 | |
| 5745 GCPRO1 (lstream); | |
| 5746 lstream = make_resizing_buffer_output_stream (); | |
| 5747 Fbacktrace (lstream, Qt); | |
| 5748 Lstream_flush (XLSTREAM (lstream)); | |
| 2532 | 5749 backtrace = resizing_buffer_to_lisp_string (XLSTREAM (lstream)); |
| 853 | 5750 Lstream_delete (XLSTREAM (lstream)); |
| 5751 UNGCPRO; | |
| 5752 | |
| 5753 unbind_to (speccount); | |
| 428 | 5754 } |
| 853 | 5755 else |
| 2532 | 5756 backtrace = Qnil; |
| 5757 | |
| 5758 return backtrace; | |
| 5759 } | |
| 5760 | |
| 5761 static DECLARE_DOESNT_RETURN_TYPE | |
| 5762 (Lisp_Object, flagged_a_squirmer (Lisp_Object, Lisp_Object, Lisp_Object)); | |
| 5763 | |
| 5764 static DOESNT_RETURN_TYPE (Lisp_Object) | |
| 5765 flagged_a_squirmer (Lisp_Object error_conditions, Lisp_Object data, | |
| 5766 Lisp_Object opaque) | |
| 5767 { | |
| 5768 struct call_trapping_problems *p = | |
| 5769 (struct call_trapping_problems *) get_opaque_ptr (opaque); | |
| 5770 | |
| 5771 if (!EQ (error_conditions, Qquit)) | |
| 5772 p->backtrace = maybe_get_trapping_problems_backtrace (); | |
| 5773 else | |
| 853 | 5774 p->backtrace = Qnil; |
| 5775 p->error_conditions = error_conditions; | |
| 5776 p->data = data; | |
| 5777 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5778 throw_or_bomb_out (p->catchtag, Qnil, 0, Qnil, Qnil); |
| 2268 | 5779 RETURN_NOT_REACHED (Qnil); |
| 853 | 5780 } |
| 5781 | |
| 5782 static Lisp_Object | |
| 5783 call_trapping_problems_2 (Lisp_Object opaque) | |
| 5784 { | |
| 5785 struct call_trapping_problems *p = | |
| 5786 (struct call_trapping_problems *) get_opaque_ptr (opaque); | |
| 5787 | |
| 5788 return (p->fun) (p->arg); | |
| 428 | 5789 } |
| 5790 | |
| 5791 static Lisp_Object | |
| 853 | 5792 call_trapping_problems_1 (Lisp_Object opaque) |
| 5793 { | |
| 5794 return call_with_condition_handler (flagged_a_squirmer, opaque, | |
| 5795 call_trapping_problems_2, opaque); | |
| 5796 } | |
| 5797 | |
| 1333 | 5798 static void |
| 5799 issue_call_trapping_problems_warning (Lisp_Object warning_class, | |
| 5800 const CIbyte *warning_string, | |
| 5801 struct call_trapping_problems_result *p) | |
| 5802 { | |
| 5803 if (!warning_will_be_discarded (current_warning_level ())) | |
| 5804 { | |
| 5805 int depth = specpdl_depth (); | |
| 5806 | |
| 5807 /* We're no longer protected against errors or quit here, so at | |
| 5808 least let's temporarily inhibit quit. */ | |
| 5809 specbind (Qinhibit_quit, Qt); | |
| 5810 | |
| 5811 if (p->caught_throw) | |
| 5812 { | |
| 5813 Lisp_Object errstr = | |
| 5814 emacs_sprintf_string_lisp | |
| 2532 | 5815 ("%s: Attempt to throw outside of function:" |
| 5816 "To catch `%s' with value `%s'\n\nBacktrace follows:\n\n%s", | |
| 2725 | 5817 Qnil, 4, |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
5818 build_msg_cistring (warning_string ? warning_string : "error"), |
| 2532 | 5819 p->thrown_tag, p->thrown_value, p->backtrace); |
| 1333 | 5820 warn_when_safe_lispobj (Qerror, current_warning_level (), errstr); |
| 5821 } | |
| 2421 | 5822 else if (p->caught_error && !EQ (p->error_conditions, Qquit)) |
| 1333 | 5823 { |
| 5824 Lisp_Object errstr; | |
| 5825 /* #### This should call | |
| 5826 (with-output-to-string (display-error (cons error_conditions | |
| 5827 data)) | |
| 5828 but that stuff is all in Lisp currently. */ | |
| 5829 errstr = | |
| 5830 emacs_sprintf_string_lisp | |
| 5831 ("%s: (%s %s)\n\nBacktrace follows:\n\n%s", | |
| 5832 Qnil, 4, | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
5833 build_msg_cistring (warning_string ? warning_string : "error"), |
| 1333 | 5834 p->error_conditions, p->data, p->backtrace); |
| 5835 | |
| 5836 warn_when_safe_lispobj (warning_class, current_warning_level (), | |
| 5837 errstr); | |
| 5838 } | |
| 5839 | |
| 5840 unbind_to (depth); | |
| 5841 } | |
| 5842 } | |
| 5843 | |
| 1318 | 5844 /* Turn on the trapping flags in FLAGS -- see call_trapping_problems(). |
| 5845 This cannot handle INTERNAL_INHIBIT_THROWS() or INTERNAL_INHIBIT_ERRORS | |
| 5846 (because they ultimately boil down to a setjmp()!) -- you must directly | |
| 5847 use call_trapping_problems() for that. Turn the flags off with | |
| 5848 unbind_to(). Returns the "canonicalized" flags (particularly in the | |
| 5849 case of INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY, which is shorthand for | |
| 5850 various other flags). */ | |
| 5851 | |
| 5852 int | |
| 5853 set_trapping_problems_flags (int flags) | |
| 5854 { | |
| 5855 int new_inhibit_flags; | |
| 5856 | |
| 5857 if (flags & INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY) | |
| 5858 flags |= INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION | |
| 5859 | INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION | |
| 5860 | INHIBIT_ENTERING_DEBUGGER | |
| 5861 | INHIBIT_WARNING_ISSUE | |
| 5862 | INHIBIT_GC; | |
| 5863 | |
| 5864 new_inhibit_flags = inhibit_flags | flags; | |
| 5865 if (new_inhibit_flags != inhibit_flags) | |
| 5866 internal_bind_int (&inhibit_flags, new_inhibit_flags); | |
| 5867 | |
| 5868 if (flags & INHIBIT_QUIT) | |
| 5869 specbind (Qinhibit_quit, Qt); | |
| 5870 | |
| 5871 if (flags & UNINHIBIT_QUIT) | |
| 5872 begin_do_check_for_quit (); | |
| 5873 | |
| 5874 if (flags & INHIBIT_GC) | |
| 5875 begin_gc_forbidden (); | |
| 5876 | |
| 5877 /* #### If we have nested calls to call_trapping_problems(), and the | |
| 5878 inner one creates some buffers/etc., should the outer one be able | |
| 5879 to delete them? I think so, but it means we need to combine rather | |
| 5880 than just reset the value. */ | |
| 5881 if (flags & INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION) | |
| 5882 internal_bind_lisp_object (&Vdeletable_permanent_display_objects, Qnil); | |
| 5883 | |
| 5884 if (flags & INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION) | |
| 5885 internal_bind_lisp_object (&Vmodifiable_buffers, Qnil); | |
| 5886 | |
| 5887 return flags; | |
| 5888 } | |
| 5889 | |
| 853 | 5890 /* This is equivalent to (*fun) (arg), except that various conditions |
| 5891 can be trapped or inhibited, according to FLAGS. | |
| 5892 | |
| 5893 If FLAGS does not contain NO_INHIBIT_ERRORS, when an error occurs, | |
| 5894 the error is caught and a warning is issued, specifying the | |
| 5895 specific error that occurred and a backtrace. In that case, | |
| 5896 WARNING_STRING should be given, and will be printed at the | |
| 5897 beginning of the error to indicate where the error occurred. | |
| 5898 | |
| 5899 If FLAGS does not contain NO_INHIBIT_THROWS, all attempts to | |
| 5900 `throw' out of the function being called are trapped, and a warning | |
| 5901 issued. (Again, WARNING_STRING should be given.) | |
| 5902 | |
| 2367 | 5903 If FLAGS contains INHIBIT_WARNING_ISSUE, no warnings are issued; |
| 853 | 5904 this applies to recursive invocations of call_trapping_problems, too. |
| 5905 | |
| 1333 | 5906 If FLAGS contains POSTPONE_WARNING_ISSUE, no warnings are issued; |
| 5907 but values useful for generating a warning are still computed (in | |
| 5908 particular, the backtrace), so that the calling function can issue | |
| 5909 a warning. | |
| 5910 | |
| 853 | 5911 If FLAGS contains ISSUE_WARNINGS_AT_DEBUG_LEVEL, warnings will be |
| 5912 issued, but at level `debug', which normally is below the minimum | |
| 5913 specified by `log-warning-minimum-level', meaning such warnings will | |
| 5914 be ignored entirely. The user can change this variable, however, | |
| 5915 to see the warnings.) | |
| 5916 | |
| 5917 Note: If neither of NO_INHIBIT_THROWS or NO_INHIBIT_ERRORS is | |
| 5918 given, you are *guaranteed* that there will be no non-local exits | |
| 5919 out of this function. | |
| 5920 | |
| 5921 If FLAGS contains INHIBIT_QUIT, QUIT using C-g is inhibited. (This | |
| 5922 is *rarely* a good idea. Unless you use NO_INHIBIT_ERRORS, QUIT is | |
| 5923 automatically caught as well, and treated as an error; you can | |
| 5924 check for this using EQ (problems->error_conditions, Qquit). | |
| 5925 | |
| 5926 If FLAGS contains UNINHIBIT_QUIT, QUIT checking will be explicitly | |
| 5927 turned on. (It will abort the code being called, but will still be | |
| 5928 trapped and reported as an error, unless NO_INHIBIT_ERRORS is | |
| 5929 given.) This is useful when QUIT checking has been turned off by a | |
| 5930 higher-level caller. | |
| 5931 | |
| 5932 If FLAGS contains INHIBIT_GC, garbage collection is inhibited. | |
| 1123 | 5933 This is useful for Lisp called within redisplay, for example. |
| 853 | 5934 |
| 5935 If FLAGS contains INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION, | |
| 5936 Lisp code is not allowed to delete any window, buffers, frames, devices, | |
| 5937 or consoles that were already in existence at the time this function | |
| 5938 was called. (However, it's perfectly legal for code to create a new | |
| 5939 buffer and then delete it.) | |
| 5940 | |
| 5941 #### It might be useful to have a flag that inhibits deletion of a | |
| 5942 specific permanent display object and everything it's attached to | |
| 5943 (e.g. a window, and the buffer, frame, device, and console it's | |
| 5944 attached to. | |
| 5945 | |
| 5946 If FLAGS contains INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION, Lisp | |
| 5947 code is not allowed to modify the text of any buffers that were | |
| 5948 already in existence at the time this function was called. | |
| 5949 (However, it's perfectly legal for code to create a new buffer and | |
| 5950 then modify its text.) | |
| 5951 | |
| 5952 [These last two flags are implemented using global variables | |
| 5953 Vdeletable_permanent_display_objects and Vmodifiable_buffers, | |
| 5954 which keep track of a list of all buffers or permanent display | |
| 5955 objects created since the last time one of these flags was set. | |
| 5956 The code that deletes buffers, etc. and modifies buffers checks | |
| 5957 | |
| 5958 (1) if the corresponding flag is set (through the global variable | |
| 5959 inhibit_flags or its accessor function get_inhibit_flags()), and | |
| 5960 | |
| 5961 (2) if the object to be modified or deleted is not in the | |
| 5962 appropriate list. | |
| 5963 | |
| 5964 If so, it signals an error. | |
| 5965 | |
| 5966 Recursive calls to call_trapping_problems() are allowed. In | |
| 5967 the case of the two flags mentioned above, the current values | |
| 5968 of the global variables are stored in an unwind-protect, and | |
| 5969 they're reset to nil.] | |
| 5970 | |
| 5971 If FLAGS contains INHIBIT_ENTERING_DEBUGGER, the debugger will not | |
| 5972 be entered if an error occurs inside the Lisp code being called, | |
| 5973 even when the user has requested an error. In such case, a warning | |
| 5974 is issued stating that access to the debugger is denied, unless | |
| 5975 INHIBIT_WARNING_ISSUE has also been supplied. This is useful when | |
| 5976 calling Lisp code inside redisplay, in menu callbacks, etc. because | |
| 5977 in such cases either the display is in an inconsistent state or | |
| 5978 doing window operations is explicitly forbidden by the OS, and the | |
| 5979 debugger would causes visual changes on the screen and might create | |
| 5980 another frame. | |
| 5981 | |
| 5982 If FLAGS contains INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY, no | |
| 5983 changes of any sort to extents, faces, glyphs, buffer text, | |
| 5984 specifiers relating to display, other variables relating to | |
| 5985 display, splitting, deleting, or resizing windows or frames, | |
| 5986 deleting buffers, windows, frames, devices, or consoles, etc. is | |
| 5987 allowed. This is for things called absolutely in the middle of | |
| 5988 redisplay, which expects things to be *exactly* the same after the | |
| 5989 call as before. This isn't completely implemented and needs to be | |
| 5990 thought out some more to determine exactly what its semantics are. | |
| 5991 For the moment, turning on this flag also turns on | |
| 5992 | |
| 5993 INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION | |
| 5994 INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION | |
| 5995 INHIBIT_ENTERING_DEBUGGER | |
| 5996 INHIBIT_WARNING_ISSUE | |
| 5997 INHIBIT_GC | |
| 5998 | |
| 5999 #### The following five flags are defined, but unimplemented: | |
| 6000 | |
| 6001 #define INHIBIT_EXISTING_CODING_SYSTEM_DELETION (1<<6) | |
| 6002 #define INHIBIT_EXISTING_CHARSET_DELETION (1<<7) | |
| 6003 #define INHIBIT_PERMANENT_DISPLAY_OBJECT_CREATION (1<<8) | |
| 6004 #define INHIBIT_CODING_SYSTEM_CREATION (1<<9) | |
| 6005 #define INHIBIT_CHARSET_CREATION (1<<10) | |
| 6006 | |
| 6007 FLAGS containing CALL_WITH_SUSPENDED_ERRORS is a sign that | |
| 6008 call_with_suspended_errors() was invoked. This exists only for | |
| 6009 debugging purposes -- often we want to break when a signal happens, | |
| 6010 but ignore signals from call_with_suspended_errors(), because they | |
| 6011 occur often and for legitimate reasons. | |
| 6012 | |
| 6013 If PROBLEM is non-zero, it should be a pointer to a structure into | |
| 6014 which exact information about any occurring problems (either an | |
| 6015 error or an attempted throw past this boundary). | |
| 6016 | |
| 6017 If a problem occurred and aborted operation (error, quit, or | |
| 6018 invalid throw), Qunbound is returned. Otherwise the return value | |
| 6019 from the call to (*fun) (arg) is returned. */ | |
| 6020 | |
| 6021 Lisp_Object | |
| 6022 call_trapping_problems (Lisp_Object warning_class, | |
| 867 | 6023 const CIbyte *warning_string, |
| 853 | 6024 int flags, |
| 6025 struct call_trapping_problems_result *problem, | |
| 6026 Lisp_Object (*fun) (void *), | |
| 6027 void *arg) | |
| 6028 { | |
| 1318 | 6029 int speccount = specpdl_depth (); |
| 853 | 6030 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; |
| 6031 struct call_trapping_problems package; | |
| 1333 | 6032 struct call_trapping_problems_result real_problem; |
| 2532 | 6033 Lisp_Object opaque, thrown_tag, tem, thrown_backtrace; |
| 853 | 6034 int thrown = 0; |
| 6035 | |
| 6036 assert (SYMBOLP (warning_class)); /* sanity-check */ | |
| 6037 assert (!NILP (warning_class)); | |
| 6038 | |
| 6039 flags ^= INTERNAL_INHIBIT_ERRORS | INTERNAL_INHIBIT_THROWS; | |
| 6040 | |
| 6041 package.warning_class = warning_class; | |
| 6042 package.warning_string = warning_string; | |
| 6043 package.fun = fun; | |
| 6044 package.arg = arg; | |
| 6045 package.catchtag = | |
| 6046 flags & INTERNAL_INHIBIT_THROWS ? Vcatch_everything_tag : | |
| 6047 flags & INTERNAL_INHIBIT_ERRORS ? make_opaque_ptr (0) : | |
| 6048 Qnil; | |
| 6049 package.error_conditions = Qnil; | |
| 6050 package.data = Qnil; | |
| 6051 package.backtrace = Qnil; | |
| 6052 | |
| 1318 | 6053 flags = set_trapping_problems_flags (flags); |
| 853 | 6054 |
| 6055 if (flags & (INTERNAL_INHIBIT_THROWS | INTERNAL_INHIBIT_ERRORS)) | |
| 6056 opaque = make_opaque_ptr (&package); | |
| 6057 else | |
| 6058 opaque = Qnil; | |
| 6059 | |
| 6060 GCPRO5 (package.catchtag, package.error_conditions, package.data, | |
| 6061 package.backtrace, opaque); | |
| 6062 | |
| 6063 if (flags & INTERNAL_INHIBIT_ERRORS) | |
| 6064 /* We need a catch so that our condition-handler can throw back here | |
| 6065 after printing the warning. (We print the warning in the stack | |
| 6066 context of the error, so we can get a backtrace.) */ | |
| 6067 tem = internal_catch (package.catchtag, call_trapping_problems_1, opaque, | |
| 2532 | 6068 &thrown, &thrown_tag, &thrown_backtrace); |
| 853 | 6069 else if (flags & INTERNAL_INHIBIT_THROWS) |
| 6070 /* We skip over the first wrapper, which traps errors. */ | |
| 6071 tem = internal_catch (package.catchtag, call_trapping_problems_2, opaque, | |
| 2532 | 6072 &thrown, &thrown_tag, &thrown_backtrace); |
| 853 | 6073 else |
| 6074 /* Nothing special. */ | |
| 6075 tem = (fun) (arg); | |
| 6076 | |
| 1333 | 6077 if (!problem) |
| 6078 problem = &real_problem; | |
| 6079 | |
| 6080 if (!thrown) | |
| 853 | 6081 { |
| 1333 | 6082 problem->caught_error = 0; |
| 6083 problem->caught_throw = 0; | |
| 6084 problem->error_conditions = Qnil; | |
| 6085 problem->data = Qnil; | |
| 6086 problem->backtrace = Qnil; | |
| 6087 problem->thrown_tag = Qnil; | |
| 6088 problem->thrown_value = Qnil; | |
| 853 | 6089 } |
| 1333 | 6090 else if (EQ (thrown_tag, package.catchtag)) |
| 853 | 6091 { |
| 1333 | 6092 problem->caught_error = 1; |
| 6093 problem->caught_throw = 0; | |
| 6094 problem->error_conditions = package.error_conditions; | |
| 6095 problem->data = package.data; | |
| 6096 problem->backtrace = package.backtrace; | |
| 6097 problem->thrown_tag = Qnil; | |
| 6098 problem->thrown_value = Qnil; | |
| 853 | 6099 } |
| 1333 | 6100 else |
| 6101 { | |
| 6102 problem->caught_error = 0; | |
| 6103 problem->caught_throw = 1; | |
| 6104 problem->error_conditions = Qnil; | |
| 6105 problem->data = Qnil; | |
| 2532 | 6106 problem->backtrace = thrown_backtrace; |
| 1333 | 6107 problem->thrown_tag = thrown_tag; |
| 6108 problem->thrown_value = tem; | |
| 6109 } | |
| 6110 | |
| 6111 if (!(flags & INHIBIT_WARNING_ISSUE) && !(flags & POSTPONE_WARNING_ISSUE)) | |
| 6112 issue_call_trapping_problems_warning (warning_class, warning_string, | |
| 6113 problem); | |
| 853 | 6114 |
| 6115 if (!NILP (package.catchtag) && | |
| 6116 !EQ (package.catchtag, Vcatch_everything_tag)) | |
| 6117 free_opaque_ptr (package.catchtag); | |
| 6118 | |
| 6119 if (!NILP (opaque)) | |
| 6120 free_opaque_ptr (opaque); | |
| 6121 | |
| 6122 unbind_to (speccount); | |
| 6123 RETURN_UNGCPRO (thrown ? Qunbound : tem); | |
| 6124 } | |
| 6125 | |
| 6126 struct va_call_trapping_problems | |
| 6127 { | |
| 6128 lisp_fn_t fun; | |
| 6129 int nargs; | |
| 6130 Lisp_Object *args; | |
| 6131 }; | |
| 6132 | |
| 6133 static Lisp_Object | |
| 6134 va_call_trapping_problems_1 (void *ai_mi_madre) | |
| 6135 { | |
| 6136 struct va_call_trapping_problems *ai_no_corrida = | |
| 6137 (struct va_call_trapping_problems *) ai_mi_madre; | |
| 6138 Lisp_Object pegar_no_bumbum; | |
| 6139 | |
| 6140 PRIMITIVE_FUNCALL (pegar_no_bumbum, ai_no_corrida->fun, | |
| 6141 ai_no_corrida->args, ai_no_corrida->nargs); | |
| 6142 return pegar_no_bumbum; | |
| 6143 } | |
| 6144 | |
| 6145 /* #### document me. */ | |
| 6146 | |
| 6147 Lisp_Object | |
| 6148 va_call_trapping_problems (Lisp_Object warning_class, | |
| 867 | 6149 const CIbyte *warning_string, |
| 853 | 6150 int flags, |
| 6151 struct call_trapping_problems_result *problem, | |
| 6152 lisp_fn_t fun, int nargs, ...) | |
| 6153 { | |
| 6154 va_list vargs; | |
| 6155 Lisp_Object args[20]; | |
| 6156 int i; | |
| 6157 struct va_call_trapping_problems fazer_invocacao_atrapalhando_problemas; | |
| 6158 struct gcpro gcpro1; | |
| 6159 | |
| 6160 assert (nargs >= 0 && nargs < 20); | |
| 6161 | |
| 6162 va_start (vargs, nargs); | |
| 6163 for (i = 0; i < nargs; i++) | |
| 6164 args[i] = va_arg (vargs, Lisp_Object); | |
| 6165 va_end (vargs); | |
| 6166 | |
| 6167 fazer_invocacao_atrapalhando_problemas.fun = fun; | |
| 6168 fazer_invocacao_atrapalhando_problemas.nargs = nargs; | |
| 6169 fazer_invocacao_atrapalhando_problemas.args = args; | |
| 6170 | |
| 6171 GCPRO1_ARRAY (args, nargs); | |
| 6172 RETURN_UNGCPRO | |
| 6173 (call_trapping_problems | |
| 6174 (warning_class, warning_string, flags, problem, | |
| 6175 va_call_trapping_problems_1, &fazer_invocacao_atrapalhando_problemas)); | |
| 6176 } | |
| 6177 | |
| 6178 /* this is an older interface, barely different from | |
| 6179 va_call_trapping_problems. | |
| 6180 | |
| 6181 #### eliminate this or at least merge the ERROR_BEHAVIOR stuff into | |
| 6182 va_call_trapping_problems(). */ | |
| 6183 | |
| 6184 Lisp_Object | |
| 6185 call_with_suspended_errors (lisp_fn_t fun, Lisp_Object retval, | |
| 1204 | 6186 Lisp_Object class_, Error_Behavior errb, |
| 853 | 6187 int nargs, ...) |
| 6188 { | |
| 6189 va_list vargs; | |
| 6190 Lisp_Object args[20]; | |
| 6191 int i; | |
| 6192 struct va_call_trapping_problems fazer_invocacao_atrapalhando_problemas; | |
| 6193 int flags; | |
| 6194 struct gcpro gcpro1; | |
| 6195 | |
| 1204 | 6196 assert (SYMBOLP (class_)); /* sanity-check */ |
| 6197 assert (!NILP (class_)); | |
| 853 | 6198 assert (nargs >= 0 && nargs < 20); |
| 6199 | |
| 6200 va_start (vargs, nargs); | |
| 6201 for (i = 0; i < nargs; i++) | |
| 6202 args[i] = va_arg (vargs, Lisp_Object); | |
| 6203 va_end (vargs); | |
| 6204 | |
| 6205 /* If error-checking is not disabled, just call the function. */ | |
| 6206 | |
| 6207 if (ERRB_EQ (errb, ERROR_ME)) | |
| 6208 { | |
| 6209 Lisp_Object val; | |
| 6210 PRIMITIVE_FUNCALL (val, fun, args, nargs); | |
| 6211 return val; | |
| 6212 } | |
| 6213 | |
| 6214 if (ERRB_EQ (errb, ERROR_ME_NOT)) /* person wants no warnings */ | |
| 6215 flags = INHIBIT_WARNING_ISSUE | INHIBIT_ENTERING_DEBUGGER; | |
| 6216 else if (ERRB_EQ (errb, ERROR_ME_DEBUG_WARN)) | |
| 6217 flags = ISSUE_WARNINGS_AT_DEBUG_LEVEL | INHIBIT_ENTERING_DEBUGGER; | |
| 6218 else | |
| 6219 { | |
| 6220 assert (ERRB_EQ (errb, ERROR_ME_WARN)); | |
| 6221 flags = INHIBIT_ENTERING_DEBUGGER; | |
| 6222 } | |
| 6223 | |
| 6224 flags |= CALL_WITH_SUSPENDED_ERRORS; | |
| 6225 | |
| 6226 fazer_invocacao_atrapalhando_problemas.fun = fun; | |
| 6227 fazer_invocacao_atrapalhando_problemas.nargs = nargs; | |
| 6228 fazer_invocacao_atrapalhando_problemas.args = args; | |
| 6229 | |
| 6230 GCPRO1_ARRAY (args, nargs); | |
| 6231 { | |
| 6232 Lisp_Object its_way_too_goddamn_late = | |
| 6233 call_trapping_problems | |
| 1204 | 6234 (class_, 0, flags, 0, va_call_trapping_problems_1, |
| 853 | 6235 &fazer_invocacao_atrapalhando_problemas); |
| 6236 UNGCPRO; | |
| 6237 if (UNBOUNDP (its_way_too_goddamn_late)) | |
| 6238 return retval; | |
| 6239 else | |
| 6240 return its_way_too_goddamn_late; | |
| 6241 } | |
| 6242 } | |
| 6243 | |
| 6244 struct calln_trapping_problems | |
| 6245 { | |
| 6246 int nargs; | |
| 6247 Lisp_Object *args; | |
| 6248 }; | |
| 6249 | |
| 6250 static Lisp_Object | |
| 6251 calln_trapping_problems_1 (void *puta) | |
| 6252 { | |
| 6253 struct calln_trapping_problems *p = (struct calln_trapping_problems *) puta; | |
| 6254 | |
| 6255 return Ffuncall (p->nargs, p->args); | |
| 428 | 6256 } |
| 6257 | |
| 6258 static Lisp_Object | |
| 853 | 6259 calln_trapping_problems (Lisp_Object warning_class, |
| 867 | 6260 const CIbyte *warning_string, int flags, |
| 853 | 6261 struct call_trapping_problems_result *problem, |
| 6262 int nargs, Lisp_Object *args) | |
| 6263 { | |
| 6264 struct calln_trapping_problems foo; | |
| 6265 struct gcpro gcpro1; | |
| 6266 | |
| 6267 if (SYMBOLP (args[0])) | |
| 6268 { | |
| 6269 Lisp_Object tem = XSYMBOL (args[0])->function; | |
| 6270 if (NILP (tem) || UNBOUNDP (tem)) | |
| 6271 { | |
| 6272 if (problem) | |
| 6273 { | |
| 6274 problem->caught_error = 0; | |
| 6275 problem->caught_throw = 0; | |
| 6276 problem->error_conditions = Qnil; | |
| 6277 problem->data = Qnil; | |
| 6278 problem->backtrace = Qnil; | |
| 6279 problem->thrown_tag = Qnil; | |
| 6280 problem->thrown_value = Qnil; | |
| 6281 } | |
| 6282 return Qnil; | |
| 6283 } | |
| 6284 } | |
| 6285 | |
| 6286 foo.nargs = nargs; | |
| 6287 foo.args = args; | |
| 6288 | |
| 6289 GCPRO1_ARRAY (args, nargs); | |
| 6290 RETURN_UNGCPRO (call_trapping_problems (warning_class, warning_string, | |
| 6291 flags, problem, | |
| 6292 calln_trapping_problems_1, | |
| 6293 &foo)); | |
| 6294 } | |
| 6295 | |
| 6296 /* #### fix these functions to follow the calling convention of | |
| 6297 call_trapping_problems! */ | |
| 6298 | |
| 6299 Lisp_Object | |
| 867 | 6300 call0_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6301 int flags) |
| 6302 { | |
| 6303 return calln_trapping_problems (Qerror, warning_string, flags, 0, 1, | |
| 6304 &function); | |
| 428 | 6305 } |
| 6306 | |
| 6307 Lisp_Object | |
| 867 | 6308 call1_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6309 Lisp_Object object, int flags) |
| 6310 { | |
| 6311 Lisp_Object args[2]; | |
| 6312 | |
| 6313 args[0] = function; | |
| 6314 args[1] = object; | |
| 6315 | |
| 6316 return calln_trapping_problems (Qerror, warning_string, flags, 0, 2, | |
| 6317 args); | |
| 6318 } | |
| 6319 | |
| 6320 Lisp_Object | |
| 867 | 6321 call2_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6322 Lisp_Object object1, Lisp_Object object2, |
| 6323 int flags) | |
| 6324 { | |
| 6325 Lisp_Object args[3]; | |
| 6326 | |
| 6327 args[0] = function; | |
| 6328 args[1] = object1; | |
| 6329 args[2] = object2; | |
| 6330 | |
| 6331 return calln_trapping_problems (Qerror, warning_string, flags, 0, 3, | |
| 6332 args); | |
| 6333 } | |
| 6334 | |
| 6335 Lisp_Object | |
| 867 | 6336 call3_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6337 Lisp_Object object1, Lisp_Object object2, |
| 6338 Lisp_Object object3, int flags) | |
| 6339 { | |
| 6340 Lisp_Object args[4]; | |
| 6341 | |
| 6342 args[0] = function; | |
| 6343 args[1] = object1; | |
| 6344 args[2] = object2; | |
| 6345 args[3] = object3; | |
| 6346 | |
| 6347 return calln_trapping_problems (Qerror, warning_string, flags, 0, 4, | |
| 6348 args); | |
| 6349 } | |
| 6350 | |
| 6351 Lisp_Object | |
| 867 | 6352 call4_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6353 Lisp_Object object1, Lisp_Object object2, |
| 6354 Lisp_Object object3, Lisp_Object object4, | |
| 6355 int flags) | |
| 6356 { | |
| 6357 Lisp_Object args[5]; | |
| 6358 | |
| 6359 args[0] = function; | |
| 6360 args[1] = object1; | |
| 6361 args[2] = object2; | |
| 6362 args[3] = object3; | |
| 6363 args[4] = object4; | |
| 6364 | |
| 6365 return calln_trapping_problems (Qerror, warning_string, flags, 0, 5, | |
| 6366 args); | |
| 6367 } | |
| 6368 | |
| 6369 Lisp_Object | |
| 867 | 6370 call5_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6371 Lisp_Object object1, Lisp_Object object2, |
| 6372 Lisp_Object object3, Lisp_Object object4, | |
| 6373 Lisp_Object object5, int flags) | |
| 6374 { | |
| 6375 Lisp_Object args[6]; | |
| 6376 | |
| 6377 args[0] = function; | |
| 6378 args[1] = object1; | |
| 6379 args[2] = object2; | |
| 6380 args[3] = object3; | |
| 6381 args[4] = object4; | |
| 6382 args[5] = object5; | |
| 6383 | |
| 6384 return calln_trapping_problems (Qerror, warning_string, flags, 0, 6, | |
| 6385 args); | |
| 6386 } | |
| 6387 | |
| 6388 struct eval_in_buffer_trapping_problems | |
| 6389 { | |
| 6390 struct buffer *buf; | |
| 6391 Lisp_Object form; | |
| 6392 }; | |
| 6393 | |
| 6394 static Lisp_Object | |
| 6395 eval_in_buffer_trapping_problems_1 (void *arg) | |
| 6396 { | |
| 6397 struct eval_in_buffer_trapping_problems *p = | |
| 6398 (struct eval_in_buffer_trapping_problems *) arg; | |
| 6399 | |
| 6400 return eval_in_buffer (p->buf, p->form); | |
| 6401 } | |
| 6402 | |
| 6403 /* #### fix these functions to follow the calling convention of | |
| 6404 call_trapping_problems! */ | |
| 6405 | |
| 6406 Lisp_Object | |
| 867 | 6407 eval_in_buffer_trapping_problems (const CIbyte *warning_string, |
| 853 | 6408 struct buffer *buf, Lisp_Object form, |
| 6409 int flags) | |
| 6410 { | |
| 6411 struct eval_in_buffer_trapping_problems p; | |
| 6412 Lisp_Object buffer = wrap_buffer (buf); | |
| 428 | 6413 struct gcpro gcpro1, gcpro2; |
| 6414 | |
| 853 | 6415 GCPRO2 (buffer, form); |
| 6416 p.buf = buf; | |
| 6417 p.form = form; | |
| 6418 RETURN_UNGCPRO (call_trapping_problems (Qerror, warning_string, flags, 0, | |
| 6419 eval_in_buffer_trapping_problems_1, | |
| 6420 &p)); | |
| 6421 } | |
| 6422 | |
| 6423 Lisp_Object | |
| 1333 | 6424 run_hook_trapping_problems (Lisp_Object warning_class, |
| 853 | 6425 Lisp_Object hook_symbol, |
| 6426 int flags) | |
| 6427 { | |
| 1333 | 6428 return run_hook_with_args_trapping_problems (warning_class, 1, &hook_symbol, |
| 853 | 6429 RUN_HOOKS_TO_COMPLETION, |
| 6430 flags); | |
| 428 | 6431 } |
| 6432 | |
| 6433 static Lisp_Object | |
| 853 | 6434 safe_run_hook_trapping_problems_1 (void *puta) |
| 6435 { | |
| 5013 | 6436 Lisp_Object hook = GET_LISP_FROM_VOID (puta); |
| 853 | 6437 |
| 6438 run_hook (hook); | |
| 428 | 6439 return Qnil; |
| 6440 } | |
| 6441 | |
| 853 | 6442 /* Same as run_hook_trapping_problems() but also set the hook to nil |
| 6443 if an error occurs (but not a quit). */ | |
| 6444 | |
| 428 | 6445 Lisp_Object |
| 1333 | 6446 safe_run_hook_trapping_problems (Lisp_Object warning_class, |
| 6447 Lisp_Object hook_symbol, int flags) | |
| 853 | 6448 { |
| 428 | 6449 Lisp_Object tem; |
| 853 | 6450 struct gcpro gcpro1, gcpro2; |
| 6451 struct call_trapping_problems_result prob; | |
| 428 | 6452 |
| 6453 if (!initialized || preparing_for_armageddon) | |
| 6454 return Qnil; | |
| 6455 tem = find_symbol_value (hook_symbol); | |
| 6456 if (NILP (tem) || UNBOUNDP (tem)) | |
| 6457 return Qnil; | |
| 6458 | |
| 853 | 6459 GCPRO2 (hook_symbol, tem); |
| 1333 | 6460 tem = call_trapping_problems (Qerror, NULL, |
| 6461 flags | POSTPONE_WARNING_ISSUE, | |
| 853 | 6462 &prob, |
| 6463 safe_run_hook_trapping_problems_1, | |
| 5013 | 6464 STORE_LISP_IN_VOID (hook_symbol)); |
| 1333 | 6465 { |
| 6466 Lisp_Object hook_name = XSYMBOL_NAME (hook_symbol); | |
| 6467 Ibyte *hook_str = XSTRING_DATA (hook_name); | |
| 6468 Ibyte *err = alloca_ibytes (XSTRING_LENGTH (hook_name) + 100); | |
| 6469 | |
| 6470 if (prob.caught_throw || (prob.caught_error && !EQ (prob.error_conditions, | |
| 6471 Qquit))) | |
| 6472 { | |
| 6473 Fset (hook_symbol, Qnil); | |
| 6474 qxesprintf (err, "Error in `%s' (resetting to nil)", hook_str); | |
| 6475 } | |
| 6476 else | |
| 6477 qxesprintf (err, "Quit in `%s'", hook_str); | |
| 6478 | |
| 6479 | |
| 6480 issue_call_trapping_problems_warning (warning_class, (CIbyte *) err, | |
| 6481 &prob); | |
| 6482 } | |
| 6483 | |
| 6484 UNGCPRO; | |
| 6485 return tem; | |
| 853 | 6486 } |
| 6487 | |
| 6488 struct run_hook_with_args_in_buffer_trapping_problems | |
| 6489 { | |
| 6490 struct buffer *buf; | |
| 6491 int nargs; | |
| 6492 Lisp_Object *args; | |
| 6493 enum run_hooks_condition cond; | |
| 6494 }; | |
| 6495 | |
| 6496 static Lisp_Object | |
| 6497 run_hook_with_args_in_buffer_trapping_problems_1 (void *puta) | |
| 6498 { | |
| 6499 struct run_hook_with_args_in_buffer_trapping_problems *porra = | |
| 6500 (struct run_hook_with_args_in_buffer_trapping_problems *) puta; | |
| 6501 | |
| 6502 return run_hook_with_args_in_buffer (porra->buf, porra->nargs, porra->args, | |
| 6503 porra->cond); | |
| 6504 } | |
| 6505 | |
| 6506 /* #### fix these functions to follow the calling convention of | |
| 6507 call_trapping_problems! */ | |
| 428 | 6508 |
| 6509 Lisp_Object | |
| 1333 | 6510 run_hook_with_args_in_buffer_trapping_problems (Lisp_Object warning_class, |
| 853 | 6511 struct buffer *buf, int nargs, |
| 6512 Lisp_Object *args, | |
| 6513 enum run_hooks_condition cond, | |
| 6514 int flags) | |
| 6515 { | |
| 6516 Lisp_Object sym, val, ret; | |
| 6517 struct run_hook_with_args_in_buffer_trapping_problems diversity_and_distrust; | |
| 428 | 6518 struct gcpro gcpro1; |
| 1333 | 6519 Lisp_Object hook_name; |
| 6520 Ibyte *hook_str; | |
| 6521 Ibyte *err; | |
| 428 | 6522 |
| 6523 if (!initialized || preparing_for_armageddon) | |
| 853 | 6524 /* We need to bail out of here pronto. */ |
| 428 | 6525 return Qnil; |
| 6526 | |
| 853 | 6527 GCPRO1_ARRAY (args, nargs); |
| 6528 | |
| 6529 sym = args[0]; | |
| 6530 val = symbol_value_in_buffer (sym, wrap_buffer (buf)); | |
| 6531 ret = (cond == RUN_HOOKS_UNTIL_FAILURE ? Qt : Qnil); | |
| 6532 | |
| 6533 if (UNBOUNDP (val) || NILP (val)) | |
| 6534 RETURN_UNGCPRO (ret); | |
| 6535 | |
| 6536 diversity_and_distrust.buf = buf; | |
| 6537 diversity_and_distrust.nargs = nargs; | |
| 6538 diversity_and_distrust.args = args; | |
| 6539 diversity_and_distrust.cond = cond; | |
| 6540 | |
| 1333 | 6541 hook_name = XSYMBOL_NAME (args[0]); |
| 6542 hook_str = XSTRING_DATA (hook_name); | |
| 6543 err = alloca_ibytes (XSTRING_LENGTH (hook_name) + 100); | |
| 6544 qxesprintf (err, "Error in `%s'", hook_str); | |
| 853 | 6545 RETURN_UNGCPRO |
| 6546 (call_trapping_problems | |
| 1333 | 6547 (warning_class, (CIbyte *) err, flags, 0, |
| 853 | 6548 run_hook_with_args_in_buffer_trapping_problems_1, |
| 6549 &diversity_and_distrust)); | |
| 428 | 6550 } |
| 6551 | |
| 6552 Lisp_Object | |
| 1333 | 6553 run_hook_with_args_trapping_problems (Lisp_Object warning_class, |
| 853 | 6554 int nargs, |
| 6555 Lisp_Object *args, | |
| 6556 enum run_hooks_condition cond, | |
| 6557 int flags) | |
| 6558 { | |
| 6559 return run_hook_with_args_in_buffer_trapping_problems | |
| 1333 | 6560 (warning_class, current_buffer, nargs, args, cond, flags); |
| 428 | 6561 } |
| 6562 | |
| 6563 Lisp_Object | |
| 1333 | 6564 va_run_hook_with_args_trapping_problems (Lisp_Object warning_class, |
| 853 | 6565 Lisp_Object hook_var, |
| 6566 int nargs, ...) | |
| 6567 { | |
| 6568 /* This function can GC */ | |
| 6569 struct gcpro gcpro1; | |
| 6570 int i; | |
| 6571 va_list vargs; | |
| 6572 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs); | |
| 6573 int flags; | |
| 6574 | |
| 6575 va_start (vargs, nargs); | |
| 6576 funcall_args[0] = hook_var; | |
| 6577 for (i = 0; i < nargs; i++) | |
| 6578 funcall_args[i + 1] = va_arg (vargs, Lisp_Object); | |
| 6579 flags = va_arg (vargs, int); | |
| 6580 va_end (vargs); | |
| 6581 | |
| 6582 GCPRO1_ARRAY (funcall_args, nargs + 1); | |
| 6583 RETURN_UNGCPRO (run_hook_with_args_in_buffer_trapping_problems | |
| 1333 | 6584 (warning_class, current_buffer, nargs + 1, funcall_args, |
| 853 | 6585 RUN_HOOKS_TO_COMPLETION, flags)); |
| 428 | 6586 } |
| 6587 | |
| 6588 Lisp_Object | |
| 1333 | 6589 va_run_hook_with_args_in_buffer_trapping_problems (Lisp_Object warning_class, |
| 853 | 6590 struct buffer *buf, |
| 6591 Lisp_Object hook_var, | |
| 6592 int nargs, ...) | |
| 6593 { | |
| 6594 /* This function can GC */ | |
| 6595 struct gcpro gcpro1; | |
| 6596 int i; | |
| 6597 va_list vargs; | |
| 6598 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs); | |
| 6599 int flags; | |
| 6600 | |
| 6601 va_start (vargs, nargs); | |
| 6602 funcall_args[0] = hook_var; | |
| 6603 for (i = 0; i < nargs; i++) | |
| 6604 funcall_args[i + 1] = va_arg (vargs, Lisp_Object); | |
| 6605 flags = va_arg (vargs, int); | |
| 6606 va_end (vargs); | |
| 6607 | |
| 6608 GCPRO1_ARRAY (funcall_args, nargs + 1); | |
| 6609 RETURN_UNGCPRO (run_hook_with_args_in_buffer_trapping_problems | |
| 1333 | 6610 (warning_class, buf, nargs + 1, funcall_args, |
| 853 | 6611 RUN_HOOKS_TO_COMPLETION, flags)); |
| 428 | 6612 } |
| 6613 | |
| 6614 | |
| 6615 /************************************************************************/ | |
| 6616 /* The special binding stack */ | |
| 771 | 6617 /* Most C code should simply use specbind() and unbind_to_1(). */ |
| 428 | 6618 /* When performance is critical, use the macros in backtrace.h. */ |
| 6619 /************************************************************************/ | |
| 6620 | |
| 6621 #define min_max_specpdl_size 400 | |
| 6622 | |
| 6623 void | |
| 647 | 6624 grow_specpdl (EMACS_INT reserved) |
| 6625 { | |
| 6626 EMACS_INT size_needed = specpdl_depth() + reserved; | |
| 428 | 6627 if (size_needed >= max_specpdl_size) |
| 6628 { | |
| 6629 if (max_specpdl_size < min_max_specpdl_size) | |
| 6630 max_specpdl_size = min_max_specpdl_size; | |
| 6631 if (size_needed >= max_specpdl_size) | |
| 6632 { | |
| 1951 | 6633 /* Leave room for some specpdl in the debugger. */ |
| 6634 max_specpdl_size = size_needed + 100; | |
| 6635 if (max_specpdl_size > specpdl_size) | |
| 6636 { | |
| 6637 specpdl_size = max_specpdl_size; | |
| 6638 XREALLOC_ARRAY (specpdl, struct specbinding, specpdl_size); | |
| 6639 specpdl_ptr = specpdl + specpdl_depth(); | |
| 6640 } | |
| 563 | 6641 signal_continuable_error |
| 6642 (Qstack_overflow, | |
| 6643 "Variable binding depth exceeds max-specpdl-size", Qunbound); | |
| 428 | 6644 } |
| 6645 } | |
| 6646 while (specpdl_size < size_needed) | |
| 6647 { | |
| 6648 specpdl_size *= 2; | |
| 6649 if (specpdl_size > max_specpdl_size) | |
| 6650 specpdl_size = max_specpdl_size; | |
| 6651 } | |
| 6652 XREALLOC_ARRAY (specpdl, struct specbinding, specpdl_size); | |
| 6653 specpdl_ptr = specpdl + specpdl_depth(); | |
| 853 | 6654 check_specbind_stack_sanity (); |
| 428 | 6655 } |
| 6656 | |
| 6657 | |
| 6658 /* Handle unbinding buffer-local variables */ | |
| 6659 static Lisp_Object | |
| 6660 specbind_unwind_local (Lisp_Object ovalue) | |
| 6661 { | |
| 6662 Lisp_Object current = Fcurrent_buffer (); | |
| 6663 Lisp_Object symbol = specpdl_ptr->symbol; | |
| 853 | 6664 Lisp_Object victim = ovalue; |
| 6665 Lisp_Object buf = get_buffer (XCAR (victim), 0); | |
| 6666 ovalue = XCDR (victim); | |
| 428 | 6667 |
| 6668 free_cons (victim); | |
| 6669 | |
| 6670 if (NILP (buf)) | |
| 6671 { | |
| 6672 /* Deleted buffer -- do nothing */ | |
| 6673 } | |
| 6674 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buf)) == 0) | |
| 6675 { | |
| 6676 /* Was buffer-local when binding was made, now no longer is. | |
| 6677 * (kill-local-variable can do this.) | |
| 6678 * Do nothing in this case. | |
| 6679 */ | |
| 6680 } | |
| 6681 else if (EQ (buf, current)) | |
| 6682 Fset (symbol, ovalue); | |
| 6683 else | |
| 6684 { | |
| 6685 /* Urk! Somebody switched buffers */ | |
| 6686 struct gcpro gcpro1; | |
| 6687 GCPRO1 (current); | |
| 6688 Fset_buffer (buf); | |
| 6689 Fset (symbol, ovalue); | |
| 6690 Fset_buffer (current); | |
| 6691 UNGCPRO; | |
| 6692 } | |
| 6693 return symbol; | |
| 6694 } | |
| 6695 | |
| 6696 static Lisp_Object | |
| 6697 specbind_unwind_wasnt_local (Lisp_Object buffer) | |
| 6698 { | |
| 6699 Lisp_Object current = Fcurrent_buffer (); | |
| 6700 Lisp_Object symbol = specpdl_ptr->symbol; | |
| 6701 | |
| 6702 buffer = get_buffer (buffer, 0); | |
| 6703 if (NILP (buffer)) | |
| 6704 { | |
| 6705 /* Deleted buffer -- do nothing */ | |
| 6706 } | |
| 6707 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buffer)) == 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 (buffer, current)) | |
| 6715 Fkill_local_variable (symbol); | |
| 6716 else | |
| 6717 { | |
| 6718 /* Urk! Somebody switched buffers */ | |
| 6719 struct gcpro gcpro1; | |
| 6720 GCPRO1 (current); | |
| 6721 Fset_buffer (buffer); | |
| 6722 Fkill_local_variable (symbol); | |
| 6723 Fset_buffer (current); | |
| 6724 UNGCPRO; | |
| 6725 } | |
| 6726 return symbol; | |
| 6727 } | |
| 6728 | |
| 6729 | |
| 6730 void | |
| 6731 specbind (Lisp_Object symbol, Lisp_Object value) | |
| 6732 { | |
| 6733 SPECBIND (symbol, value); | |
| 853 | 6734 |
| 6735 check_specbind_stack_sanity (); | |
| 428 | 6736 } |
| 6737 | |
| 6738 void | |
| 6739 specbind_magic (Lisp_Object symbol, Lisp_Object value) | |
| 6740 { | |
| 6741 int buffer_local = | |
| 6742 symbol_value_buffer_local_info (symbol, current_buffer); | |
| 6743 | |
| 6744 if (buffer_local == 0) | |
| 6745 { | |
| 6746 specpdl_ptr->old_value = find_symbol_value (symbol); | |
| 771 | 6747 specpdl_ptr->func = 0; /* Handled specially by unbind_to_1 */ |
| 428 | 6748 } |
| 6749 else if (buffer_local > 0) | |
| 6750 { | |
| 6751 /* Already buffer-local */ | |
| 6752 specpdl_ptr->old_value = noseeum_cons (Fcurrent_buffer (), | |
| 6753 find_symbol_value (symbol)); | |
| 6754 specpdl_ptr->func = specbind_unwind_local; | |
| 6755 } | |
| 6756 else | |
| 6757 { | |
| 6758 /* About to become buffer-local */ | |
| 6759 specpdl_ptr->old_value = Fcurrent_buffer (); | |
| 6760 specpdl_ptr->func = specbind_unwind_wasnt_local; | |
| 6761 } | |
| 6762 | |
| 6763 specpdl_ptr->symbol = symbol; | |
| 6764 specpdl_ptr++; | |
| 6765 specpdl_depth_counter++; | |
| 6766 | |
| 6767 Fset (symbol, value); | |
| 853 | 6768 |
| 6769 check_specbind_stack_sanity (); | |
| 428 | 6770 } |
| 6771 | |
| 771 | 6772 /* Record an unwind-protect -- FUNCTION will be called with ARG no matter |
| 6773 whether a normal or non-local exit occurs. (You need to call unbind_to_1() | |
| 6774 before your function returns normally, passing in the integer returned | |
| 6775 by this function.) Note: As long as the unwind-protect exists, ARG is | |
| 6776 automatically GCPRO'd. The return value from FUNCTION is completely | |
| 6777 ignored. #### We should eliminate it entirely. */ | |
| 6778 | |
| 6779 int | |
| 428 | 6780 record_unwind_protect (Lisp_Object (*function) (Lisp_Object arg), |
| 6781 Lisp_Object arg) | |
| 6782 { | |
| 6783 SPECPDL_RESERVE (1); | |
| 6784 specpdl_ptr->func = function; | |
| 6785 specpdl_ptr->symbol = Qnil; | |
| 6786 specpdl_ptr->old_value = arg; | |
| 6787 specpdl_ptr++; | |
| 6788 specpdl_depth_counter++; | |
| 853 | 6789 check_specbind_stack_sanity (); |
| 771 | 6790 return specpdl_depth_counter - 1; |
| 6791 } | |
| 6792 | |
| 6793 static Lisp_Object | |
| 802 | 6794 restore_lisp_object (Lisp_Object cons) |
| 6795 { | |
| 5013 | 6796 Lisp_Object laddr = XCAR (cons); |
| 6797 Lisp_Object *addr = (Lisp_Object *) GET_VOID_FROM_LISP (laddr); | |
| 802 | 6798 *addr = XCDR (cons); |
| 853 | 6799 free_cons (cons); |
| 802 | 6800 return Qnil; |
| 6801 } | |
| 6802 | |
| 6803 /* Establish an unwind-protect which will restore the Lisp_Object pointed to | |
| 6804 by ADDR with the value VAL. */ | |
| 814 | 6805 static int |
| 802 | 6806 record_unwind_protect_restoring_lisp_object (Lisp_Object *addr, |
| 6807 Lisp_Object val) | |
| 6808 { | |
| 5013 | 6809 /* We use a cons rather than a malloc()ed structure because we want the |
| 6810 Lisp object to have garbage-collection protection */ | |
| 6811 Lisp_Object laddr = STORE_VOID_IN_LISP (addr); | |
| 802 | 6812 return record_unwind_protect (restore_lisp_object, |
| 5013 | 6813 noseeum_cons (laddr, val)); |
| 802 | 6814 } |
| 6815 | |
| 6816 /* Similar to specbind() but for any C variable whose value is a | |
| 6817 Lisp_Object. Sets up an unwind-protect to restore the variable | |
| 6818 pointed to by ADDR to its existing value, and then changes its | |
| 6819 value to NEWVAL. Returns the previous value of specpdl_depth(); | |
| 6820 pass this to unbind_to() after you are done. */ | |
| 6821 int | |
| 6822 internal_bind_lisp_object (Lisp_Object *addr, Lisp_Object newval) | |
| 6823 { | |
| 6824 int count = specpdl_depth (); | |
| 6825 record_unwind_protect_restoring_lisp_object (addr, *addr); | |
| 6826 *addr = newval; | |
| 6827 return count; | |
| 6828 } | |
| 6829 | |
| 5013 | 6830 struct restore_int |
| 6831 { | |
| 6832 int *addr; | |
| 802 | 6833 int val; |
| 5013 | 6834 }; |
| 6835 | |
| 6836 static Lisp_Object | |
| 6837 restore_int (Lisp_Object obj) | |
| 6838 { | |
| 6839 struct restore_int *ri = (struct restore_int *) GET_VOID_FROM_LISP (obj); | |
| 6840 *(ri->addr) = ri->val; | |
| 6841 xfree (ri); | |
| 802 | 6842 return Qnil; |
| 6843 } | |
| 6844 | |
| 6845 /* Establish an unwind-protect which will restore the int pointed to | |
| 6846 by ADDR with the value VAL. This function works correctly with | |
| 6847 all ints, even those that don't fit into a Lisp integer. */ | |
| 1333 | 6848 int |
| 802 | 6849 record_unwind_protect_restoring_int (int *addr, int val) |
| 6850 { | |
| 5013 | 6851 struct restore_int *ri = xnew (struct restore_int); |
| 6852 ri->addr = addr; | |
| 6853 ri->val = val; | |
| 6854 return record_unwind_protect (restore_int, STORE_VOID_IN_LISP (ri)); | |
| 802 | 6855 } |
| 6856 | |
| 6857 /* Similar to specbind() but for any C variable whose value is an int. | |
| 6858 Sets up an unwind-protect to restore the variable pointed to by | |
| 6859 ADDR to its existing value, and then changes its value to NEWVAL. | |
| 6860 Returns the previous value of specpdl_depth(); pass this to | |
| 6861 unbind_to() after you are done. This function works correctly with | |
| 6862 all ints, even those that don't fit into a Lisp integer. */ | |
| 6863 int | |
| 6864 internal_bind_int (int *addr, int newval) | |
| 6865 { | |
| 6866 int count = specpdl_depth (); | |
| 6867 record_unwind_protect_restoring_int (addr, *addr); | |
| 6868 *addr = newval; | |
| 6869 return count; | |
| 6870 } | |
| 6871 | |
| 6872 static Lisp_Object | |
| 771 | 6873 free_pointer (Lisp_Object opaque) |
| 6874 { | |
| 5013 | 6875 void *ptr = GET_VOID_FROM_LISP (opaque); |
| 6876 xfree (ptr); | |
| 771 | 6877 return Qnil; |
| 6878 } | |
| 6879 | |
| 6880 /* Establish an unwind-protect which will free the specified block. | |
| 6881 */ | |
| 6882 int | |
| 6883 record_unwind_protect_freeing (void *ptr) | |
| 6884 { | |
| 5013 | 6885 return record_unwind_protect (free_pointer, STORE_VOID_IN_LISP (ptr)); |
| 771 | 6886 } |
| 6887 | |
| 6888 static Lisp_Object | |
| 6889 free_dynarr (Lisp_Object opaque) | |
| 6890 { | |
| 5013 | 6891 Dynarr_free (GET_VOID_FROM_LISP (opaque)); |
| 771 | 6892 return Qnil; |
| 6893 } | |
| 6894 | |
| 6895 int | |
| 6896 record_unwind_protect_freeing_dynarr (void *ptr) | |
| 6897 { | |
| 5013 | 6898 return record_unwind_protect (free_dynarr, STORE_VOID_IN_LISP (ptr)); |
| 771 | 6899 } |
| 428 | 6900 |
| 6901 /* Unwind the stack till specpdl_depth() == COUNT. | |
| 6902 VALUE is not used, except that, purely as a convenience to the | |
| 771 | 6903 caller, it is protected from garbage-protection and returned. */ |
| 428 | 6904 Lisp_Object |
| 771 | 6905 unbind_to_1 (int count, Lisp_Object value) |
| 428 | 6906 { |
| 6907 UNBIND_TO_GCPRO (count, value); | |
| 853 | 6908 check_specbind_stack_sanity (); |
| 428 | 6909 return value; |
| 6910 } | |
| 6911 | |
| 6912 /* Don't call this directly. | |
| 6913 Only for use by UNBIND_TO* macros in backtrace.h */ | |
| 6914 void | |
| 6915 unbind_to_hairy (int count) | |
| 6916 { | |
| 442 | 6917 ++specpdl_ptr; |
| 6918 ++specpdl_depth_counter; | |
| 6919 | |
| 428 | 6920 while (specpdl_depth_counter != count) |
| 6921 { | |
| 1313 | 6922 Lisp_Object oquit = Qunbound; |
| 6923 | |
| 6924 /* Do this check BEFORE decrementing the values below, because once | |
| 6925 they're decremented, GC protection is lost on | |
| 6926 specpdl_ptr->old_value. */ | |
| 1322 | 6927 if (specpdl_ptr[-1].func == Fprogn) |
| 1313 | 6928 { |
| 6929 /* Allow QUIT within unwind-protect routines, but defer any | |
| 6930 existing QUIT until afterwards. Only do this, however, for | |
| 6931 unwind-protects established by Lisp code, not by C code | |
| 6932 (e.g. free_opaque_ptr() or something), because the act of | |
| 6933 checking for QUIT can cause all sorts of weird things to | |
| 6934 happen, since it churns the event loop -- redisplay, running | |
| 6935 Lisp, etc. Code should not have to worry about this just | |
| 6936 because of establishing an unwind-protect. */ | |
| 6937 check_quit (); /* make Vquit_flag accurate */ | |
| 6938 oquit = Vquit_flag; | |
| 6939 Vquit_flag = Qnil; | |
| 6940 } | |
| 6941 | |
| 428 | 6942 --specpdl_ptr; |
| 6943 --specpdl_depth_counter; | |
| 6944 | |
| 1313 | 6945 /* #### At this point, there is no GC protection on old_value. This |
| 6946 could be a real problem, depending on what unwind-protect function | |
| 6947 is called. It looks like it just so happens that the ones | |
| 6948 actually called don't have a problem with this, e.g. Fprogn. But | |
| 6949 we should look into fixing this. (Many unwind-protect functions | |
| 6950 free values. Is it a problem if freed values are | |
| 6951 GC-protected?) */ | |
| 428 | 6952 if (specpdl_ptr->func != 0) |
| 1313 | 6953 { |
| 6954 /* An unwind-protect */ | |
| 6955 (*specpdl_ptr->func) (specpdl_ptr->old_value); | |
| 6956 } | |
| 6957 | |
| 428 | 6958 else |
| 6959 { | |
| 6960 /* We checked symbol for validity when we specbound it, | |
| 6961 so only need to call Fset if symbol has magic value. */ | |
| 440 | 6962 Lisp_Symbol *sym = XSYMBOL (specpdl_ptr->symbol); |
| 428 | 6963 if (!SYMBOL_VALUE_MAGIC_P (sym->value)) |
| 6964 sym->value = specpdl_ptr->old_value; | |
| 6965 else | |
| 6966 Fset (specpdl_ptr->symbol, specpdl_ptr->old_value); | |
| 6967 } | |
| 6968 | |
| 6969 #if 0 /* martin */ | |
| 6970 #ifndef EXCEEDINGLY_QUESTIONABLE_CODE | |
| 6971 /* There should never be anything here for us to remove. | |
| 6972 If so, it indicates a logic error in Emacs. Catches | |
| 6973 should get removed when a throw or signal occurs, or | |
| 6974 when a catch or condition-case exits normally. But | |
| 6975 it's too dangerous to just remove this code. --ben */ | |
| 6976 | |
| 6977 /* Furthermore, this code is not in FSFmacs!!! | |
| 6978 Braino on mly's part? */ | |
| 6979 /* If we're unwound past the pdlcount of a catch frame, | |
| 6980 that catch can't possibly still be valid. */ | |
| 6981 while (catchlist && catchlist->pdlcount > specpdl_depth_counter) | |
| 6982 { | |
| 6983 catchlist = catchlist->next; | |
| 6984 /* Don't mess with gcprolist, backtrace_list here */ | |
| 6985 } | |
| 6986 #endif | |
| 6987 #endif | |
| 1313 | 6988 |
| 6989 if (!UNBOUNDP (oquit)) | |
| 6990 Vquit_flag = oquit; | |
| 428 | 6991 } |
| 853 | 6992 check_specbind_stack_sanity (); |
| 428 | 6993 } |
| 6994 | |
| 6995 | |
| 6996 | |
| 6997 /* Get the value of symbol's global binding, even if that binding is | |
| 6998 not now dynamically visible. May return Qunbound or magic values. */ | |
| 6999 | |
| 7000 Lisp_Object | |
| 7001 top_level_value (Lisp_Object symbol) | |
| 7002 { | |
| 7003 REGISTER struct specbinding *ptr = specpdl; | |
| 7004 | |
| 7005 CHECK_SYMBOL (symbol); | |
| 7006 for (; ptr != specpdl_ptr; ptr++) | |
| 7007 { | |
| 7008 if (EQ (ptr->symbol, symbol)) | |
| 7009 return ptr->old_value; | |
| 7010 } | |
| 7011 return XSYMBOL (symbol)->value; | |
| 7012 } | |
| 7013 | |
| 7014 #if 0 | |
| 7015 | |
| 7016 Lisp_Object | |
| 7017 top_level_set (Lisp_Object symbol, Lisp_Object newval) | |
| 7018 { | |
| 7019 REGISTER struct specbinding *ptr = specpdl; | |
| 7020 | |
| 7021 CHECK_SYMBOL (symbol); | |
| 7022 for (; ptr != specpdl_ptr; ptr++) | |
| 7023 { | |
| 7024 if (EQ (ptr->symbol, symbol)) | |
| 7025 { | |
| 7026 ptr->old_value = newval; | |
| 7027 return newval; | |
| 7028 } | |
| 7029 } | |
| 7030 return Fset (symbol, newval); | |
| 7031 } | |
| 7032 | |
| 7033 #endif /* 0 */ | |
| 7034 | |
| 7035 | |
| 7036 /************************************************************************/ | |
| 7037 /* Backtraces */ | |
| 7038 /************************************************************************/ | |
| 7039 | |
| 7040 DEFUN ("backtrace-debug", Fbacktrace_debug, 2, 2, 0, /* | |
| 7041 Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG. | |
| 7042 The debugger is entered when that frame exits, if the flag is non-nil. | |
| 7043 */ | |
| 7044 (level, flag)) | |
| 7045 { | |
| 7046 REGISTER struct backtrace *backlist = backtrace_list; | |
| 7047 REGISTER int i; | |
| 7048 | |
| 7049 CHECK_INT (level); | |
| 7050 | |
| 7051 for (i = 0; backlist && i < XINT (level); i++) | |
| 7052 { | |
| 7053 backlist = backlist->next; | |
| 7054 } | |
| 7055 | |
| 7056 if (backlist) | |
| 7057 backlist->debug_on_exit = !NILP (flag); | |
| 7058 | |
| 7059 return flag; | |
| 7060 } | |
| 7061 | |
| 7062 static void | |
| 7063 backtrace_specials (int speccount, int speclimit, Lisp_Object stream) | |
| 7064 { | |
| 7065 int printing_bindings = 0; | |
| 7066 | |
| 7067 for (; speccount > speclimit; speccount--) | |
| 7068 { | |
| 7069 if (specpdl[speccount - 1].func == 0 | |
| 7070 || specpdl[speccount - 1].func == specbind_unwind_local | |
| 7071 || specpdl[speccount - 1].func == specbind_unwind_wasnt_local) | |
| 7072 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7073 write_ascstring (stream, !printing_bindings ? " # bind (" : " "); |
| 428 | 7074 Fprin1 (specpdl[speccount - 1].symbol, stream); |
| 7075 printing_bindings = 1; | |
| 7076 } | |
| 7077 else | |
| 7078 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7079 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
|
7080 write_ascstring (stream, " # (unwind-protect ...)\n"); |
| 428 | 7081 printing_bindings = 0; |
| 7082 } | |
| 7083 } | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7084 if (printing_bindings) write_ascstring (stream, ")\n"); |
| 428 | 7085 } |
| 7086 | |
| 1292 | 7087 static Lisp_Object |
| 7088 backtrace_unevalled_args (Lisp_Object *args) | |
| 7089 { | |
| 7090 if (args) | |
| 7091 return *args; | |
| 7092 else | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7093 return list1 (build_ascstring ("[internal]")); |
| 1292 | 7094 } |
| 7095 | |
| 428 | 7096 DEFUN ("backtrace", Fbacktrace, 0, 2, "", /* |
| 7097 Print a trace of Lisp function calls currently active. | |
| 438 | 7098 Optional arg STREAM specifies the output stream to send the backtrace to, |
| 444 | 7099 and defaults to the value of `standard-output'. |
| 7100 Optional second arg DETAILED non-nil means show places where currently | |
| 7101 active variable bindings, catches, condition-cases, and | |
| 7102 unwind-protects, as well as function calls, were made. | |
| 428 | 7103 */ |
| 7104 (stream, detailed)) | |
| 7105 { | |
| 7106 /* This function can GC */ | |
| 7107 struct backtrace *backlist = backtrace_list; | |
| 7108 struct catchtag *catches = catchlist; | |
| 7109 int speccount = specpdl_depth(); | |
| 7110 | |
| 7111 int old_nl = print_escape_newlines; | |
| 7112 int old_pr = print_readably; | |
| 7113 Lisp_Object old_level = Vprint_level; | |
| 7114 Lisp_Object oiq = Vinhibit_quit; | |
| 7115 struct gcpro gcpro1, gcpro2; | |
| 7116 | |
| 7117 /* We can't allow quits in here because that could cause the values | |
| 7118 of print_readably and print_escape_newlines to get screwed up. | |
| 7119 Normally we would use a record_unwind_protect but that would | |
| 7120 screw up the functioning of this function. */ | |
| 7121 Vinhibit_quit = Qt; | |
| 7122 | |
| 7123 entering_debugger = 0; | |
| 7124 | |
| 872 | 7125 if (!NILP (detailed)) |
| 7126 Vprint_level = make_int (50); | |
| 7127 else | |
| 7128 Vprint_level = make_int (3); | |
| 428 | 7129 print_readably = 0; |
| 7130 print_escape_newlines = 1; | |
| 7131 | |
| 7132 GCPRO2 (stream, old_level); | |
| 7133 | |
| 1261 | 7134 stream = canonicalize_printcharfun (stream); |
| 428 | 7135 |
| 7136 for (;;) | |
| 7137 { | |
| 7138 if (!NILP (detailed) && catches && catches->backlist == backlist) | |
| 7139 { | |
| 7140 int catchpdl = catches->pdlcount; | |
| 438 | 7141 if (speccount > catchpdl |
| 7142 && specpdl[catchpdl].func == condition_case_unwind) | |
| 428 | 7143 /* This is a condition-case catchpoint */ |
| 7144 catchpdl = catchpdl + 1; | |
| 7145 | |
| 7146 backtrace_specials (speccount, catchpdl, stream); | |
| 7147 | |
| 7148 speccount = catches->pdlcount; | |
| 7149 if (catchpdl == speccount) | |
| 7150 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7151 write_ascstring (stream, " # (catch "); |
| 428 | 7152 Fprin1 (catches->tag, stream); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7153 write_ascstring (stream, " ...)\n"); |
| 428 | 7154 } |
| 7155 else | |
| 7156 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7157 write_ascstring (stream, " # (condition-case ... . "); |
| 428 | 7158 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
|
7159 write_ascstring (stream, ")\n"); |
| 428 | 7160 } |
| 7161 catches = catches->next; | |
| 7162 } | |
| 7163 else if (!backlist) | |
| 7164 break; | |
| 7165 else | |
| 7166 { | |
| 7167 if (!NILP (detailed) && backlist->pdlcount < speccount) | |
| 7168 { | |
| 7169 backtrace_specials (speccount, backlist->pdlcount, stream); | |
| 7170 speccount = backlist->pdlcount; | |
| 7171 } | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7172 write_ascstring (stream, backlist->debug_on_exit ? "* " : " "); |
| 428 | 7173 if (backlist->nargs == UNEVALLED) |
| 7174 { | |
| 1292 | 7175 Fprin1 (Fcons (*backlist->function, |
| 7176 backtrace_unevalled_args (backlist->args)), | |
| 7177 stream); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7178 write_ascstring (stream, "\n"); /* from FSFmacs 19.30 */ |
| 428 | 7179 } |
| 7180 else | |
| 7181 { | |
| 7182 Lisp_Object tem = *backlist->function; | |
| 7183 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
|
7184 write_ascstring (stream, "("); |
| 428 | 7185 if (backlist->nargs == MANY) |
| 7186 { | |
| 7187 int i; | |
| 7188 Lisp_Object tail = Qnil; | |
| 7189 struct gcpro ngcpro1; | |
| 7190 | |
| 7191 NGCPRO1 (tail); | |
| 7192 for (tail = *backlist->args, i = 0; | |
| 7193 !NILP (tail); | |
| 7194 tail = Fcdr (tail), i++) | |
| 7195 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7196 if (i != 0) write_ascstring (stream, " "); |
| 428 | 7197 Fprin1 (Fcar (tail), stream); |
| 7198 } | |
| 7199 NUNGCPRO; | |
| 7200 } | |
| 7201 else | |
| 7202 { | |
| 7203 int i; | |
| 7204 for (i = 0; i < backlist->nargs; i++) | |
| 7205 { | |
| 826 | 7206 if (!i && EQ (tem, Qbyte_code)) |
| 7207 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7208 write_ascstring (stream, "\"...\""); |
| 826 | 7209 continue; |
| 7210 } | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7211 if (i != 0) write_ascstring (stream, " "); |
| 428 | 7212 Fprin1 (backlist->args[i], stream); |
| 7213 } | |
| 7214 } | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7215 write_ascstring (stream, ")\n"); |
| 428 | 7216 } |
| 7217 backlist = backlist->next; | |
| 7218 } | |
| 7219 } | |
| 7220 Vprint_level = old_level; | |
| 7221 print_readably = old_pr; | |
| 7222 print_escape_newlines = old_nl; | |
| 7223 UNGCPRO; | |
| 7224 Vinhibit_quit = oiq; | |
| 7225 return Qnil; | |
| 7226 } | |
| 7227 | |
| 7228 | |
| 444 | 7229 DEFUN ("backtrace-frame", Fbacktrace_frame, 1, 1, 0, /* |
| 7230 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
|
7231 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
|
7232 operator), the value is (nil FUNCTION ARG-FORMS...). |
| 428 | 7233 If that frame has evaluated its arguments and called its function already, |
| 7234 the value is (t FUNCTION ARG-VALUES...). | |
| 7235 A &rest arg is represented as the tail of the list ARG-VALUES. | |
| 7236 FUNCTION is whatever was supplied as car of evaluated list, | |
| 7237 or a lambda expression for macro calls. | |
| 444 | 7238 If NFRAMES is more than the number of frames, the value is nil. |
| 428 | 7239 */ |
| 7240 (nframes)) | |
| 7241 { | |
| 7242 REGISTER struct backtrace *backlist = backtrace_list; | |
| 7243 REGISTER int i; | |
| 7244 Lisp_Object tem; | |
| 7245 | |
|
5307
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5265
diff
changeset
|
7246 check_integer_range (nframes, Qzero, make_integer (EMACS_INT_MAX)); |
| 428 | 7247 |
| 7248 /* Find the frame requested. */ | |
| 7249 for (i = XINT (nframes); backlist && (i-- > 0);) | |
| 7250 backlist = backlist->next; | |
| 7251 | |
| 7252 if (!backlist) | |
| 7253 return Qnil; | |
| 7254 if (backlist->nargs == UNEVALLED) | |
| 1292 | 7255 return Fcons (Qnil, Fcons (*backlist->function, |
| 7256 backtrace_unevalled_args (backlist->args))); | |
| 428 | 7257 else |
| 7258 { | |
| 7259 if (backlist->nargs == MANY) | |
| 7260 tem = *backlist->args; | |
| 7261 else | |
| 7262 tem = Flist (backlist->nargs, backlist->args); | |
| 7263 | |
| 7264 return Fcons (Qt, Fcons (*backlist->function, tem)); | |
| 7265 } | |
| 7266 } | |
| 7267 | |
| 7268 | |
| 7269 /************************************************************************/ | |
| 7270 /* Warnings */ | |
| 7271 /************************************************************************/ | |
| 7272 | |
| 1123 | 7273 static int |
| 7274 warning_will_be_discarded (Lisp_Object level) | |
| 7275 { | |
| 7276 /* Don't even generate debug warnings if they're going to be discarded, | |
| 7277 to avoid excessive consing. */ | |
| 7278 return (EQ (level, Qdebug) && !NILP (Vlog_warning_minimum_level) && | |
| 7279 !EQ (Vlog_warning_minimum_level, Qdebug)); | |
| 7280 } | |
| 7281 | |
| 428 | 7282 void |
| 1204 | 7283 warn_when_safe_lispobj (Lisp_Object class_, Lisp_Object level, |
| 428 | 7284 Lisp_Object obj) |
| 7285 { | |
| 1123 | 7286 if (warning_will_be_discarded (level)) |
| 793 | 7287 return; |
| 1123 | 7288 |
| 1204 | 7289 obj = list1 (list3 (class_, level, obj)); |
| 428 | 7290 if (NILP (Vpending_warnings)) |
| 7291 Vpending_warnings = Vpending_warnings_tail = obj; | |
| 7292 else | |
| 7293 { | |
| 7294 Fsetcdr (Vpending_warnings_tail, obj); | |
| 7295 Vpending_warnings_tail = obj; | |
| 7296 } | |
| 7297 } | |
| 7298 | |
| 7299 /* #### This should probably accept Lisp objects; but then we have | |
| 7300 to make sure that Feval() isn't called, since it might not be safe. | |
| 7301 | |
| 7302 An alternative approach is to just pass some non-string type of | |
| 7303 Lisp_Object to warn_when_safe_lispobj(); `prin1-to-string' will | |
| 7304 automatically be called when it is safe to do so. */ | |
| 7305 | |
| 7306 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7307 warn_when_safe (Lisp_Object class_, Lisp_Object level, const Ascbyte *fmt, ...) |
| 428 | 7308 { |
| 7309 Lisp_Object obj; | |
| 7310 va_list args; | |
| 7311 | |
| 1123 | 7312 if (warning_will_be_discarded (level)) |
| 793 | 7313 return; |
| 1123 | 7314 |
| 428 | 7315 va_start (args, fmt); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7316 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 428 | 7317 va_end (args); |
| 7318 | |
| 1204 | 7319 warn_when_safe_lispobj (class_, level, obj); |
| 428 | 7320 } |
| 7321 | |
| 7322 | |
| 7323 | |
| 7324 | |
| 7325 /************************************************************************/ | |
| 7326 /* Initialization */ | |
| 7327 /************************************************************************/ | |
| 7328 | |
| 7329 void | |
| 7330 syms_of_eval (void) | |
| 7331 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
7332 INIT_LISP_OBJECT (subr); |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
7333 INIT_LISP_OBJECT (multiple_value); |
| 442 | 7334 |
| 563 | 7335 DEFSYMBOL (Qinhibit_quit); |
| 7336 DEFSYMBOL (Qautoload); | |
| 7337 DEFSYMBOL (Qdebug_on_error); | |
| 7338 DEFSYMBOL (Qstack_trace_on_error); | |
| 7339 DEFSYMBOL (Qdebug_on_signal); | |
| 7340 DEFSYMBOL (Qstack_trace_on_signal); | |
| 7341 DEFSYMBOL (Qdebugger); | |
| 7342 DEFSYMBOL (Qmacro); | |
| 428 | 7343 defsymbol (&Qand_rest, "&rest"); |
| 7344 defsymbol (&Qand_optional, "&optional"); | |
| 7345 /* Note that the process code also uses Qexit */ | |
| 563 | 7346 DEFSYMBOL (Qexit); |
|
5506
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
7347 DEFSYMBOL (Qdeclare); |
| 563 | 7348 DEFSYMBOL (Qsetq); |
| 7349 DEFSYMBOL (Qinteractive); | |
| 7350 DEFSYMBOL (Qcommandp); | |
| 7351 DEFSYMBOL (Qdefun); | |
| 7352 DEFSYMBOL (Qprogn); | |
| 7353 DEFSYMBOL (Qvalues); | |
| 7354 DEFSYMBOL (Qdisplay_warning); | |
| 7355 DEFSYMBOL (Qrun_hooks); | |
| 887 | 7356 DEFSYMBOL (Qfinalize_list); |
| 563 | 7357 DEFSYMBOL (Qif); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7358 DEFSYMBOL (Qthrow); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7359 DEFSYMBOL (Qobsolete_throw); |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
7360 DEFSYMBOL (Qmultiple_value_list_internal); |
| 428 | 7361 |
| 7362 DEFSUBR (For); | |
| 7363 DEFSUBR (Fand); | |
| 7364 DEFSUBR (Fif); | |
| 7365 DEFSUBR_MACRO (Fwhen); | |
| 7366 DEFSUBR_MACRO (Funless); | |
| 7367 DEFSUBR (Fcond); | |
| 7368 DEFSUBR (Fprogn); | |
| 7369 DEFSUBR (Fprog1); | |
| 7370 DEFSUBR (Fprog2); | |
| 7371 DEFSUBR (Fsetq); | |
| 7372 DEFSUBR (Fquote); | |
|
4744
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
7373 DEFSUBR (Fquote_maybe); |
| 428 | 7374 DEFSUBR (Ffunction); |
| 7375 DEFSUBR (Fdefun); | |
| 7376 DEFSUBR (Fdefmacro); | |
| 7377 DEFSUBR (Fdefvar); | |
| 7378 DEFSUBR (Fdefconst); | |
| 7379 DEFSUBR (Flet); | |
| 7380 DEFSUBR (FletX); | |
| 7381 DEFSUBR (Fwhile); | |
| 7382 DEFSUBR (Fmacroexpand_internal); | |
| 7383 DEFSUBR (Fcatch); | |
| 7384 DEFSUBR (Fthrow); | |
| 7385 DEFSUBR (Funwind_protect); | |
| 7386 DEFSUBR (Fcondition_case); | |
| 7387 DEFSUBR (Fcall_with_condition_handler); | |
| 7388 DEFSUBR (Fsignal); | |
| 7389 DEFSUBR (Finteractive_p); | |
| 7390 DEFSUBR (Fcommandp); | |
| 7391 DEFSUBR (Fcommand_execute); | |
| 7392 DEFSUBR (Fautoload); | |
| 7393 DEFSUBR (Feval); | |
| 7394 DEFSUBR (Fapply); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7395 DEFSUBR (Fmultiple_value_call); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7396 DEFSUBR (Fmultiple_value_list_internal); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7397 DEFSUBR (Fmultiple_value_prog1); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7398 DEFSUBR (Fvalues); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7399 DEFSUBR (Fvalues_list); |
| 428 | 7400 DEFSUBR (Ffuncall); |
| 7401 DEFSUBR (Ffunctionp); | |
| 7402 DEFSUBR (Ffunction_min_args); | |
| 7403 DEFSUBR (Ffunction_max_args); | |
| 7404 DEFSUBR (Frun_hooks); | |
| 7405 DEFSUBR (Frun_hook_with_args); | |
| 7406 DEFSUBR (Frun_hook_with_args_until_success); | |
| 7407 DEFSUBR (Frun_hook_with_args_until_failure); | |
| 7408 DEFSUBR (Fbacktrace_debug); | |
| 7409 DEFSUBR (Fbacktrace); | |
| 7410 DEFSUBR (Fbacktrace_frame); | |
| 7411 } | |
| 7412 | |
| 7413 void | |
| 814 | 7414 init_eval_semi_early (void) |
| 428 | 7415 { |
| 7416 specpdl_ptr = specpdl; | |
| 7417 specpdl_depth_counter = 0; | |
| 7418 catchlist = 0; | |
| 7419 Vcondition_handlers = Qnil; | |
| 7420 backtrace_list = 0; | |
| 7421 Vquit_flag = Qnil; | |
| 7422 debug_on_next_call = 0; | |
| 7423 lisp_eval_depth = 0; | |
| 7424 entering_debugger = 0; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7425 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7426 first_desired_multiple_value = 0; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7427 multiple_value_current_limit = 1; |
| 428 | 7428 } |
| 7429 | |
| 7430 void | |
| 7431 reinit_vars_of_eval (void) | |
| 7432 { | |
| 7433 preparing_for_armageddon = 0; | |
| 7434 in_warnings = 0; | |
| 7435 specpdl_size = 50; | |
| 7436 specpdl = xnew_array (struct specbinding, specpdl_size); | |
| 7437 /* XEmacs change: increase these values. */ | |
| 7438 max_specpdl_size = 3000; | |
| 442 | 7439 max_lisp_eval_depth = 1000; |
| 7440 #ifdef DEFEND_AGAINST_THROW_RECURSION | |
| 428 | 7441 throw_level = 0; |
| 7442 #endif | |
| 2367 | 7443 init_eval_semi_early (); |
| 428 | 7444 } |
| 7445 | |
| 7446 void | |
| 7447 vars_of_eval (void) | |
| 7448 { | |
| 7449 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size /* | |
| 7450 Limit on number of Lisp variable bindings & unwind-protects before error. | |
| 7451 */ ); | |
| 7452 | |
| 7453 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth /* | |
| 7454 Limit on depth in `eval', `apply' and `funcall' before error. | |
| 7455 This limit is to catch infinite recursions for you before they cause | |
| 7456 actual stack overflow in C, which would be fatal for Emacs. | |
| 7457 You can safely make it considerably larger than its default value, | |
| 7458 if that proves inconveniently small. | |
| 7459 */ ); | |
| 7460 | |
| 7461 DEFVAR_LISP ("quit-flag", &Vquit_flag /* | |
| 853 | 7462 t causes running Lisp code to abort, unless `inhibit-quit' is non-nil. |
| 7463 `critical' causes running Lisp code to abort regardless of `inhibit-quit'. | |
| 7464 Normally, you do not need to set this value yourself. It is set to | |
| 7465 t each time a Control-G is detected, and to `critical' each time a | |
| 7466 Shift-Control-G is detected. The XEmacs core C code is littered with | |
| 7467 calls to the QUIT; macro, which check the values of `quit-flag' and | |
| 2500 | 7468 `inhibit-quit' and ABORT (or more accurately, call (signal 'quit)) if |
| 853 | 7469 it's correct to do so. |
| 428 | 7470 */ ); |
| 7471 Vquit_flag = Qnil; | |
| 7472 | |
| 7473 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit /* | |
| 7474 Non-nil inhibits C-g quitting from happening immediately. | |
| 7475 Note that `quit-flag' will still be set by typing C-g, | |
| 7476 so a quit will be signalled as soon as `inhibit-quit' is nil. | |
| 7477 To prevent this happening, set `quit-flag' to nil | |
| 853 | 7478 before making `inhibit-quit' nil. |
| 7479 | |
| 7480 The value of `inhibit-quit' is ignored if a critical quit is | |
| 7481 requested by typing control-shift-G in a window-system frame; | |
| 7482 this is explained in more detail in `quit-flag'. | |
| 428 | 7483 */ ); |
| 7484 Vinhibit_quit = Qnil; | |
| 7485 | |
| 7486 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error /* | |
| 7487 *Non-nil means automatically display a backtrace buffer | |
| 7488 after any error that is not handled by a `condition-case'. | |
| 7489 If the value is a list, an error only means to display a backtrace | |
| 7490 if one of its condition symbols appears in the list. | |
| 7491 See also variable `stack-trace-on-signal'. | |
| 7492 */ ); | |
| 7493 Vstack_trace_on_error = Qnil; | |
| 7494 | |
| 7495 DEFVAR_LISP ("stack-trace-on-signal", &Vstack_trace_on_signal /* | |
| 7496 *Non-nil means automatically display a backtrace buffer | |
| 7497 after any error that is signalled, whether or not it is handled by | |
| 7498 a `condition-case'. | |
| 7499 If the value is a list, an error only means to display a backtrace | |
| 7500 if one of its condition symbols appears in the list. | |
| 7501 See also variable `stack-trace-on-error'. | |
| 7502 */ ); | |
| 7503 Vstack_trace_on_signal = Qnil; | |
| 7504 | |
| 7505 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors /* | |
| 7506 *List of errors for which the debugger should not be called. | |
| 7507 Each element may be a condition-name or a regexp that matches error messages. | |
| 7508 If any element applies to a given error, that error skips the debugger | |
| 7509 and just returns to top level. | |
| 7510 This overrides the variable `debug-on-error'. | |
| 7511 It does not apply to errors handled by `condition-case'. | |
| 7512 */ ); | |
| 7513 Vdebug_ignored_errors = Qnil; | |
| 7514 | |
| 7515 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error /* | |
| 7516 *Non-nil means enter debugger if an unhandled error is signalled. | |
| 7517 The debugger will not be entered if the error is handled by | |
| 7518 a `condition-case'. | |
| 7519 If the value is a list, an error only means to enter the debugger | |
| 7520 if one of its condition symbols appears in the list. | |
| 7521 This variable is overridden by `debug-ignored-errors'. | |
| 7522 See also variables `debug-on-quit' and `debug-on-signal'. | |
| 1123 | 7523 |
|
4657
f8d7d8202635
imported patch accept-process-output-docstring
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4642
diff
changeset
|
7524 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
|
7525 (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
|
7526 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
|
7527 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
|
7528 |
| 1123 | 7529 If this variable is set while XEmacs is running noninteractively (using |
| 7530 `-batch'), and XEmacs was configured with `--debug' (#define XEMACS_DEBUG | |
| 7531 in the C code), instead of trying to invoke the Lisp debugger (which | |
| 7532 obviously won't work), XEmacs will break out to a C debugger using | |
| 7533 \(force-debugging-signal t). This is useful because debugging | |
| 7534 noninteractive runs of XEmacs is often very difficult, since they typically | |
| 7535 happen as part of sometimes large and complex make suites (e.g. rebuilding | |
| 2500 | 7536 the XEmacs packages). NOTE: This runs ABORT()!!! (As well as and after |
| 1123 | 7537 executing INT 3 under MS Windows, which should invoke a debugger if it's |
| 7538 active.) This is guaranteed to kill XEmacs! (But in this situation, XEmacs | |
| 7539 is about to die anyway, and if no debugger is present, this will usefully | |
| 7540 dump core.) The most useful way to set this flag when debugging | |
| 7541 noninteractive runs, especially in makefiles, is using the environment | |
| 7542 variable XEMACSDEBUG, like this: | |
| 771 | 7543 |
| 7544 \(using csh) setenv XEMACSDEBUG '(setq debug-on-error t)' | |
| 7545 \(using bash) export XEMACSDEBUG='(setq debug-on-error t)' | |
| 428 | 7546 */ ); |
| 7547 Vdebug_on_error = Qnil; | |
| 7548 | |
| 7549 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal /* | |
| 7550 *Non-nil means enter debugger if an error is signalled. | |
| 7551 The debugger will be entered whether or not 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 See also variable `debug-on-quit'. | |
| 1123 | 7556 |
| 7557 This will attempt to enter a C debugger when XEmacs is run noninteractively | |
| 7558 and under the same conditions as described in `debug-on-error'. | |
| 428 | 7559 */ ); |
| 7560 Vdebug_on_signal = Qnil; | |
| 7561 | |
| 7562 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit /* | |
| 7563 *Non-nil means enter debugger if quit is signalled (C-G, for example). | |
| 7564 Does not apply if quit is handled by a `condition-case'. Entering the | |
| 7565 debugger can also be achieved at any time (for X11 console) by typing | |
| 7566 control-shift-G to signal a critical quit. | |
| 7567 */ ); | |
| 7568 debug_on_quit = 0; | |
| 7569 | |
| 7570 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call /* | |
| 7571 Non-nil means enter debugger before next `eval', `apply' or `funcall'. | |
| 7572 */ ); | |
| 7573 | |
| 1292 | 7574 DEFVAR_BOOL ("backtrace-with-interal-sections", |
| 7575 &backtrace_with_internal_sections /* | |
| 7576 Non-nil means backtraces will contain additional information indicating | |
| 7577 when particular sections of the C code have been entered, e.g. redisplay(), | |
| 7578 byte-char conversion, internal-external conversion, etc. This can be | |
| 7579 particularly useful when XEmacs crashes, in helping to pinpoint the problem. | |
| 7580 */ ); | |
| 7581 #ifdef ERROR_CHECK_STRUCTURES | |
| 7582 backtrace_with_internal_sections = 1; | |
| 7583 #else | |
| 7584 backtrace_with_internal_sections = 0; | |
| 7585 #endif | |
| 7586 | |
| 428 | 7587 DEFVAR_LISP ("debugger", &Vdebugger /* |
| 7588 Function to call to invoke debugger. | |
| 7589 If due to frame exit, args are `exit' and the value being returned; | |
| 7590 this function's value will be returned instead of that. | |
| 7591 If due to error, args are `error' and a list of the args to `signal'. | |
| 7592 If due to `apply' or `funcall' entry, one arg, `lambda'. | |
| 7593 If due to `eval' entry, one arg, t. | |
| 7594 */ ); | |
| 7595 Vdebugger = Qnil; | |
| 7596 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7597 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
|
7598 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
|
7599 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7600 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
|
7601 macros and special operators. |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7602 */); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7603 Vmultiple_values_limit = EMACS_INT_MAX > INT_MAX ? INT_MAX : EMACS_INT_MAX; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7604 |
|
5506
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
7605 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
|
7606 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
|
7607 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
|
7608 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
|
7609 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
|
7610 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
|
7611 */); |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
7612 Vmacro_declaration_function = Qnil; |
|
b0d87f92e60b
Complete support for macro-declaration-function, bytecomp{,-runtime}.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5470
diff
changeset
|
7613 |
| 853 | 7614 staticpro (&Vcatch_everything_tag); |
| 7615 Vcatch_everything_tag = make_opaque (OPAQUE_CLEAR, 0); | |
| 7616 | |
| 428 | 7617 staticpro (&Vpending_warnings); |
| 7618 Vpending_warnings = Qnil; | |
| 1204 | 7619 dump_add_root_lisp_object (&Vpending_warnings_tail); |
| 428 | 7620 Vpending_warnings_tail = Qnil; |
| 7621 | |
| 793 | 7622 DEFVAR_LISP ("log-warning-minimum-level", &Vlog_warning_minimum_level); |
| 7623 Vlog_warning_minimum_level = Qinfo; | |
| 7624 | |
| 428 | 7625 staticpro (&Vautoload_queue); |
| 7626 Vautoload_queue = Qnil; | |
| 7627 | |
| 7628 staticpro (&Vcondition_handlers); | |
| 7629 | |
| 853 | 7630 staticpro (&Vdeletable_permanent_display_objects); |
| 7631 Vdeletable_permanent_display_objects = Qnil; | |
| 7632 | |
| 7633 staticpro (&Vmodifiable_buffers); | |
| 7634 Vmodifiable_buffers = Qnil; | |
| 7635 | |
| 7636 inhibit_flags = 0; | |
| 7637 } |