Mercurial > hg > xemacs-beta
annotate src/eval.c @ 5050:6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
-------------------- ChangeLog entries follow: --------------------
ChangeLog addition:
2010-02-20 Ben Wing <ben@xemacs.org>
* configure.ac (XE_COMPLEX_ARG):
Correct doc of --quick-build: It also doesn't check for Lisp shadows.
src/ChangeLog addition:
2010-02-20 Ben Wing <ben@xemacs.org>
* EmacsFrame.c:
* EmacsFrame.c (EmacsFrameRecomputeCellSize):
* alloca.c (i00afunc):
* buffer.c:
* buffer.c (MARKED_SLOT):
* buffer.c (complex_vars_of_buffer):
* cm.c:
* cm.c (cmcheckmagic):
* console.c:
* console.c (MARKED_SLOT):
* device-x.c:
* device-x.c (x_get_visual_depth):
* emacs.c (sort_args):
* eval.c (throw_or_bomb_out):
* event-stream.c:
* event-stream.c (Fadd_timeout):
* event-stream.c (Fadd_async_timeout):
* event-stream.c (Frecent_keys):
* events.c:
* events.c (Fdeallocate_event):
* events.c (event_pixel_translation):
* extents.c:
* extents.c (process_extents_for_insertion_mapper):
* fns.c (Fbase64_encode_region):
* fns.c (Fbase64_encode_string):
* fns.c (Fbase64_decode_region):
* fns.c (Fbase64_decode_string):
* font-lock.c:
* font-lock.c (find_context):
* frame-x.c:
* frame-x.c (x_wm_mark_shell_size_user_specified):
* frame-x.c (x_wm_mark_shell_position_user_specified):
* frame-x.c (x_wm_set_shell_iconic_p):
* frame-x.c (x_wm_set_cell_size):
* frame-x.c (x_wm_set_variable_size):
* frame-x.c (x_wm_store_class_hints):
* frame-x.c (x_wm_maybe_store_wm_command):
* frame-x.c (x_initialize_frame_size):
* frame.c (delete_frame_internal):
* frame.c (change_frame_size_1):
* free-hook.c (check_free):
* free-hook.c (note_block_input):
* free-hook.c (log_gcpro):
* gccache-gtk.c (gc_cache_lookup):
* gccache-x.c:
* gccache-x.c (gc_cache_lookup):
* glyphs-gtk.c:
* glyphs-gtk.c (init_image_instance_from_gdk_pixmap):
* glyphs-x.c:
* glyphs-x.c (extract_xpm_color_names):
* insdel.c:
* insdel.c (move_gap):
* keymap.c:
* keymap.c (keymap_lookup_directly):
* keymap.c (keymap_delete_inverse_internal):
* keymap.c (accessible_keymaps_mapper_1):
* keymap.c (where_is_recursive_mapper):
* lisp.h:
* lstream.c (make_lisp_buffer_stream_1):
* macros.c:
* macros.c (pop_kbd_macro_event):
* mc-alloc.c (remove_page_from_used_list):
* menubar-x.c:
* menubar-x.c (set_frame_menubar):
* ralloc.c:
* ralloc.c (obtain):
* ralloc.c (relinquish):
* ralloc.c (relocate_blocs):
* ralloc.c (resize_bloc):
* ralloc.c (r_alloc_free):
* ralloc.c (r_re_alloc):
* ralloc.c (r_alloc_thaw):
* ralloc.c (init_ralloc):
* ralloc.c (Free_Addr_Block):
* scrollbar-x.c:
* scrollbar-x.c (x_update_scrollbar_instance_status):
* sunplay.c (init_device):
* unexnt.c:
* unexnt.c (read_in_bss):
* unexnt.c (map_in_heap):
* window.c:
* window.c (real_window):
* window.c (window_display_lines):
* window.c (window_display_buffer):
* window.c (set_window_display_buffer):
* window.c (unshow_buffer):
* window.c (Fget_lru_window):
if (...) ABORT(); ---> assert();
More specifically:
if (x == y) ABORT (); --> assert (x != y);
if (x != y) ABORT (); --> assert (x == y);
if (x > y) ABORT (); --> assert (x <= y);
etc.
if (!x) ABORT (); --> assert (x);
if (x) ABORT (); --> assert (!x);
DeMorgan's Law's applied and manually simplified:
if (x && !y) ABORT (); --> assert (!x || y);
if (!x || y >= z) ABORT (); --> assert (x && y < z);
Checked to make sure that assert() of an expression with side
effects ensures that the side effects get executed even when
asserts are disabled, and add a comment about this being a
requirement of any "disabled assert" expression.
* depend:
* make-src-depend:
* make-src-depend (PrintDeps):
Fix broken code in make-src-depend so it does what it was always
supposed to do, which was separate out config.h and lisp.h and
all the files they include into separate variables in the
depend part of Makefile so that quick-build can turn off the
lisp.h/config.h/text.h/etc. dependencies of the source files, to
speed up recompilation.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Sat, 20 Feb 2010 05:05:54 -0600 |
| parents | 2ade80e8c640 |
| children | 6afe991b8135 2a462149bd6a |
| 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 | |
| 8 XEmacs is free software; you can redistribute it and/or modify it | |
| 9 under the terms of the GNU General Public License as published by the | |
| 10 Free Software Foundation; either version 2, or (at your option) any | |
| 11 later version. | |
| 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 | |
| 19 along with XEmacs; see the file COPYING. If not, write to | |
| 20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 21 Boston, MA 02111-1307, USA. */ | |
| 22 | |
| 23 /* Synched up with: FSF 19.30 (except for Fsignal), Mule 2.0. */ | |
| 24 | |
| 853 | 25 /* Authorship: |
| 26 | |
| 27 Based on code from pre-release FSF 19, c. 1991. | |
| 28 Some work by Richard Mlynarik long ago (c. 1993?) -- | |
| 29 added call-with-condition-handler; synch. up to released FSF 19.7 | |
| 30 for lemacs 19.8. some signal changes. | |
| 31 Various work by Ben Wing, 1995-1996: | |
| 32 added all stuff dealing with trapping errors, suspended-errors, etc. | |
| 33 added most Fsignal front ends. | |
| 34 added warning code. | |
| 35 reworked the Fsignal code and synched the rest up to FSF 19.30. | |
| 36 Some changes by Martin Buchholz c. 1999? | |
| 37 e.g. PRIMITIVE_FUNCALL macros. | |
| 38 New call_trapping_problems code and large comments below | |
| 39 by Ben Wing, Mar-Apr 2000. | |
| 40 */ | |
| 41 | |
| 42 /* This file has been Mule-ized. */ | |
| 43 | |
| 44 /* What is in this file? | |
| 45 | |
| 46 This file contains the engine for the ELisp interpreter in XEmacs. | |
| 47 The engine does the actual work of implementing function calls, | |
| 48 form evaluation, non-local exits (catch, throw, signal, | |
| 49 condition-case, call-with-condition-handler), unwind-protects, | |
| 50 dynamic bindings, let constructs, backtraces, etc. You might say | |
| 51 that this module is the very heart of XEmacs, and everything else | |
| 52 in XEmacs is merely an auxiliary module implementing some specific | |
| 53 functionality that may be called from the heart at an appropriate | |
| 54 time. | |
| 55 | |
| 56 The only exception is the alloc.c module, which implements the | |
| 57 framework upon which this module (eval.c) works. alloc.c works | |
| 58 with creating the actual Lisp objects themselves and garbage | |
| 1960 | 59 collecting them as necessary, presenting a nice, high-level |
| 853 | 60 interface for object creation, deletion, access, and modification. |
| 61 | |
| 62 The only other exception that could be cited is the event-handling | |
| 63 module in event-stream.c. From its perspective, it is also the | |
| 64 heart of XEmacs, and controls exactly what gets done at what time. | |
| 65 From its perspective, eval.c is merely one of the auxiliary modules | |
| 66 out there that can be invoked by event-stream.c. | |
| 67 | |
| 68 Although the event-stream-centric view is a convenient fiction that | |
| 69 makes sense particularly from the user's perspective and from the | |
| 70 perspective of time, the engine-centric view is actually closest to | |
| 71 the truth, because anywhere within the event-stream module, you are | |
| 72 still somewhere in a Lisp backtrace, and event-loops are begun by | |
| 73 functions such as `command-loop-1', a Lisp function. | |
| 74 | |
| 75 As the Lisp engine is doing its thing, it maintains the state of | |
| 1960 | 76 the engine primarily in five list-like items, which are: |
| 853 | 77 |
| 78 -- the backtrace list | |
| 79 -- the catchtag list | |
| 80 -- the condition-handler list | |
| 81 -- the specbind list | |
| 82 -- the GCPRO list. | |
| 83 | |
| 84 These are described in detail in the next comment. | |
| 85 | |
| 86 --ben | |
| 87 */ | |
| 88 | |
| 89 /* Note that there are five separate lists used to maintain state in | |
| 90 the evaluator. All of them conceptually are stacks (last-in, | |
| 91 first-out). All non-local exits happen ultimately through the | |
| 92 catch/throw mechanism, which uses one of the five lists (the | |
| 93 catchtag list) and records the current state of the others in each | |
| 94 frame of the list (some other information is recorded and restored | |
| 95 as well, such as the current eval depth), so that all the state of | |
| 96 the evaluator is restored properly when a non-local exit occurs. | |
| 97 (Note that the current state of the condition-handler list is not | |
| 98 recorded in the catchtag list. Instead, when a condition-case or | |
| 99 call-with-condition-handler is set up, it installs an | |
| 100 unwind-protect on the specbind list to restore the appropriate | |
| 101 setting for the condition-handler list. During the course of | |
| 102 handling the non-local exit, all entries on the specbind list that | |
| 103 are past the location stored in the catch frame are "unwound" | |
| 104 (i.e. variable bindings are restored and unwind-protects are | |
| 105 executed), so the condition-handler list gets reset properly. | |
| 106 | |
| 107 The five lists are | |
| 108 | |
| 109 1. The backtrace list, which is chained through `struct backtrace's | |
| 110 declared in the stack frames of various primitives, and keeps | |
| 111 track of all Lisp function call entries and exits. | |
| 112 2. The catchtag list, which is chained through `struct catchtag's | |
| 113 declared in the stack frames of internal_catch and condition_case_1, | |
| 114 and keeps track of information needed to reset the internal state | |
| 115 of the evaluator to the state that was current when the catch or | |
| 116 condition-case were established, in the event of a non-local exit. | |
| 117 3. The condition-handler list, which is a simple Lisp list with new | |
| 118 entries consed onto the front of the list. It records condition-cases | |
| 119 and call-with-condition-handlers established either from C or from | |
| 120 Lisp. Unlike with the other lists (but similar to everything else | |
| 121 of a similar nature in the rest of the C and Lisp code), it takes care | |
| 122 of restoring itself appropriately in the event of a non-local exit | |
| 123 through the use of the unwind-protect mechanism. | |
| 124 4. The specbind list, which is a contiguous array of `struct specbinding's, | |
| 125 expanded as necessary using realloc(). It holds dynamic variable | |
| 126 bindings (the only kind we currently have in ELisp) and unwind-protects. | |
| 127 5. The GCPRO list, which is chained through `struct gcpro's declared in | |
| 128 the stack frames of any functions that need to GC-protect Lisp_Objects | |
| 129 declared on the stack. This is one of the most fragile areas of the | |
| 130 entire scheme -- you must not forget to UNGCPRO at the end of your | |
| 131 function, you must make sure you GCPRO in many circumstances you don't | |
| 132 think you have to, etc. See the internals manual for more information | |
| 133 about this. | |
| 134 | |
| 135 --ben | |
| 136 */ | |
| 137 | |
| 428 | 138 #include <config.h> |
| 139 #include "lisp.h" | |
| 140 | |
| 141 #include "commands.h" | |
| 142 #include "backtrace.h" | |
| 143 #include "bytecode.h" | |
| 144 #include "buffer.h" | |
| 872 | 145 #include "console-impl.h" |
| 853 | 146 #include "device.h" |
| 147 #include "frame.h" | |
| 148 #include "lstream.h" | |
| 428 | 149 #include "opaque.h" |
| 1292 | 150 #include "profile.h" |
| 853 | 151 #include "window.h" |
| 428 | 152 |
| 153 struct backtrace *backtrace_list; | |
| 154 | |
| 155 /* Macros for calling subrs with an argument list whose length is only | |
| 156 known at runtime. See EXFUN and DEFUN for similar hackery. */ | |
| 157 | |
| 158 #define AV_0(av) | |
| 159 #define AV_1(av) av[0] | |
| 160 #define AV_2(av) AV_1(av), av[1] | |
| 161 #define AV_3(av) AV_2(av), av[2] | |
| 162 #define AV_4(av) AV_3(av), av[3] | |
| 163 #define AV_5(av) AV_4(av), av[4] | |
| 164 #define AV_6(av) AV_5(av), av[5] | |
| 165 #define AV_7(av) AV_6(av), av[6] | |
| 166 #define AV_8(av) AV_7(av), av[7] | |
| 167 | |
| 168 #define PRIMITIVE_FUNCALL_1(fn, av, ac) \ | |
| 444 | 169 (((Lisp_Object (*)(EXFUN_##ac)) (fn)) (AV_##ac (av))) |
| 428 | 170 |
| 171 /* If subrs take more than 8 arguments, more cases need to be added | |
| 172 to this switch. (But wait - don't do it - if you really need | |
| 173 a SUBR with more than 8 arguments, use max_args == MANY. | |
| 853 | 174 Or better, considering using a property list as one of your args. |
| 428 | 175 See the DEFUN macro in lisp.h) */ |
| 176 #define PRIMITIVE_FUNCALL(rv, fn, av, ac) do { \ | |
| 177 void (*PF_fn)(void) = (void (*)(void)) fn; \ | |
| 178 Lisp_Object *PF_av = (av); \ | |
| 179 switch (ac) \ | |
| 180 { \ | |
| 436 | 181 default:rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 0); break; \ |
| 428 | 182 case 1: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 1); break; \ |
| 183 case 2: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 2); break; \ | |
| 184 case 3: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 3); break; \ | |
| 185 case 4: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 4); break; \ | |
| 186 case 5: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 5); break; \ | |
| 187 case 6: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 6); break; \ | |
| 188 case 7: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 7); break; \ | |
| 189 case 8: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 8); break; \ | |
| 190 } \ | |
| 191 } while (0) | |
| 192 | |
| 193 #define FUNCALL_SUBR(rv, subr, av, ac) \ | |
| 194 PRIMITIVE_FUNCALL (rv, subr_function (subr), av, ac); | |
| 195 | |
| 196 | |
| 197 /* This is the list of current catches (and also condition-cases). | |
| 853 | 198 This is a stack: the most recent catch is at the head of the list. |
| 199 The list is threaded through the stack frames of the C functions | |
| 200 that set up the catches; this is similar to the way the GCPRO list | |
| 201 is handled, but different from the condition-handler list (which is | |
| 202 a simple Lisp list) and the specbind stack, which is a contiguous | |
| 203 array of `struct specbinding's, grown (using realloc()) as | |
| 204 necessary. (Note that all four of these lists behave as a stacks.) | |
| 205 | |
| 3025 | 206 Catches are created by declaring a `struct catchtag' locally, |
| 853 | 207 filling the .TAG field in with the tag, and doing a setjmp() on |
| 208 .JMP. Fthrow() will store the value passed to it in .VAL and | |
| 209 longjmp() back to .JMP, back to the function that established the | |
| 210 catch. This will always be either internal_catch() (catches | |
| 211 established internally or through `catch') or condition_case_1 | |
| 212 (condition-cases established internally or through | |
| 213 `condition-case'). | |
| 428 | 214 |
| 215 The catchtag also records the current position in the | |
| 216 call stack (stored in BACKTRACE_LIST), the current position | |
| 217 in the specpdl stack (used for variable bindings and | |
| 218 unwind-protects), the value of LISP_EVAL_DEPTH, and the | |
| 219 current position in the GCPRO stack. All of these are | |
| 220 restored by Fthrow(). | |
| 853 | 221 */ |
| 428 | 222 |
| 223 struct catchtag *catchlist; | |
| 224 | |
| 853 | 225 /* A special tag that can be used internally from C code to catch |
| 226 every attempt to throw past this level. */ | |
| 227 Lisp_Object Vcatch_everything_tag; | |
| 228 | |
| 428 | 229 Lisp_Object Qautoload, Qmacro, Qexit; |
| 230 Lisp_Object Qinteractive, Qcommandp, Qdefun, Qprogn, Qvalues; | |
| 231 Lisp_Object Vquit_flag, Vinhibit_quit; | |
| 232 Lisp_Object Qand_rest, Qand_optional; | |
| 233 Lisp_Object Qdebug_on_error, Qstack_trace_on_error; | |
| 234 Lisp_Object Qdebug_on_signal, Qstack_trace_on_signal; | |
| 235 Lisp_Object Qdebugger; | |
| 236 Lisp_Object Qinhibit_quit; | |
| 887 | 237 Lisp_Object Qfinalize_list; |
| 428 | 238 Lisp_Object Qrun_hooks; |
| 239 Lisp_Object Qsetq; | |
| 240 Lisp_Object Qdisplay_warning; | |
| 241 Lisp_Object Vpending_warnings, Vpending_warnings_tail; | |
| 242 Lisp_Object Qif; | |
| 243 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
244 Lisp_Object Qthrow; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
245 Lisp_Object Qobsolete_throw; |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
246 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
|
247 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
248 static int first_desired_multiple_value; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
249 /* 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
|
250 macro: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
251 int multiple_value_current_limit; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
252 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
253 Fixnum Vmultiple_values_limit; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
254 |
| 853 | 255 /* Flags specifying which operations are currently inhibited. */ |
| 256 int inhibit_flags; | |
| 257 | |
| 258 /* Buffers, frames, windows, devices, and consoles created since most | |
| 259 recent active | |
| 260 call_trapping_problems (INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION). | |
| 261 */ | |
| 262 Lisp_Object Vdeletable_permanent_display_objects; | |
| 263 | |
| 264 /* Buffers created since most recent active | |
| 265 call_trapping_problems (INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION). */ | |
| 266 Lisp_Object Vmodifiable_buffers; | |
| 793 | 267 |
| 268 /* Minimum level at which warnings are logged. Below this, they're ignored | |
| 269 entirely -- not even generated. */ | |
| 270 Lisp_Object Vlog_warning_minimum_level; | |
| 271 | |
| 428 | 272 /* Non-nil means record all fset's and provide's, to be undone |
| 273 if the file being autoloaded is not fully loaded. | |
| 274 They are recorded by being consed onto the front of Vautoload_queue: | |
| 275 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */ | |
| 276 Lisp_Object Vautoload_queue; | |
| 277 | |
| 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 |
| 421 /************************************************************************/ | |
| 422 /* The subr object type */ | |
| 423 /************************************************************************/ | |
| 424 | |
| 425 static void | |
| 2286 | 426 print_subr (Lisp_Object obj, Lisp_Object printcharfun, int UNUSED (escapeflag)) |
| 428 | 427 { |
| 428 Lisp_Subr *subr = XSUBR (obj); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
429 const Ascbyte *header = |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
430 (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
|
431 const Ascbyte *name = subr_name (subr); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
432 const Ascbyte *trailer = subr->prompt ? " (interactive)>" : ">"; |
| 428 | 433 |
| 434 if (print_readably) | |
| 563 | 435 printing_unreadable_object ("%s%s%s", header, name, trailer); |
| 428 | 436 |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
437 write_ascstring (printcharfun, header); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
438 write_ascstring (printcharfun, name); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
439 write_ascstring (printcharfun, trailer); |
| 428 | 440 } |
| 441 | |
| 1204 | 442 static const struct memory_description subr_description[] = { |
| 2551 | 443 { XD_DOC_STRING, offsetof (Lisp_Subr, doc), 0, { 0 }, XD_FLAG_NO_KKCC }, |
| 428 | 444 { XD_END } |
| 445 }; | |
| 446 | |
| 938 | 447 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("subr", subr, |
| 448 1, /*dumpable-flag*/ | |
| 449 0, print_subr, 0, 0, 0, | |
| 450 subr_description, | |
| 451 Lisp_Subr); | |
| 428 | 452 |
| 453 /************************************************************************/ | |
| 454 /* Entering the debugger */ | |
| 455 /************************************************************************/ | |
| 456 | |
| 853 | 457 static Lisp_Object |
| 458 current_warning_level (void) | |
| 459 { | |
| 460 if (inhibit_flags & ISSUE_WARNINGS_AT_DEBUG_LEVEL) | |
| 461 return Qdebug; | |
| 462 else | |
| 463 return Qwarning; | |
| 464 } | |
| 465 | |
| 428 | 466 /* Actually call the debugger. ARG is a list of args that will be |
| 467 passed to the debugger function, as follows; | |
| 468 | |
| 469 If due to frame exit, args are `exit' and the value being returned; | |
| 470 this function's value will be returned instead of that. | |
| 471 If due to error, args are `error' and a list of the args to `signal'. | |
| 472 If due to `apply' or `funcall' entry, one arg, `lambda'. | |
| 473 If due to `eval' entry, one arg, t. | |
| 474 | |
| 475 */ | |
| 476 | |
| 477 static Lisp_Object | |
| 478 call_debugger_259 (Lisp_Object arg) | |
| 479 { | |
| 480 return apply1 (Vdebugger, arg); | |
| 481 } | |
| 482 | |
| 483 /* Call the debugger, doing some encapsulation. We make sure we have | |
| 484 some room on the eval and specpdl stacks, and bind entering_debugger | |
| 485 to 1 during this call. This is used to trap errors that may occur | |
| 486 when entering the debugger (e.g. the value of `debugger' is invalid), | |
| 487 so that the debugger will not be recursively entered if debug-on-error | |
| 488 is set. (Otherwise, XEmacs would infinitely recurse, attempting to | |
| 489 enter the debugger.) entering_debugger gets reset to 0 as soon | |
| 490 as a backtrace is displayed, so that further errors can indeed be | |
| 491 handled normally. | |
| 492 | |
| 3025 | 493 We also establish a catch for `debugger'. If the debugger function |
| 428 | 494 throws to this instead of returning a value, it means that the user |
| 495 pressed 'c' (pretend like the debugger was never entered). The | |
| 496 function then returns Qunbound. (If the user pressed 'r', for | |
| 497 return a value, then the debugger function returns normally with | |
| 498 this value.) | |
| 499 | |
| 500 The difference between 'c' and 'r' is as follows: | |
| 501 | |
| 502 debug-on-call: | |
| 503 No difference. The call proceeds as normal. | |
| 504 debug-on-exit: | |
| 505 With 'r', the specified value is returned as the function's | |
| 506 return value. With 'c', the value that would normally be | |
| 507 returned is returned. | |
| 508 signal: | |
| 509 With 'r', the specified value is returned as the return | |
| 510 value of `signal'. (This is the only time that `signal' | |
| 511 can return, instead of making a non-local exit.) With `c', | |
| 512 `signal' will continue looking for handlers as if the | |
| 513 debugger was never entered, and will probably end up | |
| 514 throwing to a handler or to top-level. | |
| 515 */ | |
| 516 | |
| 517 static Lisp_Object | |
| 518 call_debugger (Lisp_Object arg) | |
| 519 { | |
| 520 int threw; | |
| 521 Lisp_Object val; | |
| 522 int speccount; | |
| 523 | |
| 853 | 524 debug_on_next_call = 0; |
| 525 | |
| 526 if (inhibit_flags & INHIBIT_ENTERING_DEBUGGER) | |
| 527 { | |
| 528 if (!(inhibit_flags & INHIBIT_WARNING_ISSUE)) | |
| 529 warn_when_safe | |
| 530 (Qdebugger, current_warning_level (), | |
| 531 "Unable to enter debugger within critical section"); | |
| 532 return Qunbound; | |
| 533 } | |
| 534 | |
| 428 | 535 if (lisp_eval_depth + 20 > max_lisp_eval_depth) |
| 536 max_lisp_eval_depth = lisp_eval_depth + 20; | |
| 537 if (specpdl_size + 40 > max_specpdl_size) | |
| 538 max_specpdl_size = specpdl_size + 40; | |
| 853 | 539 |
| 540 speccount = internal_bind_int (&entering_debugger, 1); | |
| 2532 | 541 val = internal_catch (Qdebugger, call_debugger_259, arg, &threw, 0, 0); |
| 428 | 542 |
| 771 | 543 return unbind_to_1 (speccount, ((threw) |
| 428 | 544 ? Qunbound /* Not returning a value */ |
| 545 : val)); | |
| 546 } | |
| 547 | |
| 548 /* Called when debug-on-exit behavior is called for. Enter the debugger | |
| 549 with the appropriate args for this. VAL is the exit value that is | |
| 550 about to be returned. */ | |
| 551 | |
| 552 static Lisp_Object | |
| 553 do_debug_on_exit (Lisp_Object val) | |
| 554 { | |
| 555 /* This is falsified by call_debugger */ | |
| 556 Lisp_Object v = call_debugger (list2 (Qexit, val)); | |
| 557 | |
| 558 return !UNBOUNDP (v) ? v : val; | |
| 559 } | |
| 560 | |
| 561 /* Called when debug-on-call behavior is called for. Enter the debugger | |
| 562 with the appropriate args for this. VAL is either t for a call | |
| 3025 | 563 through `eval' or `lambda' for a call through `funcall'. |
| 428 | 564 |
| 565 #### The differentiation here between EVAL and FUNCALL is bogus. | |
| 566 FUNCALL can be defined as | |
| 567 | |
| 568 (defmacro func (fun &rest args) | |
| 569 (cons (eval fun) args)) | |
| 570 | |
| 571 and should be treated as such. | |
| 572 */ | |
| 573 | |
| 574 static void | |
| 575 do_debug_on_call (Lisp_Object code) | |
| 576 { | |
| 577 debug_on_next_call = 0; | |
| 578 backtrace_list->debug_on_exit = 1; | |
| 579 call_debugger (list1 (code)); | |
| 580 } | |
| 581 | |
| 582 /* LIST is the value of one of the variables `debug-on-error', | |
| 583 `debug-on-signal', `stack-trace-on-error', or `stack-trace-on-signal', | |
| 584 and CONDITIONS is the list of error conditions associated with | |
| 585 the error being signalled. This returns non-nil if LIST | |
| 586 matches CONDITIONS. (A nil value for LIST does not match | |
| 587 CONDITIONS. A non-list value for LIST does match CONDITIONS. | |
| 588 A list matches CONDITIONS when one of the symbols in LIST is the | |
| 589 same as one of the symbols in CONDITIONS.) */ | |
| 590 | |
| 591 static int | |
| 592 wants_debugger (Lisp_Object list, Lisp_Object conditions) | |
| 593 { | |
| 594 if (NILP (list)) | |
| 595 return 0; | |
| 596 if (! CONSP (list)) | |
| 597 return 1; | |
| 598 | |
| 599 while (CONSP (conditions)) | |
| 600 { | |
| 2552 | 601 Lisp_Object curr, tail; |
| 602 curr = XCAR (conditions); | |
| 428 | 603 for (tail = list; CONSP (tail); tail = XCDR (tail)) |
| 2552 | 604 if (EQ (XCAR (tail), curr)) |
| 428 | 605 return 1; |
| 606 conditions = XCDR (conditions); | |
| 607 } | |
| 608 return 0; | |
| 609 } | |
| 610 | |
| 611 | |
| 612 /* Return 1 if an error with condition-symbols CONDITIONS, | |
| 613 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
|
614 according to debug-ignored-errors. */ |
| 428 | 615 |
| 616 static int | |
| 617 skip_debugger (Lisp_Object conditions, Lisp_Object data) | |
| 618 { | |
| 619 /* This function can GC */ | |
| 620 Lisp_Object tail; | |
| 621 int first_string = 1; | |
| 622 Lisp_Object error_message = Qnil; | |
| 623 | |
| 624 for (tail = Vdebug_ignored_errors; CONSP (tail); tail = XCDR (tail)) | |
| 625 { | |
| 626 if (STRINGP (XCAR (tail))) | |
| 627 { | |
| 628 if (first_string) | |
| 629 { | |
| 630 error_message = Ferror_message_string (data); | |
| 631 first_string = 0; | |
| 632 } | |
| 633 if (fast_lisp_string_match (XCAR (tail), error_message) >= 0) | |
| 634 return 1; | |
| 635 } | |
| 636 else | |
| 637 { | |
| 638 Lisp_Object contail; | |
| 639 | |
| 640 for (contail = conditions; CONSP (contail); contail = XCDR (contail)) | |
| 641 if (EQ (XCAR (tail), XCAR (contail))) | |
| 642 return 1; | |
| 643 } | |
| 644 } | |
| 645 | |
| 646 return 0; | |
| 647 } | |
| 648 | |
| 649 /* Actually generate a backtrace on STREAM. */ | |
| 650 | |
| 651 static Lisp_Object | |
| 652 backtrace_259 (Lisp_Object stream) | |
| 653 { | |
| 654 return Fbacktrace (stream, Qt); | |
| 655 } | |
| 656 | |
| 1130 | 657 #ifdef DEBUG_XEMACS |
| 658 | |
| 659 static void | |
| 660 trace_out_and_die (Lisp_Object err) | |
| 661 { | |
| 662 Fdisplay_error (err, Qt); | |
| 663 backtrace_259 (Qnil); | |
| 664 stderr_out ("XEmacs exiting to debugger.\n"); | |
| 665 Fforce_debugging_signal (Qt); | |
| 666 /* Unlikely to be reached */ | |
| 667 } | |
| 668 | |
| 669 #endif | |
| 670 | |
| 428 | 671 /* An error was signaled. Maybe call the debugger, if the `debug-on-error' |
| 672 etc. variables call for this. CONDITIONS is the list of conditions | |
| 673 associated with the error being signalled. SIG is the actual error | |
| 674 being signalled, and DATA is the associated data (these are exactly | |
| 675 the same as the arguments to `signal'). ACTIVE_HANDLERS is the | |
| 676 list of error handlers that are to be put in place while the debugger | |
| 677 is called. This is generally the remaining handlers that are | |
| 678 outside of the innermost handler trapping this error. This way, | |
| 679 if the same error occurs inside of the debugger, you usually don't get | |
| 680 the debugger entered recursively. | |
| 681 | |
| 682 This function returns Qunbound if it didn't call the debugger or if | |
| 683 the user asked (through 'c') that XEmacs should pretend like the | |
| 684 debugger was never entered. Otherwise, it returns the value | |
| 685 that the user specified with `r'. (Note that much of the time, | |
| 686 the user will abort with C-], and we will never have a chance to | |
| 687 return anything at all.) | |
| 688 | |
| 689 SIGNAL_VARS_ONLY means we should only look at debug-on-signal | |
| 690 and stack-trace-on-signal to control whether we do anything. | |
| 691 This is so that debug-on-error doesn't make handled errors | |
| 692 cause the debugger to get invoked. | |
| 693 | |
| 694 STACK_TRACE_DISPLAYED and DEBUGGER_ENTERED are used so that | |
| 695 those functions aren't done more than once in a single `signal' | |
| 696 session. */ | |
| 697 | |
| 698 static Lisp_Object | |
| 699 signal_call_debugger (Lisp_Object conditions, | |
| 700 Lisp_Object sig, Lisp_Object data, | |
| 701 Lisp_Object active_handlers, | |
| 702 int signal_vars_only, | |
| 703 int *stack_trace_displayed, | |
| 704 int *debugger_entered) | |
| 705 { | |
| 853 | 706 #ifdef PIGS_FLY_AND_ALL_C_CODE_CAN_HANDLE_GC_OCCURRING_ALMOST_ANYWHERE |
| 428 | 707 /* This function can GC */ |
| 853 | 708 #else /* reality check */ |
| 709 /* This function cannot GC because it inhibits GC during its operation */ | |
| 710 #endif | |
| 711 | |
| 428 | 712 Lisp_Object val = Qunbound; |
| 713 Lisp_Object all_handlers = Vcondition_handlers; | |
| 714 Lisp_Object temp_data = Qnil; | |
| 853 | 715 int outer_speccount = specpdl_depth(); |
| 716 int speccount; | |
| 717 | |
| 718 #ifdef PIGS_FLY_AND_ALL_C_CODE_CAN_HANDLE_GC_OCCURRING_ALMOST_ANYWHERE | |
| 428 | 719 struct gcpro gcpro1, gcpro2; |
| 720 GCPRO2 (all_handlers, temp_data); | |
| 853 | 721 #else |
| 722 begin_gc_forbidden (); | |
| 723 #endif | |
| 724 | |
| 725 speccount = specpdl_depth(); | |
| 428 | 726 |
| 727 Vcondition_handlers = active_handlers; | |
| 728 | |
| 729 temp_data = Fcons (sig, data); /* needed for skip_debugger */ | |
| 730 | |
| 731 if (!entering_debugger && !*stack_trace_displayed && !signal_vars_only | |
| 732 && wants_debugger (Vstack_trace_on_error, conditions) | |
| 733 && !skip_debugger (conditions, temp_data)) | |
| 734 { | |
| 735 specbind (Qdebug_on_error, Qnil); | |
| 736 specbind (Qstack_trace_on_error, Qnil); | |
| 737 specbind (Qdebug_on_signal, Qnil); | |
| 738 specbind (Qstack_trace_on_signal, Qnil); | |
| 739 | |
| 442 | 740 if (!noninteractive) |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
741 internal_with_output_to_temp_buffer (build_ascstring ("*Backtrace*"), |
| 442 | 742 backtrace_259, |
| 743 Qnil, | |
| 744 Qnil); | |
| 745 else /* in batch mode, we want this going to stderr. */ | |
| 746 backtrace_259 (Qnil); | |
| 771 | 747 unbind_to (speccount); |
| 428 | 748 *stack_trace_displayed = 1; |
| 749 } | |
| 750 | |
| 751 if (!entering_debugger && !*debugger_entered && !signal_vars_only | |
| 752 && (EQ (sig, Qquit) | |
| 753 ? debug_on_quit | |
| 754 : wants_debugger (Vdebug_on_error, conditions)) | |
| 755 && !skip_debugger (conditions, temp_data)) | |
| 756 { | |
| 757 debug_on_quit &= ~2; /* reset critical bit */ | |
| 1123 | 758 |
| 428 | 759 specbind (Qdebug_on_error, Qnil); |
| 760 specbind (Qstack_trace_on_error, Qnil); | |
| 761 specbind (Qdebug_on_signal, Qnil); | |
| 762 specbind (Qstack_trace_on_signal, Qnil); | |
| 763 | |
| 1130 | 764 #ifdef DEBUG_XEMACS |
| 765 if (noninteractive) | |
| 766 trace_out_and_die (Fcons (sig, data)); | |
| 767 #endif | |
| 768 | |
| 428 | 769 val = call_debugger (list2 (Qerror, (Fcons (sig, data)))); |
| 853 | 770 unbind_to (speccount); |
| 428 | 771 *debugger_entered = 1; |
| 772 } | |
| 773 | |
| 774 if (!entering_debugger && !*stack_trace_displayed | |
| 775 && wants_debugger (Vstack_trace_on_signal, conditions)) | |
| 776 { | |
| 777 specbind (Qdebug_on_error, Qnil); | |
| 778 specbind (Qstack_trace_on_error, Qnil); | |
| 779 specbind (Qdebug_on_signal, Qnil); | |
| 780 specbind (Qstack_trace_on_signal, Qnil); | |
| 781 | |
| 442 | 782 if (!noninteractive) |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
783 internal_with_output_to_temp_buffer (build_ascstring ("*Backtrace*"), |
| 442 | 784 backtrace_259, |
| 785 Qnil, | |
| 786 Qnil); | |
| 787 else /* in batch mode, we want this going to stderr. */ | |
| 788 backtrace_259 (Qnil); | |
| 771 | 789 unbind_to (speccount); |
| 428 | 790 *stack_trace_displayed = 1; |
| 791 } | |
| 792 | |
| 793 if (!entering_debugger && !*debugger_entered | |
| 794 && (EQ (sig, Qquit) | |
| 795 ? debug_on_quit | |
| 796 : wants_debugger (Vdebug_on_signal, conditions))) | |
| 797 { | |
| 798 debug_on_quit &= ~2; /* reset critical bit */ | |
| 1123 | 799 |
| 428 | 800 specbind (Qdebug_on_error, Qnil); |
| 801 specbind (Qstack_trace_on_error, Qnil); | |
| 802 specbind (Qdebug_on_signal, Qnil); | |
| 803 specbind (Qstack_trace_on_signal, Qnil); | |
| 804 | |
| 1130 | 805 #ifdef DEBUG_XEMACS |
| 806 if (noninteractive) | |
| 807 trace_out_and_die (Fcons (sig, data)); | |
| 808 #endif | |
| 809 | |
| 428 | 810 val = call_debugger (list2 (Qerror, (Fcons (sig, data)))); |
| 811 *debugger_entered = 1; | |
| 812 } | |
| 813 | |
| 853 | 814 #ifdef PIGS_FLY_AND_ALL_C_CODE_CAN_HANDLE_GC_OCCURRING_ALMOST_ANYWHERE |
| 428 | 815 UNGCPRO; |
| 853 | 816 #endif |
| 428 | 817 Vcondition_handlers = all_handlers; |
| 853 | 818 return unbind_to_1 (outer_speccount, val); |
| 428 | 819 } |
| 820 | |
| 821 | |
| 822 /************************************************************************/ | |
| 823 /* The basic special forms */ | |
| 824 /************************************************************************/ | |
| 825 | |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
826 /* Except for Fprogn(), the basic special operators below are only called |
| 428 | 827 from interpreted code. The byte compiler turns them into bytecodes. */ |
| 828 | |
| 829 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
|
830 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
|
831 The remaining ARGS are not evalled at all. |
| 428 | 832 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
|
833 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
834 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
|
835 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
|
836 |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
837 arguments: (&rest ARGS) |
| 428 | 838 */ |
| 839 (args)) | |
| 840 { | |
| 841 /* This function can GC */ | |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
842 Lisp_Object val = Qnil; |
| 428 | 843 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
844 LIST_LOOP_3 (arg, args, tail) |
| 428 | 845 { |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
846 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
|
847 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
848 if (NILP (XCDR (tail))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
849 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
850 /* 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
|
851 return val; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
852 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
853 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
854 return IGNORE_MULTIPLE_VALUES (val); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
855 } |
| 428 | 856 } |
| 857 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
858 return val; |
| 428 | 859 } |
| 860 | |
| 861 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
|
862 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
|
863 The remaining ARGS are not evalled at all. |
| 428 | 864 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
|
865 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
866 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
|
867 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
|
868 |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
869 arguments: (&rest ARGS) |
| 428 | 870 */ |
| 871 (args)) | |
| 872 { | |
| 873 /* This function can GC */ | |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
874 Lisp_Object val = Qt; |
| 428 | 875 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
876 LIST_LOOP_3 (arg, args, tail) |
| 428 | 877 { |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
878 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
|
879 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
880 if (NILP (XCDR (tail))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
881 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
882 /* 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
|
883 return val; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
884 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
885 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
886 return Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
887 } |
| 428 | 888 } |
| 889 | |
| 890 return val; | |
| 891 } | |
| 892 | |
| 893 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
|
894 If COND yields non-nil, do THEN, else do ELSE. |
| 428 | 895 Returns the value of THEN or the value of the last of the ELSE's. |
| 896 THEN must be one expression, but ELSE... can be zero or more expressions. | |
| 897 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
|
898 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
899 arguments: (COND THEN &rest ELSE) |
| 428 | 900 */ |
| 901 (args)) | |
| 902 { | |
| 903 /* This function can GC */ | |
| 904 Lisp_Object condition = XCAR (args); | |
| 905 Lisp_Object then_form = XCAR (XCDR (args)); | |
| 906 Lisp_Object else_forms = XCDR (XCDR (args)); | |
| 907 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
908 if (!NILP (IGNORE_MULTIPLE_VALUES (Feval (condition)))) |
| 428 | 909 return Feval (then_form); |
| 910 else | |
| 911 return Fprogn (else_forms); | |
| 912 } | |
| 913 | |
| 914 /* Macros `when' and `unless' are trivially defined in Lisp, | |
| 915 but it helps for bootstrapping to have them ALWAYS defined. */ | |
| 916 | |
| 917 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
|
918 If COND yields non-nil, do BODY, else return nil. |
| 428 | 919 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
|
920 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
921 arguments: (COND &rest BODY) |
| 428 | 922 */ |
| 923 (int nargs, Lisp_Object *args)) | |
| 924 { | |
| 925 Lisp_Object cond = args[0]; | |
| 926 Lisp_Object body; | |
| 853 | 927 |
| 428 | 928 switch (nargs) |
| 929 { | |
| 930 case 1: body = Qnil; break; | |
| 931 case 2: body = args[1]; break; | |
| 932 default: body = Fcons (Qprogn, Flist (nargs-1, args+1)); break; | |
| 933 } | |
| 934 | |
| 935 return list3 (Qif, cond, body); | |
| 936 } | |
| 937 | |
| 938 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
|
939 If COND yields nil, do BODY, else return nil. |
| 428 | 940 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
|
941 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
942 arguments: (COND &rest BODY) |
| 428 | 943 */ |
| 944 (int nargs, Lisp_Object *args)) | |
| 945 { | |
| 946 Lisp_Object cond = args[0]; | |
| 947 Lisp_Object body = Flist (nargs-1, args+1); | |
| 948 return Fcons (Qif, Fcons (cond, Fcons (Qnil, body))); | |
| 949 } | |
| 950 | |
| 951 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
|
952 Try each clause until one succeeds. |
| 428 | 953 Each clause looks like (CONDITION BODY...). CONDITION is evaluated |
| 954 and, if the value is non-nil, this clause succeeds: | |
| 955 then the expressions in BODY are evaluated and the last one's | |
| 956 value is the value of the cond-form. | |
| 957 If no clause succeeds, cond returns nil. | |
| 958 If a clause has one element, as in (CONDITION), | |
| 959 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
|
960 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
961 arguments: (&rest CLAUSES) |
| 428 | 962 */ |
| 963 (args)) | |
| 964 { | |
| 965 /* This function can GC */ | |
| 442 | 966 REGISTER Lisp_Object val; |
| 428 | 967 |
| 968 LIST_LOOP_2 (clause, args) | |
| 969 { | |
| 970 CHECK_CONS (clause); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
971 if (!NILP (val = IGNORE_MULTIPLE_VALUES (Feval (XCAR (clause))))) |
| 428 | 972 { |
| 973 if (!NILP (clause = XCDR (clause))) | |
| 974 { | |
| 975 CHECK_TRUE_LIST (clause); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
976 /* Pass back any multiple values here: */ |
| 428 | 977 val = Fprogn (clause); |
| 978 } | |
| 979 return val; | |
| 980 } | |
| 981 } | |
| 982 | |
| 983 return Qnil; | |
| 984 } | |
| 985 | |
| 986 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
|
987 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
|
988 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
989 arguments: (&rest BODY) |
| 428 | 990 */ |
| 991 (args)) | |
| 992 { | |
| 993 /* This function can GC */ | |
| 994 /* Caller must provide a true list in ARGS */ | |
| 442 | 995 REGISTER Lisp_Object val = Qnil; |
| 428 | 996 struct gcpro gcpro1; |
| 997 | |
| 998 GCPRO1 (args); | |
| 999 | |
| 1000 { | |
| 1001 LIST_LOOP_2 (form, args) | |
| 1002 val = Feval (form); | |
| 1003 } | |
| 1004 | |
| 1005 UNGCPRO; | |
| 1006 return val; | |
| 1007 } | |
| 1008 | |
| 1009 /* Fprog1() is the canonical example of a function that must GCPRO a | |
| 1010 Lisp_Object across calls to Feval(). */ | |
| 1011 | |
| 1012 DEFUN ("prog1", Fprog1, 1, UNEVALLED, 0, /* | |
| 1013 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
|
1014 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1015 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
|
1016 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
|
1017 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1018 arguments: (FIRST &rest BODY) |
| 428 | 1019 */ |
| 1020 (args)) | |
| 1021 { | |
| 1849 | 1022 Lisp_Object val; |
| 428 | 1023 struct gcpro gcpro1; |
| 1024 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1025 val = IGNORE_MULTIPLE_VALUES (Feval (Fcar (args))); |
| 428 | 1026 |
| 1027 GCPRO1 (val); | |
| 1028 | |
| 1029 { | |
| 1030 LIST_LOOP_2 (form, XCDR (args)) | |
| 1031 Feval (form); | |
| 1032 } | |
| 1033 | |
| 1034 UNGCPRO; | |
| 1035 return val; | |
| 1036 } | |
| 1037 | |
| 1038 DEFUN ("prog2", Fprog2, 2, UNEVALLED, 0, /* | |
| 1039 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
|
1040 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1041 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
|
1042 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
|
1043 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1044 arguments: (FIRST SECOND &rest BODY) |
| 428 | 1045 */ |
| 1046 (args)) | |
| 1047 { | |
| 1048 /* This function can GC */ | |
| 1849 | 1049 Lisp_Object val; |
| 428 | 1050 struct gcpro gcpro1; |
| 1051 | |
| 1052 Feval (XCAR (args)); | |
| 1053 args = XCDR (args); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1054 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1055 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
|
1056 |
| 428 | 1057 args = XCDR (args); |
| 1058 | |
| 1059 GCPRO1 (val); | |
| 1060 | |
| 442 | 1061 { |
| 1062 LIST_LOOP_2 (form, args) | |
| 1063 Feval (form); | |
| 1064 } | |
| 428 | 1065 |
| 1066 UNGCPRO; | |
| 1067 return val; | |
| 1068 } | |
| 1069 | |
| 1070 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
|
1071 Bind variables according to VARLIST then eval BODY. |
| 428 | 1072 The value of the last form in BODY is returned. |
| 1073 Each element of VARLIST is a symbol (which is bound to nil) | |
| 1074 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM). | |
| 1075 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
|
1076 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1077 arguments: (VARLIST &rest BODY) |
| 428 | 1078 */ |
| 1079 (args)) | |
| 1080 { | |
| 1081 /* This function can GC */ | |
| 1082 Lisp_Object varlist = XCAR (args); | |
| 1083 Lisp_Object body = XCDR (args); | |
| 1084 int speccount = specpdl_depth(); | |
| 1085 | |
| 1086 EXTERNAL_LIST_LOOP_3 (var, varlist, tail) | |
| 1087 { | |
| 1088 Lisp_Object symbol, value, tem; | |
| 1089 if (SYMBOLP (var)) | |
| 1090 symbol = var, value = Qnil; | |
| 1091 else | |
| 1092 { | |
| 1093 CHECK_CONS (var); | |
| 1094 symbol = XCAR (var); | |
| 1095 tem = XCDR (var); | |
| 1096 if (NILP (tem)) | |
| 1097 value = Qnil; | |
| 1098 else | |
| 1099 { | |
| 1100 CHECK_CONS (tem); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1101 value = IGNORE_MULTIPLE_VALUES (Feval (XCAR (tem))); |
| 428 | 1102 if (!NILP (XCDR (tem))) |
| 563 | 1103 sferror |
| 428 | 1104 ("`let' bindings can have only one value-form", var); |
| 1105 } | |
| 1106 } | |
| 1107 specbind (symbol, value); | |
| 1108 } | |
| 771 | 1109 return unbind_to_1 (speccount, Fprogn (body)); |
| 428 | 1110 } |
| 1111 | |
| 1112 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
|
1113 Bind variables according to VARLIST then eval BODY. |
| 428 | 1114 The value of the last form in BODY is returned. |
| 1115 Each element of VARLIST is a symbol (which is bound to nil) | |
| 1116 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM). | |
| 1117 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
|
1118 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1119 arguments: (VARLIST &rest BODY) |
| 428 | 1120 */ |
| 1121 (args)) | |
| 1122 { | |
| 1123 /* This function can GC */ | |
| 1124 Lisp_Object varlist = XCAR (args); | |
| 1125 Lisp_Object body = XCDR (args); | |
| 1126 int speccount = specpdl_depth(); | |
| 1127 Lisp_Object *temps; | |
| 1128 int idx; | |
| 1129 struct gcpro gcpro1; | |
| 1130 | |
| 1131 /* Make space to hold the values to give the bound variables. */ | |
| 1132 { | |
| 1133 int varcount; | |
| 1134 GET_EXTERNAL_LIST_LENGTH (varlist, varcount); | |
| 1135 temps = alloca_array (Lisp_Object, varcount); | |
| 1136 } | |
| 1137 | |
| 1138 /* Compute the values and store them in `temps' */ | |
| 1139 GCPRO1 (*temps); | |
| 1140 gcpro1.nvars = 0; | |
| 1141 | |
| 1142 idx = 0; | |
| 442 | 1143 { |
| 1144 LIST_LOOP_2 (var, varlist) | |
| 1145 { | |
| 1146 Lisp_Object *value = &temps[idx++]; | |
| 1147 if (SYMBOLP (var)) | |
| 1148 *value = Qnil; | |
| 1149 else | |
| 1150 { | |
| 1151 Lisp_Object tem; | |
| 1152 CHECK_CONS (var); | |
| 1153 tem = XCDR (var); | |
| 1154 if (NILP (tem)) | |
| 1155 *value = Qnil; | |
| 1156 else | |
| 1157 { | |
| 1158 CHECK_CONS (tem); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1159 *value = IGNORE_MULTIPLE_VALUES (Feval (XCAR (tem))); |
| 442 | 1160 gcpro1.nvars = idx; |
| 1161 | |
| 1162 if (!NILP (XCDR (tem))) | |
| 563 | 1163 sferror |
| 442 | 1164 ("`let' bindings can have only one value-form", var); |
| 1165 } | |
| 1166 } | |
| 1167 } | |
| 1168 } | |
| 428 | 1169 |
| 1170 idx = 0; | |
| 442 | 1171 { |
| 1172 LIST_LOOP_2 (var, varlist) | |
| 1173 { | |
| 1174 specbind (SYMBOLP (var) ? var : XCAR (var), temps[idx++]); | |
| 1175 } | |
| 1176 } | |
| 428 | 1177 |
| 1178 UNGCPRO; | |
| 1179 | |
| 771 | 1180 return unbind_to_1 (speccount, Fprogn (body)); |
| 428 | 1181 } |
| 1182 | |
| 1183 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
|
1184 If TEST yields non-nil, eval BODY... and repeat. |
| 428 | 1185 The order of execution is thus TEST, BODY, TEST, BODY and so on |
| 1186 until TEST returns nil. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1187 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1188 arguments: (TEST &rest BODY) |
| 428 | 1189 */ |
| 1190 (args)) | |
| 1191 { | |
| 1192 /* This function can GC */ | |
| 1193 Lisp_Object test = XCAR (args); | |
| 1194 Lisp_Object body = XCDR (args); | |
| 1195 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1196 while (!NILP (IGNORE_MULTIPLE_VALUES (Feval (test)))) |
| 428 | 1197 { |
| 1198 QUIT; | |
| 1199 Fprogn (body); | |
| 1200 } | |
| 1201 | |
| 1202 return Qnil; | |
| 1203 } | |
| 1204 | |
| 1205 DEFUN ("setq", Fsetq, 0, UNEVALLED, 0, /* | |
| 1206 \(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL. | |
| 1207 The symbols SYM are variables; they are literal (not evaluated). | |
| 1208 The values VAL are expressions; they are evaluated. | |
| 1209 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'. | |
| 1210 The second VAL is not computed until after the first SYM is set, and so on; | |
| 1211 each VAL can use the new value of variables set earlier in the `setq'. | |
| 1212 The return value of the `setq' form is the value of the last VAL. | |
| 1213 */ | |
| 1214 (args)) | |
| 1215 { | |
| 1216 /* This function can GC */ | |
| 1217 int nargs; | |
| 2421 | 1218 Lisp_Object retval = Qnil; |
| 428 | 1219 |
| 1220 GET_LIST_LENGTH (args, nargs); | |
| 1221 | |
| 1222 if (nargs & 1) /* Odd number of arguments? */ | |
| 1223 Fsignal (Qwrong_number_of_arguments, list2 (Qsetq, make_int (nargs))); | |
| 1224 | |
| 2421 | 1225 GC_PROPERTY_LIST_LOOP_3 (symbol, val, args) |
| 428 | 1226 { |
| 1227 val = Feval (val); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1228 val = IGNORE_MULTIPLE_VALUES (val); |
| 428 | 1229 Fset (symbol, val); |
| 2421 | 1230 retval = val; |
| 428 | 1231 } |
| 1232 | |
| 2421 | 1233 END_GC_PROPERTY_LIST_LOOP (symbol); |
| 1234 | |
| 1235 return retval; | |
| 428 | 1236 } |
| 1237 | |
| 1238 DEFUN ("quote", Fquote, 1, UNEVALLED, 0, /* | |
| 1239 Return the argument, without evaluating it. `(quote x)' yields `x'. | |
| 3794 | 1240 |
| 3842 | 1241 `quote' differs from `function' in that it is a hint that an expression is |
| 1242 data, not a function. In particular, under some circumstances the byte | |
| 1243 compiler will compile an expression quoted with `function', but it will | |
| 1244 never do so for an expression quoted with `quote'. These issues are most | |
| 1245 important for lambda expressions (see `lambda'). | |
| 1246 | |
| 1247 There is an alternative, more readable, reader syntax for `quote': a Lisp | |
| 1248 object preceded by `''. Thus, `'x' is equivalent to `(quote x)', in all | |
| 1249 contexts. A print function may use either. Internally the expression is | |
| 1250 represented as `(quote x)'). | |
| 428 | 1251 */ |
| 1252 (args)) | |
| 1253 { | |
| 1254 return XCAR (args); | |
| 1255 } | |
| 1256 | |
|
4744
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1257 /* 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
|
1258 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
|
1259 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
|
1260 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
|
1261 |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1262 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
|
1263 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
|
1264 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
|
1265 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
|
1266 self-quoting. |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1267 */ |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1268 (expr)) |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1269 { |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1270 if ((XTYPE (expr)) == Lisp_Type_Record) |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1271 { |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1272 switch (XRECORD_LHEADER (expr)->type) |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1273 { |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1274 case lrecord_type_symbol: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1275 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
|
1276 { |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1277 return expr; |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1278 } |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1279 break; |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1280 case lrecord_type_cons: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1281 if (EQ (XCAR (expr), Qlambda)) |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1282 { |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1283 return expr; |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1284 } |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1285 break; |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1286 |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1287 case lrecord_type_vector: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1288 case lrecord_type_string: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1289 case lrecord_type_compiled_function: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1290 case lrecord_type_bit_vector: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1291 case lrecord_type_float: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1292 case lrecord_type_hash_table: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1293 case lrecord_type_char_table: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1294 case lrecord_type_range_table: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1295 case lrecord_type_bignum: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1296 case lrecord_type_ratio: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1297 case lrecord_type_bigfloat: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1298 return expr; |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1299 } |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1300 return list2 (Qquote, expr); |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1301 } |
|
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 /* Fixnums and characters are self-quoting: */ |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1304 return expr; |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1305 } |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1306 |
| 428 | 1307 DEFUN ("function", Ffunction, 1, UNEVALLED, 0, /* |
| 3842 | 1308 Return the argument, without evaluating it. `(function x)' yields `x'. |
| 1309 | |
| 1310 `function' differs from `quote' in that it is a hint that an expression is | |
| 1311 a function, not data. In particular, under some circumstances the byte | |
| 1312 compiler will compile an expression quoted with `function', but it will | |
| 1313 never do so for an expression quoted with `quote'. However, the byte | |
| 1314 compiler will not compile an expression buried in a data structure such as | |
| 1315 a vector or a list which is not syntactically a function. These issues are | |
| 1316 most important for lambda expressions (see `lambda'). | |
| 1317 | |
| 1318 There is an alternative, more readable, reader syntax for `function': a Lisp | |
| 1319 object preceded by `#''. Thus, #'x is equivalent to (function x), in all | |
| 1320 contexts. A print function may use either. Internally the expression is | |
| 1321 represented as `(function x)'). | |
| 428 | 1322 */ |
| 1323 (args)) | |
| 1324 { | |
| 1325 return XCAR (args); | |
| 1326 } | |
| 1327 | |
| 1328 | |
| 1329 /************************************************************************/ | |
| 1330 /* Defining functions/variables */ | |
| 1331 /************************************************************************/ | |
| 1332 static Lisp_Object | |
| 1333 define_function (Lisp_Object name, Lisp_Object defn) | |
| 1334 { | |
| 1335 Ffset (name, defn); | |
|
4535
69a1eda3da06
Distinguish vars and functions in #'symbol-file, #'describe-{function,variable}
Aidan Kehoe <kehoea@parhasard.net>
parents:
4502
diff
changeset
|
1336 LOADHIST_ATTACH (Fcons (Qdefun, name)); |
| 428 | 1337 return name; |
| 1338 } | |
| 1339 | |
| 1340 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
|
1341 Define NAME as a function. |
| 428 | 1342 The definition is (lambda ARGLIST [DOCSTRING] BODY...). |
| 1343 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
|
1344 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1345 arguments: (NAME ARGLIST &optional DOCSTRING &rest BODY) |
| 428 | 1346 */ |
| 1347 (args)) | |
| 1348 { | |
| 1349 /* This function can GC */ | |
| 1350 return define_function (XCAR (args), | |
| 1351 Fcons (Qlambda, XCDR (args))); | |
| 1352 } | |
| 1353 | |
| 1354 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
|
1355 Define NAME as a macro. |
| 428 | 1356 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...). |
| 1357 When the macro is called, as in (NAME ARGS...), | |
| 1358 the function (lambda ARGLIST BODY...) is applied to | |
| 1359 the list ARGS... as it appears in the expression, | |
| 1360 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
|
1361 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1362 arguments: (NAME ARGLIST &optional DOCSTRING &rest BODY) |
| 428 | 1363 */ |
| 1364 (args)) | |
| 1365 { | |
| 1366 /* This function can GC */ | |
| 1367 return define_function (XCAR (args), | |
| 1368 Fcons (Qmacro, Fcons (Qlambda, XCDR (args)))); | |
| 1369 } | |
| 1370 | |
| 1371 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
|
1372 Define SYMBOL as a variable. |
| 428 | 1373 You are not required to define a variable in order to use it, |
| 1374 but the definition can supply documentation and an initial value | |
| 1375 in a way that tags can recognize. | |
| 1376 | |
| 1377 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is | |
| 1378 void. (However, when you evaluate a defvar interactively, it acts like a | |
| 1379 defconst: SYMBOL's value is always set regardless of whether it's currently | |
| 1380 void.) | |
| 1381 If SYMBOL is buffer-local, its default value is what is set; | |
| 1382 buffer-local values are not affected. | |
| 1383 INITVALUE and DOCSTRING are optional. | |
| 1384 If DOCSTRING starts with *, this variable is identified as a user option. | |
| 442 | 1385 This means that M-x set-variable recognizes it. |
| 428 | 1386 If INITVALUE is missing, SYMBOL's value is not set. |
| 1387 | |
| 1388 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
|
1389 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1390 arguments: (SYMBOL &optional INITVALUE DOCSTRING) |
| 428 | 1391 */ |
| 1392 (args)) | |
| 1393 { | |
| 1394 /* This function can GC */ | |
| 1395 Lisp_Object sym = XCAR (args); | |
| 1396 | |
| 1397 if (!NILP (args = XCDR (args))) | |
| 1398 { | |
| 1399 Lisp_Object val = XCAR (args); | |
| 1400 | |
| 1401 if (NILP (Fdefault_boundp (sym))) | |
| 1402 { | |
| 1403 struct gcpro gcpro1; | |
| 1404 GCPRO1 (val); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1405 val = IGNORE_MULTIPLE_VALUES (Feval (val)); |
| 428 | 1406 Fset_default (sym, val); |
| 1407 UNGCPRO; | |
| 1408 } | |
| 1409 | |
| 1410 if (!NILP (args = XCDR (args))) | |
| 1411 { | |
| 1412 Lisp_Object doc = XCAR (args); | |
| 1413 Fput (sym, Qvariable_documentation, doc); | |
| 1414 if (!NILP (args = XCDR (args))) | |
| 563 | 1415 signal_error (Qwrong_number_of_arguments, "too many arguments", Qunbound); |
| 428 | 1416 } |
| 1417 } | |
| 1418 | |
| 1419 #ifdef I18N3 | |
| 1420 if (!NILP (Vfile_domain)) | |
| 1421 Fput (sym, Qvariable_domain, Vfile_domain); | |
| 1422 #endif | |
| 1423 | |
| 1424 LOADHIST_ATTACH (sym); | |
| 1425 return sym; | |
| 1426 } | |
| 1427 | |
| 1428 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
|
1429 Define SYMBOL as a constant variable. |
| 428 | 1430 The intent is that programs do not change this value, but users may. |
| 1431 Always sets the value of SYMBOL to the result of evalling INITVALUE. | |
| 1432 If SYMBOL is buffer-local, its default value is what is set; | |
| 1433 buffer-local values are not affected. | |
| 1434 DOCSTRING is optional. | |
| 1435 If DOCSTRING starts with *, this variable is identified as a user option. | |
| 442 | 1436 This means that M-x set-variable recognizes it. |
| 428 | 1437 |
| 1438 Note: do not use `defconst' for user options in libraries that are not | |
| 1439 normally loaded, since it is useful for users to be able to specify | |
| 1440 their own values for such variables before loading the library. | |
| 1441 Since `defconst' unconditionally assigns the variable, | |
| 1442 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
|
1443 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1444 arguments: (SYMBOL &optional INITVALUE DOCSTRING) |
| 428 | 1445 */ |
| 1446 (args)) | |
| 1447 { | |
| 1448 /* This function can GC */ | |
| 1449 Lisp_Object sym = XCAR (args); | |
| 1450 Lisp_Object val = Feval (XCAR (args = XCDR (args))); | |
| 1451 struct gcpro gcpro1; | |
| 1452 | |
| 1453 GCPRO1 (val); | |
| 1454 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1455 val = IGNORE_MULTIPLE_VALUES (val); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1456 |
| 428 | 1457 Fset_default (sym, val); |
| 1458 | |
| 1459 UNGCPRO; | |
| 1460 | |
| 1461 if (!NILP (args = XCDR (args))) | |
| 1462 { | |
| 1463 Lisp_Object doc = XCAR (args); | |
| 1464 Fput (sym, Qvariable_documentation, doc); | |
| 1465 if (!NILP (args = XCDR (args))) | |
| 563 | 1466 signal_error (Qwrong_number_of_arguments, "too many arguments", Qunbound); |
| 428 | 1467 } |
| 1468 | |
| 1469 #ifdef I18N3 | |
| 1470 if (!NILP (Vfile_domain)) | |
| 1471 Fput (sym, Qvariable_domain, Vfile_domain); | |
| 1472 #endif | |
| 1473 | |
| 1474 LOADHIST_ATTACH (sym); | |
| 1475 return sym; | |
| 1476 } | |
| 1477 | |
|
4502
8748a3f7ceb4
Handle varalias chains, custom variables in #'user-variable-p.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4162
diff
changeset
|
1478 /* 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
|
1479 with the symbol variable aliases. */ |
| 428 | 1480 |
| 1481 DEFUN ("macroexpand-internal", Fmacroexpand_internal, 1, 2, 0, /* | |
| 1482 Return result of expanding macros at top level of FORM. | |
| 1483 If FORM is not a macro call, it is returned unchanged. | |
| 1484 Otherwise, the macro is expanded and the expansion is considered | |
| 1485 in place of FORM. When a non-macro-call results, it is returned. | |
| 1486 | |
| 442 | 1487 The second optional arg ENVIRONMENT specifies an environment of macro |
| 428 | 1488 definitions to shadow the loaded ones for use in file byte-compilation. |
| 1489 */ | |
| 442 | 1490 (form, environment)) |
| 428 | 1491 { |
| 1492 /* This function can GC */ | |
| 1493 /* With cleanups from Hallvard Furuseth. */ | |
| 1494 REGISTER Lisp_Object expander, sym, def, tem; | |
| 1495 | |
| 1496 while (1) | |
| 1497 { | |
| 1498 /* Come back here each time we expand a macro call, | |
| 1499 in case it expands into another macro call. */ | |
| 1500 if (!CONSP (form)) | |
| 1501 break; | |
| 1502 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */ | |
| 1503 def = sym = XCAR (form); | |
| 1504 tem = Qnil; | |
| 1505 /* Trace symbols aliases to other symbols | |
| 1506 until we get a symbol that is not an alias. */ | |
| 1507 while (SYMBOLP (def)) | |
| 1508 { | |
| 1509 QUIT; | |
| 1510 sym = def; | |
| 442 | 1511 tem = Fassq (sym, environment); |
| 428 | 1512 if (NILP (tem)) |
| 1513 { | |
| 1514 def = XSYMBOL (sym)->function; | |
| 1515 if (!UNBOUNDP (def)) | |
| 1516 continue; | |
| 1517 } | |
| 1518 break; | |
| 1519 } | |
| 442 | 1520 /* Right now TEM is the result from SYM in ENVIRONMENT, |
| 428 | 1521 and if TEM is nil then DEF is SYM's function definition. */ |
| 1522 if (NILP (tem)) | |
| 1523 { | |
| 442 | 1524 /* SYM is not mentioned in ENVIRONMENT. |
| 428 | 1525 Look at its function definition. */ |
| 1526 if (UNBOUNDP (def) | |
| 1527 || !CONSP (def)) | |
| 1528 /* Not defined or definition not suitable */ | |
| 1529 break; | |
| 1530 if (EQ (XCAR (def), Qautoload)) | |
| 1531 { | |
| 1532 /* Autoloading function: will it be a macro when loaded? */ | |
| 1533 tem = Felt (def, make_int (4)); | |
| 1534 if (EQ (tem, Qt) || EQ (tem, Qmacro)) | |
| 1535 { | |
| 1536 /* Yes, load it and try again. */ | |
| 970 | 1537 /* do_autoload GCPROs both arguments */ |
| 428 | 1538 do_autoload (def, sym); |
| 1539 continue; | |
| 1540 } | |
| 1541 else | |
| 1542 break; | |
| 1543 } | |
| 1544 else if (!EQ (XCAR (def), Qmacro)) | |
| 1545 break; | |
| 1546 else expander = XCDR (def); | |
| 1547 } | |
| 1548 else | |
| 1549 { | |
| 1550 expander = XCDR (tem); | |
| 1551 if (NILP (expander)) | |
| 1552 break; | |
| 1553 } | |
| 1554 form = apply1 (expander, XCDR (form)); | |
| 1555 } | |
| 1556 return form; | |
| 1557 } | |
| 1558 | |
| 1559 | |
| 1560 /************************************************************************/ | |
| 1561 /* Non-local exits */ | |
| 1562 /************************************************************************/ | |
| 1563 | |
| 1318 | 1564 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS |
| 1565 | |
| 1566 int | |
| 1567 proper_redisplay_wrapping_in_place (void) | |
| 1568 { | |
| 1569 return !in_display | |
| 1570 || ((get_inhibit_flags () & INTERNAL_INHIBIT_ERRORS) | |
| 1571 && (get_inhibit_flags () & INTERNAL_INHIBIT_THROWS)); | |
| 1572 } | |
| 1573 | |
| 1574 static void | |
| 1575 check_proper_critical_section_nonlocal_exit_protection (void) | |
| 1576 { | |
| 1577 assert_with_message | |
| 1578 (proper_redisplay_wrapping_in_place (), | |
| 1579 "Attempted non-local exit from within redisplay without being properly wrapped"); | |
| 1580 } | |
| 1581 | |
| 1582 static void | |
| 1583 check_proper_critical_section_lisp_protection (void) | |
| 1584 { | |
| 1585 assert_with_message | |
| 1586 (proper_redisplay_wrapping_in_place (), | |
| 1587 "Attempt to call Lisp code from within redisplay without being properly wrapped"); | |
| 1588 } | |
| 1589 | |
| 1590 #endif /* ERROR_CHECK_TRAPPING_PROBLEMS */ | |
| 1591 | |
| 428 | 1592 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
|
1593 Eval BODY allowing nonlocal exits using `throw'. |
| 428 | 1594 TAG is evalled to get the tag to use. Then the BODY is executed. |
| 3577 | 1595 Within BODY, (throw TAG VAL) with same (`eq') tag exits BODY and this `catch'. |
| 428 | 1596 If no throw happens, `catch' returns the value of the last BODY form. |
| 1597 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
|
1598 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1599 arguments: (TAG &rest BODY) |
| 428 | 1600 */ |
| 1601 (args)) | |
| 1602 { | |
| 1603 /* This function can GC */ | |
| 1604 Lisp_Object tag = Feval (XCAR (args)); | |
| 1605 Lisp_Object body = XCDR (args); | |
| 2532 | 1606 return internal_catch (tag, Fprogn, body, 0, 0, 0); |
| 428 | 1607 } |
| 1608 | |
| 1609 /* Set up a catch, then call C function FUNC on argument ARG. | |
| 1610 FUNC should return a Lisp_Object. | |
| 1611 This is how catches are done from within C code. */ | |
| 1612 | |
| 1613 Lisp_Object | |
| 1614 internal_catch (Lisp_Object tag, | |
| 1615 Lisp_Object (*func) (Lisp_Object arg), | |
| 1616 Lisp_Object arg, | |
| 853 | 1617 int * volatile threw, |
| 2532 | 1618 Lisp_Object * volatile thrown_tag, |
| 1619 Lisp_Object * volatile backtrace_before_throw) | |
| 428 | 1620 { |
| 1621 /* This structure is made part of the chain `catchlist'. */ | |
| 1622 struct catchtag c; | |
| 1623 | |
| 1624 /* Fill in the components of c, and put it on the list. */ | |
| 1625 c.next = catchlist; | |
| 1626 c.tag = tag; | |
| 853 | 1627 c.actual_tag = Qnil; |
| 2532 | 1628 c.backtrace = Qnil; |
| 428 | 1629 c.val = Qnil; |
| 1630 c.backlist = backtrace_list; | |
| 1631 #if 0 /* FSFmacs */ | |
| 1632 /* #### */ | |
| 1633 c.handlerlist = handlerlist; | |
| 1634 #endif | |
| 1635 c.lisp_eval_depth = lisp_eval_depth; | |
| 1636 c.pdlcount = specpdl_depth(); | |
| 1637 #if 0 /* FSFmacs */ | |
| 1638 c.poll_suppress_count = async_timer_suppress_count; | |
| 1639 #endif | |
| 1640 c.gcpro = gcprolist; | |
| 1641 catchlist = &c; | |
| 1642 | |
| 1643 /* Call FUNC. */ | |
| 1644 if (SETJMP (c.jmp)) | |
| 1645 { | |
| 1646 /* Throw works by a longjmp that comes right here. */ | |
| 1647 if (threw) *threw = 1; | |
| 853 | 1648 if (thrown_tag) *thrown_tag = c.actual_tag; |
| 2532 | 1649 if (backtrace_before_throw) *backtrace_before_throw = c.backtrace; |
| 428 | 1650 return c.val; |
| 1651 } | |
| 1652 c.val = (*func) (arg); | |
| 1653 if (threw) *threw = 0; | |
| 853 | 1654 if (thrown_tag) *thrown_tag = Qnil; |
| 428 | 1655 catchlist = c.next; |
| 853 | 1656 check_catchlist_sanity (); |
| 428 | 1657 return c.val; |
| 1658 } | |
| 1659 | |
| 1660 | |
| 1661 /* Unwind the specbind, catch, and handler stacks back to CATCH, and | |
| 1662 jump to that CATCH, returning VALUE as the value of that catch. | |
| 1663 | |
| 2297 | 1664 This is the guts of Fthrow and Fsignal; they differ only in the |
| 1665 way they choose the catch tag to throw to. A catch tag for a | |
| 428 | 1666 condition-case form has a TAG of Qnil. |
| 1667 | |
| 1668 Before each catch is discarded, unbind all special bindings and | |
| 1669 execute all unwind-protect clauses made above that catch. Unwind | |
| 1670 the handler stack as we go, so that the proper handlers are in | |
| 1671 effect for each unwind-protect clause we run. At the end, restore | |
| 1672 some static info saved in CATCH, and longjmp to the location | |
| 1673 specified in the | |
| 1674 | |
| 1675 This is used for correct unwinding in Fthrow and Fsignal. */ | |
| 1676 | |
| 2268 | 1677 static DECLARE_DOESNT_RETURN (unwind_to_catch (struct catchtag *, Lisp_Object, |
| 1678 Lisp_Object)); | |
| 1679 | |
| 1680 static DOESNT_RETURN | |
| 853 | 1681 unwind_to_catch (struct catchtag *c, Lisp_Object val, Lisp_Object tag) |
| 428 | 1682 { |
| 1683 REGISTER int last_time; | |
| 1684 | |
| 1685 /* Unwind the specbind, catch, and handler stacks back to CATCH | |
| 1686 Before each catch is discarded, unbind all special bindings | |
| 1687 and execute all unwind-protect clauses made above that catch. | |
| 1688 At the end, restore some static info saved in CATCH, | |
| 1689 and longjmp to the location specified. | |
| 1690 */ | |
| 1691 | |
| 1692 /* Save the value somewhere it will be GC'ed. | |
| 1693 (Can't overwrite tag slot because an unwind-protect may | |
| 1694 want to throw to this same tag, which isn't yet invalid.) */ | |
| 1695 c->val = val; | |
| 853 | 1696 c->actual_tag = tag; |
| 428 | 1697 |
| 1698 #if 0 /* FSFmacs */ | |
| 1699 /* Restore the polling-suppression count. */ | |
| 1700 set_poll_suppress_count (catch->poll_suppress_count); | |
| 1701 #endif | |
| 1702 | |
| 617 | 1703 #if 1 |
| 428 | 1704 do |
| 1705 { | |
| 1706 last_time = catchlist == c; | |
| 1707 | |
| 1708 /* Unwind the specpdl stack, and then restore the proper set of | |
| 1709 handlers. */ | |
| 771 | 1710 unbind_to (catchlist->pdlcount); |
| 428 | 1711 catchlist = catchlist->next; |
| 853 | 1712 check_catchlist_sanity (); |
| 428 | 1713 } |
| 1714 while (! last_time); | |
| 617 | 1715 #else |
| 1716 /* Former XEmacs code. This is definitely not as correct because | |
| 1717 there may be a number of catches we're unwinding, and a number | |
| 1718 of unwind-protects in the process. By not undoing the catches till | |
| 1719 the end, there may be invalid catches still current. (This would | |
| 1720 be a particular problem with code like this: | |
| 1721 | |
| 1722 (catch 'foo | |
| 1723 (call-some-code-which-does... | |
| 1724 (catch 'bar | |
| 1725 (unwind-protect | |
| 1726 (call-some-code-which-does... | |
| 1727 (catch 'bar | |
| 1728 (call-some-code-which-does... | |
| 1729 (throw 'foo nil)))) | |
| 1730 (throw 'bar nil))))) | |
| 1731 | |
| 1732 This would try to throw to the inner (catch 'bar)! | |
| 1733 | |
| 1734 --ben | |
| 1735 */ | |
| 428 | 1736 /* Unwind the specpdl stack */ |
| 771 | 1737 unbind_to (c->pdlcount); |
| 428 | 1738 catchlist = c->next; |
| 853 | 1739 check_catchlist_sanity (); |
| 617 | 1740 #endif /* Former code */ |
| 428 | 1741 |
| 1204 | 1742 UNWIND_GCPRO_TO (c->gcpro); |
| 1292 | 1743 if (profiling_active) |
| 1744 { | |
| 1745 while (backtrace_list != c->backlist) | |
| 1746 { | |
| 1747 profile_record_unwind (backtrace_list); | |
| 1748 backtrace_list = backtrace_list->next; | |
| 1749 } | |
| 1750 } | |
| 1751 else | |
| 1752 backtrace_list = c->backlist; | |
| 428 | 1753 lisp_eval_depth = c->lisp_eval_depth; |
| 1754 | |
| 442 | 1755 #ifdef DEFEND_AGAINST_THROW_RECURSION |
| 428 | 1756 throw_level = 0; |
| 1757 #endif | |
| 1758 LONGJMP (c->jmp, 1); | |
| 1759 } | |
| 1760 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1761 DECLARE_DOESNT_RETURN (throw_or_bomb_out (Lisp_Object, Lisp_Object, int, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1762 Lisp_Object, Lisp_Object)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1763 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1764 DOESNT_RETURN |
| 428 | 1765 throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p, |
| 1766 Lisp_Object sig, Lisp_Object data) | |
| 1767 { | |
| 442 | 1768 #ifdef DEFEND_AGAINST_THROW_RECURSION |
| 428 | 1769 /* die if we recurse more than is reasonable */ |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
5016
diff
changeset
|
1770 assert (++throw_level <= 20); |
| 428 | 1771 #endif |
| 1772 | |
| 1318 | 1773 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS |
| 1123 | 1774 check_proper_critical_section_nonlocal_exit_protection (); |
| 1318 | 1775 #endif |
| 1123 | 1776 |
| 428 | 1777 /* If bomb_out_p is t, this is being called from Fsignal as a |
| 1778 "last resort" when there is no handler for this error and | |
| 1779 the debugger couldn't be invoked, so we are throwing to | |
| 3025 | 1780 `top-level'. If this tag doesn't exist (happens during the |
| 428 | 1781 initialization stages) we would get in an infinite recursive |
| 1782 Fsignal/Fthrow loop, so instead we bomb out to the | |
| 1783 really-early-error-handler. | |
| 1784 | |
| 1785 Note that in fact the only time that the "last resort" | |
| 3025 | 1786 occurs is when there's no catch for `top-level' -- the |
| 1787 `top-level' catch and the catch-all error handler are | |
| 428 | 1788 established at the same time, in initial_command_loop/ |
| 1789 top_level_1. | |
| 1790 | |
| 853 | 1791 [[#### Fix this horrifitude!]] |
| 1792 | |
| 1793 I don't think this is horrifitude, just defensive programming. --ben | |
| 428 | 1794 */ |
| 1795 | |
| 1796 while (1) | |
| 1797 { | |
| 1798 REGISTER struct catchtag *c; | |
| 1799 | |
| 1800 #if 0 /* FSFmacs */ | |
| 1801 if (!NILP (tag)) /* #### */ | |
| 1802 #endif | |
| 1803 for (c = catchlist; c; c = c->next) | |
| 1804 { | |
| 2532 | 1805 if (EQ (c->tag, Vcatch_everything_tag)) |
| 1806 c->backtrace = maybe_get_trapping_problems_backtrace (); | |
| 853 | 1807 if (EQ (c->tag, tag) || EQ (c->tag, Vcatch_everything_tag)) |
| 1808 unwind_to_catch (c, val, tag); | |
| 428 | 1809 } |
| 1810 if (!bomb_out_p) | |
| 1811 tag = Fsignal (Qno_catch, list2 (tag, val)); | |
| 1812 else | |
| 1813 call1 (Qreally_early_error_handler, Fcons (sig, data)); | |
| 1814 } | |
| 1815 } | |
| 1816 | |
| 1817 /* See above, where CATCHLIST is defined, for a description of how | |
| 1818 Fthrow() works. | |
| 1819 | |
| 1820 Fthrow() is also called by Fsignal(), to do a non-local jump | |
| 1821 back to the appropriate condition-case handler after (maybe) | |
| 1822 the debugger is entered. In that case, TAG is the value | |
| 1823 of Vcondition_handlers that was in place just after the | |
| 1824 condition-case handler was set up. The car of this will be | |
| 1825 some data referring to the handler: Its car will be Qunbound | |
| 1826 (thus, this tag can never be generated by Lisp code), and | |
| 1827 its CDR will be the HANDLERS argument to condition_case_1() | |
| 1828 (either Qerror, Qt, or a list of handlers as in `condition-case'). | |
| 1829 This works fine because Fthrow() does not care what TAG was | |
| 1830 passed to it: it just looks up the catch list for something | |
| 1831 that is EQ() to TAG. When it finds it, it will longjmp() | |
| 1832 back to the place that established the catch (in this case, | |
| 1833 condition_case_1). See below for more info. | |
| 1834 */ | |
| 1835 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1836 DEFUN_NORETURN ("throw", Fthrow, 2, UNEVALLED, 0, /* |
| 444 | 1837 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
|
1838 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1839 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
|
1840 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
|
1841 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1842 arguments: (TAG VALUE) |
| 428 | 1843 */ |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1844 (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1845 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1846 int nargs; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1847 Lisp_Object tag, value; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1848 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1849 GET_LIST_LENGTH (args, nargs); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1850 if (nargs != 2) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1851 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1852 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
|
1853 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1854 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1855 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
|
1856 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1857 value = Feval (XCAR (XCDR (args))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1858 |
| 444 | 1859 throw_or_bomb_out (tag, value, 0, Qnil, Qnil); /* Doesn't return */ |
| 2268 | 1860 RETURN_NOT_REACHED (Qnil); |
| 428 | 1861 } |
| 1862 | |
| 1863 DEFUN ("unwind-protect", Funwind_protect, 1, UNEVALLED, 0, /* | |
| 1864 Do BODYFORM, protecting with UNWINDFORMS. | |
| 1865 If BODYFORM completes normally, its value is returned | |
| 1866 after executing the UNWINDFORMS. | |
| 1867 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
|
1868 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1869 arguments: (BODYFORM &rest UNWINDFORMS) |
| 428 | 1870 */ |
| 1871 (args)) | |
| 1872 { | |
| 1873 /* This function can GC */ | |
| 1874 int speccount = specpdl_depth(); | |
| 1875 | |
| 1876 record_unwind_protect (Fprogn, XCDR (args)); | |
| 771 | 1877 return unbind_to_1 (speccount, Feval (XCAR (args))); |
| 428 | 1878 } |
| 1879 | |
| 1880 | |
| 1881 /************************************************************************/ | |
| 1292 | 1882 /* Trapping errors */ |
| 428 | 1883 /************************************************************************/ |
| 1884 | |
| 1885 static Lisp_Object | |
| 1886 condition_bind_unwind (Lisp_Object loser) | |
| 1887 { | |
| 617 | 1888 /* There is no problem freeing stuff here like there is in |
| 1889 condition_case_unwind(), because there are no outside pointers | |
| 1890 (like the tag below in the catchlist) pointing to the objects. */ | |
| 853 | 1891 |
| 428 | 1892 /* ((handler-fun . handler-args) ... other handlers) */ |
| 1893 Lisp_Object tem = XCAR (loser); | |
| 853 | 1894 int first = 1; |
| 428 | 1895 |
| 1896 while (CONSP (tem)) | |
| 1897 { | |
| 853 | 1898 Lisp_Object victim = tem; |
| 1899 if (first && OPAQUE_PTRP (XCAR (victim))) | |
| 1900 free_opaque_ptr (XCAR (victim)); | |
| 1901 first = 0; | |
| 1902 tem = XCDR (victim); | |
| 428 | 1903 free_cons (victim); |
| 1904 } | |
| 1905 | |
| 1906 if (EQ (loser, Vcondition_handlers)) /* may have been rebound to some tail */ | |
| 853 | 1907 Vcondition_handlers = XCDR (loser); |
| 1908 | |
| 1909 free_cons (loser); | |
| 428 | 1910 return Qnil; |
| 1911 } | |
| 1912 | |
| 1913 static Lisp_Object | |
| 1914 condition_case_unwind (Lisp_Object loser) | |
| 1915 { | |
| 1916 /* ((<unbound> . clauses) ... other handlers */ | |
| 617 | 1917 /* NO! Doing this now leaves the tag deleted in a still-active |
| 1918 catch. With the recent changes to unwind_to_catch(), the | |
| 1919 evil situation might not happen any more; it certainly could | |
| 1920 happen before because it did. But it's very precarious to rely | |
| 1921 on something like this. #### Instead we should rewrite, adopting | |
| 1922 the FSF's mechanism with a struct handler instead of | |
| 1923 Vcondition_handlers; then we have NO Lisp-object structures used | |
| 1924 to hold all of the values, and there's no possibility either of | |
| 1925 crashes from freeing objects too quickly, or objects not getting | |
| 1926 freed and hanging around till the next GC. | |
| 1927 | |
| 1928 In practice, the extra consing here should not matter because | |
| 1929 it only happens when we throw past the condition-case, which almost | |
| 1930 always is the result of an error. Most of the time, there will be | |
| 1931 no error, and we will free the objects below in the main function. | |
| 1932 | |
| 1933 --ben | |
| 1934 | |
| 1935 DO NOT DO: free_cons (XCAR (loser)); | |
| 1936 */ | |
| 1937 | |
| 428 | 1938 if (EQ (loser, Vcondition_handlers)) /* may have been rebound to some tail */ |
| 617 | 1939 Vcondition_handlers = XCDR (loser); |
| 1940 | |
| 1941 /* DO NOT DO: free_cons (loser); */ | |
| 428 | 1942 return Qnil; |
| 1943 } | |
| 1944 | |
| 1945 /* Split out from condition_case_3 so that primitive C callers | |
| 1946 don't have to cons up a lisp handler form to be evaluated. */ | |
| 1947 | |
| 1948 /* Call a function BFUN of one argument BARG, trapping errors as | |
| 1949 specified by HANDLERS. If no error occurs that is indicated by | |
| 1950 HANDLERS as something to be caught, the return value of this | |
| 1951 function is the return value from BFUN. If such an error does | |
| 1952 occur, HFUN is called, and its return value becomes the | |
| 1953 return value of condition_case_1(). The second argument passed | |
| 1954 to HFUN will always be HARG. The first argument depends on | |
| 1955 HANDLERS: | |
| 1956 | |
| 1957 If HANDLERS is Qt, all errors (this includes QUIT, but not | |
| 1958 non-local exits with `throw') cause HFUN to be invoked, and VAL | |
| 1959 (the first argument to HFUN) is a cons (SIG . DATA) of the | |
| 1960 arguments passed to `signal'. The debugger is not invoked even if | |
| 1961 `debug-on-error' was set. | |
| 1962 | |
| 1963 A HANDLERS value of Qerror is the same as Qt except that the | |
| 1964 debugger is invoked if `debug-on-error' was set. | |
| 1965 | |
| 1966 Otherwise, HANDLERS should be a list of lists (CONDITION-NAME BODY ...) | |
| 1967 exactly as in `condition-case', and errors will be trapped | |
| 1968 as indicated in HANDLERS. VAL (the first argument to HFUN) will | |
| 1969 be a cons whose car is the cons (SIG . DATA) and whose CDR is the | |
| 1970 list (BODY ...) from the appropriate slot in HANDLERS. | |
| 1971 | |
| 1972 This function pushes HANDLERS onto the front of Vcondition_handlers | |
| 1973 (actually with a Qunbound marker as well -- see Fthrow() above | |
| 1974 for why), establishes a catch whose tag is this new value of | |
| 1975 Vcondition_handlers, and calls BFUN. When Fsignal() is called, | |
| 1976 it calls Fthrow(), setting TAG to this same new value of | |
| 1977 Vcondition_handlers and setting VAL to the same thing that will | |
| 1978 be passed to HFUN, as above. Fthrow() longjmp()s back to the | |
| 1979 jump point we just established, and we in turn just call the | |
| 1980 HFUN and return its value. | |
| 1981 | |
| 1982 For a real condition-case, HFUN will always be | |
| 1983 run_condition_case_handlers() and HARG is the argument VAR | |
| 1984 to condition-case. That function just binds VAR to the cons | |
| 1985 (SIG . DATA) that is the CAR of VAL, and calls the handler | |
| 1986 (BODY ...) that is the CDR of VAL. Note that before calling | |
| 1987 Fthrow(), Fsignal() restored Vcondition_handlers to the value | |
| 1988 it had *before* condition_case_1() was called. This maintains | |
| 1989 consistency (so that the state of things at exit of | |
| 1990 condition_case_1() is the same as at entry), and implies | |
| 1991 that the handler can signal the same error again (possibly | |
| 1992 after processing of its own), without getting in an infinite | |
| 1993 loop. */ | |
| 1994 | |
| 1995 Lisp_Object | |
| 1996 condition_case_1 (Lisp_Object handlers, | |
| 1997 Lisp_Object (*bfun) (Lisp_Object barg), | |
| 1998 Lisp_Object barg, | |
| 1999 Lisp_Object (*hfun) (Lisp_Object val, Lisp_Object harg), | |
| 2000 Lisp_Object harg) | |
| 2001 { | |
| 2002 int speccount = specpdl_depth(); | |
| 2003 struct catchtag c; | |
| 617 | 2004 struct gcpro gcpro1, gcpro2, gcpro3; |
| 428 | 2005 |
| 2006 #if 0 /* FSFmacs */ | |
| 2007 c.tag = Qnil; | |
| 2008 #else | |
| 2009 /* Do consing now so out-of-memory error happens up front */ | |
| 2010 /* (unbound . stuff) is a special condition-case kludge marker | |
| 2011 which is known specially by Fsignal. | |
| 617 | 2012 [[ This is an abomination, but to fix it would require either |
| 428 | 2013 making condition_case cons (a union of the conditions of the clauses) |
| 617 | 2014 or changing the byte-compiler output (no thanks).]] |
| 2015 | |
| 2016 The above comment is clearly wrong. FSF does not do it this way | |
| 2017 and did not change the byte-compiler output. Instead they use a | |
| 2018 `struct handler' to hold the various values (in place of our | |
| 2019 Vcondition_handlers) and chain them together, with pointers from | |
| 2020 the `struct catchtag' to the `struct handler'. We should perhaps | |
| 2021 consider moving to something similar, but not before I merge my | |
| 2022 stderr-proc workspace, which contains changes to these | |
| 2023 functions. --ben */ | |
| 428 | 2024 c.tag = noseeum_cons (noseeum_cons (Qunbound, handlers), |
| 2025 Vcondition_handlers); | |
| 2026 #endif | |
| 2027 c.val = Qnil; | |
| 853 | 2028 c.actual_tag = Qnil; |
| 2532 | 2029 c.backtrace = Qnil; |
| 428 | 2030 c.backlist = backtrace_list; |
| 2031 #if 0 /* FSFmacs */ | |
| 2032 /* #### */ | |
| 2033 c.handlerlist = handlerlist; | |
| 2034 #endif | |
| 2035 c.lisp_eval_depth = lisp_eval_depth; | |
| 2036 c.pdlcount = specpdl_depth(); | |
| 2037 #if 0 /* FSFmacs */ | |
| 2038 c.poll_suppress_count = async_timer_suppress_count; | |
| 2039 #endif | |
| 2040 c.gcpro = gcprolist; | |
| 2041 /* #### FSFmacs does the following statement *after* the setjmp(). */ | |
| 2042 c.next = catchlist; | |
| 2043 | |
| 2044 if (SETJMP (c.jmp)) | |
| 2045 { | |
| 2046 /* throw does ungcpro, etc */ | |
| 2047 return (*hfun) (c.val, harg); | |
| 2048 } | |
| 2049 | |
| 2050 record_unwind_protect (condition_case_unwind, c.tag); | |
| 2051 | |
| 2052 catchlist = &c; | |
| 2053 #if 0 /* FSFmacs */ | |
| 2054 h.handler = handlers; | |
| 2055 h.var = Qnil; | |
| 2056 h.next = handlerlist; | |
| 2057 h.tag = &c; | |
| 2058 handlerlist = &h; | |
| 2059 #else | |
| 2060 Vcondition_handlers = c.tag; | |
| 2061 #endif | |
| 2062 GCPRO1 (harg); /* Somebody has to gc-protect */ | |
| 2063 c.val = ((*bfun) (barg)); | |
| 2064 UNGCPRO; | |
| 617 | 2065 |
| 2066 /* Once we change `catchlist' below, the stuff in c will not be GCPRO'd. */ | |
| 2067 GCPRO3 (harg, c.val, c.tag); | |
| 2068 | |
| 428 | 2069 catchlist = c.next; |
| 853 | 2070 check_catchlist_sanity (); |
| 617 | 2071 /* Note: The unbind also resets Vcondition_handlers. Maybe we should |
| 2072 delete this here. */ | |
| 428 | 2073 Vcondition_handlers = XCDR (c.tag); |
| 771 | 2074 unbind_to (speccount); |
| 617 | 2075 |
| 2076 UNGCPRO; | |
| 2077 /* free the conses *after* the unbind, because the unbind will run | |
| 2078 condition_case_unwind above. */ | |
| 853 | 2079 free_cons (XCAR (c.tag)); |
| 2080 free_cons (c.tag); | |
| 617 | 2081 return c.val; |
| 428 | 2082 } |
| 2083 | |
| 2084 static Lisp_Object | |
| 2085 run_condition_case_handlers (Lisp_Object val, Lisp_Object var) | |
| 2086 { | |
| 2087 /* This function can GC */ | |
| 2088 #if 0 /* FSFmacs */ | |
| 2089 if (!NILP (h.var)) | |
| 2090 specbind (h.var, c.val); | |
| 2091 val = Fprogn (Fcdr (h.chosen_clause)); | |
| 2092 | |
| 2093 /* Note that this just undoes the binding of h.var; whoever | |
| 2094 longjmp()ed to us unwound the stack to c.pdlcount before | |
| 2095 throwing. */ | |
| 771 | 2096 unbind_to (c.pdlcount); |
| 428 | 2097 return val; |
| 2098 #else | |
| 2099 int speccount; | |
| 2100 | |
| 2101 CHECK_TRUE_LIST (val); | |
| 2102 if (NILP (var)) | |
| 2103 return Fprogn (Fcdr (val)); /* tail call */ | |
| 2104 | |
| 2105 speccount = specpdl_depth(); | |
| 2106 specbind (var, Fcar (val)); | |
| 2107 val = Fprogn (Fcdr (val)); | |
| 771 | 2108 return unbind_to_1 (speccount, val); |
| 428 | 2109 #endif |
| 2110 } | |
| 2111 | |
| 2112 /* Here for bytecode to call non-consfully. This is exactly like | |
| 2113 condition-case except that it takes three arguments rather | |
| 2114 than a single list of arguments. */ | |
| 2115 Lisp_Object | |
| 2116 condition_case_3 (Lisp_Object bodyform, Lisp_Object var, Lisp_Object handlers) | |
| 2117 { | |
| 2118 /* This function can GC */ | |
| 2119 EXTERNAL_LIST_LOOP_2 (handler, handlers) | |
| 2120 { | |
| 2121 if (NILP (handler)) | |
| 2122 ; | |
| 2123 else if (CONSP (handler)) | |
| 2124 { | |
| 2125 Lisp_Object conditions = XCAR (handler); | |
| 2126 /* CONDITIONS must a condition name or a list of condition names */ | |
| 2127 if (SYMBOLP (conditions)) | |
| 2128 ; | |
| 2129 else | |
| 2130 { | |
| 2131 EXTERNAL_LIST_LOOP_2 (condition, conditions) | |
| 2132 if (!SYMBOLP (condition)) | |
| 2133 goto invalid_condition_handler; | |
| 2134 } | |
| 2135 } | |
| 2136 else | |
| 2137 { | |
| 2138 invalid_condition_handler: | |
| 563 | 2139 sferror ("Invalid condition handler", handler); |
| 428 | 2140 } |
| 2141 } | |
| 2142 | |
| 2143 CHECK_SYMBOL (var); | |
| 2144 | |
| 2145 return condition_case_1 (handlers, | |
| 2146 Feval, bodyform, | |
| 2147 run_condition_case_handlers, | |
| 2148 var); | |
| 2149 } | |
| 2150 | |
| 2151 DEFUN ("condition-case", Fcondition_case, 2, UNEVALLED, 0, /* | |
| 2152 Regain control when an error is signalled. | |
| 2153 Usage looks like (condition-case VAR BODYFORM HANDLERS...). | |
| 2154 Executes BODYFORM and returns its value if no error happens. | |
| 2155 Each element of HANDLERS looks like (CONDITION-NAME BODY...) | |
| 2156 where the BODY is made of Lisp expressions. | |
| 2157 | |
| 771 | 2158 A typical usage of `condition-case' looks like this: |
| 2159 | |
| 2160 (condition-case nil | |
| 2161 ;; you need a progn here if you want more than one statement ... | |
| 2162 (progn | |
| 2163 (do-something) | |
| 2164 (do-something-else)) | |
| 2165 (error | |
| 2166 (issue-warning-or) | |
| 2167 ;; but strangely, you don't need one here. | |
| 2168 (return-a-value-etc) | |
| 2169 )) | |
| 2170 | |
| 428 | 2171 A handler is applicable to an error if CONDITION-NAME is one of the |
| 2172 error's condition names. If an error happens, the first applicable | |
| 2173 handler is run. As a special case, a CONDITION-NAME of t matches | |
| 2174 all errors, even those without the `error' condition name on them | |
| 2175 \(e.g. `quit'). | |
| 2176 | |
| 2177 The car of a handler may be a list of condition names | |
| 2178 instead of a single condition name. | |
| 2179 | |
| 2180 When a handler handles an error, | |
| 2181 control returns to the condition-case and the handler BODY... is executed | |
| 2182 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA). | |
| 2183 VAR may be nil; then you do not get access to the signal information. | |
| 2184 | |
| 2185 The value of the last BODY form is returned from the condition-case. | |
| 2186 See also the function `signal' for more info. | |
| 2187 | |
| 2188 Note that at the time the condition handler is invoked, the Lisp stack | |
| 2189 and the current catches, condition-cases, and bindings have all been | |
| 2190 popped back to the state they were in just before the call to | |
| 2191 `condition-case'. This means that resignalling the error from | |
| 2192 within the handler will not result in an infinite loop. | |
| 2193 | |
| 2194 If you want to establish an error handler that is called with the | |
| 2195 Lisp stack, bindings, etc. as they were when `signal' was called, | |
| 2196 rather than when the handler was set, use `call-with-condition-handler'. | |
| 2197 */ | |
| 2198 (args)) | |
| 2199 { | |
| 2200 /* This function can GC */ | |
| 2201 Lisp_Object var = XCAR (args); | |
| 2202 Lisp_Object bodyform = XCAR (XCDR (args)); | |
| 2203 Lisp_Object handlers = XCDR (XCDR (args)); | |
| 2204 return condition_case_3 (bodyform, var, handlers); | |
| 2205 } | |
| 2206 | |
| 2207 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
|
2208 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
|
2209 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
2210 This function is similar to `condition-case', but HANDLER is invoked |
| 428 | 2211 with the same environment (Lisp stack, bindings, catches, condition-cases) |
| 2212 that was current when `signal' was called, rather than when the handler | |
| 2213 was established. | |
| 2214 | |
| 2215 HANDLER should be a function of one argument, which is a cons of the args | |
| 2216 \(SIG . DATA) that were passed to `signal'. It is invoked whenever | |
| 2217 `signal' is called (this differs from `condition-case', which allows | |
| 2218 you to specify which errors are trapped). If the handler function | |
| 2219 returns, `signal' continues as if the handler were never invoked. | |
| 2220 \(It continues to look for handlers established earlier than this one, | |
| 2221 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
|
2222 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
2223 arguments: (HANDLER FUNCTION &rest ARGS) |
| 428 | 2224 */ |
| 2225 (int nargs, Lisp_Object *args)) /* Note! Args side-effected! */ | |
| 2226 { | |
| 2227 /* This function can GC */ | |
| 2228 int speccount = specpdl_depth(); | |
| 2229 Lisp_Object tem; | |
| 2230 | |
| 853 | 2231 tem = Ffunction_max_args (args[0]); |
| 2232 if (! (XINT (Ffunction_min_args (args[0])) <= 1 | |
| 2233 && (NILP (tem) || 1 <= XINT (tem)))) | |
| 2234 invalid_argument ("Must be function of one argument", args[0]); | |
| 2235 | |
| 2236 /* (handler-fun . handler-args) but currently there are no handler-args */ | |
| 428 | 2237 tem = noseeum_cons (list1 (args[0]), Vcondition_handlers); |
| 2238 record_unwind_protect (condition_bind_unwind, tem); | |
| 2239 Vcondition_handlers = tem; | |
| 2240 | |
| 2241 /* Caller should have GC-protected args */ | |
| 771 | 2242 return unbind_to_1 (speccount, Ffuncall (nargs - 1, args + 1)); |
| 428 | 2243 } |
| 2244 | |
| 853 | 2245 /* This is the C version of the above function. It calls FUN, passing it |
| 2246 ARG, first setting up HANDLER to catch signals in the environment in | |
| 2247 which they were signalled. (HANDLER is only invoked if there was no | |
| 2248 handler (either from condition-case or call-with-condition-handler) set | |
| 2249 later on that handled the signal; therefore, this is a real error. | |
| 2250 | |
| 2251 HANDLER is invoked with three arguments: the ERROR-SYMBOL and DATA as | |
| 2252 passed to `signal', and HANDLER_ARG. Originally I made HANDLER_ARG and | |
| 2253 ARG be void * to facilitate passing structures, but I changed to | |
| 2254 Lisp_Objects because all the other C interfaces to catch/condition-case/etc. | |
| 2255 take Lisp_Objects, and it is easy enough to use make_opaque_ptr() et al. | |
| 2256 to convert between Lisp_Objects and structure pointers. */ | |
| 2257 | |
| 2258 Lisp_Object | |
| 2259 call_with_condition_handler (Lisp_Object (*handler) (Lisp_Object, Lisp_Object, | |
| 2260 Lisp_Object), | |
| 2261 Lisp_Object handler_arg, | |
| 2262 Lisp_Object (*fun) (Lisp_Object), | |
| 2263 Lisp_Object arg) | |
| 2264 { | |
| 2265 /* This function can GC */ | |
| 1111 | 2266 int speccount = specpdl_depth (); |
| 853 | 2267 Lisp_Object tem; |
| 2268 | |
| 2269 /* ((handler-fun . (handler-arg . nil)) ... ) */ | |
| 1111 | 2270 tem = noseeum_cons (noseeum_cons (make_opaque_ptr ((void *) handler), |
| 853 | 2271 noseeum_cons (handler_arg, Qnil)), |
| 2272 Vcondition_handlers); | |
| 2273 record_unwind_protect (condition_bind_unwind, tem); | |
| 2274 Vcondition_handlers = tem; | |
| 2275 | |
| 2276 return unbind_to_1 (speccount, (*fun) (arg)); | |
| 2277 } | |
| 2278 | |
| 428 | 2279 static int |
| 2280 condition_type_p (Lisp_Object type, Lisp_Object conditions) | |
| 2281 { | |
| 2282 if (EQ (type, Qt)) | |
| 2283 /* (condition-case c # (t c)) catches -all- signals | |
| 2284 * Use with caution! */ | |
| 2285 return 1; | |
| 2286 | |
| 2287 if (SYMBOLP (type)) | |
| 2288 return !NILP (Fmemq (type, conditions)); | |
| 2289 | |
| 2290 for (; CONSP (type); type = XCDR (type)) | |
| 2291 if (!NILP (Fmemq (XCAR (type), conditions))) | |
| 2292 return 1; | |
| 2293 | |
| 2294 return 0; | |
| 2295 } | |
| 2296 | |
| 2297 static Lisp_Object | |
| 2298 return_from_signal (Lisp_Object value) | |
| 2299 { | |
| 2300 #if 1 | |
| 2301 /* Most callers are not prepared to handle gc if this | |
| 2302 returns. So, since this feature is not very useful, | |
| 2303 take it out. */ | |
| 2304 /* Have called debugger; return value to signaller */ | |
| 2305 return value; | |
| 2306 #else /* But the reality is that that stinks, because: */ | |
| 2307 /* GACK!!! Really want some way for debug-on-quit errors | |
| 2308 to be continuable!! */ | |
| 563 | 2309 signal_error (Qunimplemented, |
| 2310 "Returning a value from an error is no longer supported", | |
| 2311 Qunbound); | |
| 428 | 2312 #endif |
| 2313 } | |
| 2314 | |
| 2315 | |
| 2316 /************************************************************************/ | |
| 2317 /* the workhorse error-signaling function */ | |
| 2318 /************************************************************************/ | |
| 2319 | |
| 853 | 2320 /* This exists only for debugging purposes, as a place to put a breakpoint |
| 2321 that won't get signalled for errors occurring when | |
| 2322 call_with_suspended_errors() was invoked. */ | |
| 2323 | |
| 872 | 2324 /* Don't make static or it might be compiled away */ |
| 2325 void signal_1 (void); | |
| 2326 | |
| 2327 void | |
| 853 | 2328 signal_1 (void) |
| 2329 { | |
| 2330 } | |
| 2331 | |
| 428 | 2332 /* #### This function has not been synched with FSF. It diverges |
| 2333 significantly. */ | |
| 2334 | |
| 853 | 2335 /* The simplest external error function: it would be called |
| 2336 signal_continuable_error() in the terminology below, but it's | |
| 2337 Lisp-callable. */ | |
| 2338 | |
| 2339 DEFUN ("signal", Fsignal, 2, 2, 0, /* | |
| 2340 Signal a continuable error. Args are ERROR-SYMBOL, and associated DATA. | |
| 2341 An error symbol is a symbol defined using `define-error'. | |
| 2342 DATA should be a list. Its elements are printed as part of the error message. | |
| 2343 If the signal is handled, DATA is made available to the handler. | |
| 2344 See also the function `signal-error', and the functions to handle errors: | |
| 2345 `condition-case' and `call-with-condition-handler'. | |
| 2346 | |
| 2347 Note that this function can return, if the debugger is invoked and the | |
| 2348 user invokes the "return from signal" option. | |
| 2349 */ | |
| 2350 (error_symbol, data)) | |
| 428 | 2351 { |
| 2352 /* This function can GC */ | |
| 853 | 2353 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; |
| 2354 Lisp_Object conditions = Qnil; | |
| 2355 Lisp_Object handlers = Qnil; | |
| 428 | 2356 /* signal_call_debugger() could get called more than once |
| 2357 (once when a call-with-condition-handler is about to | |
| 2358 be dealt with, and another when a condition-case handler | |
| 2359 is about to be invoked). So make sure the debugger and/or | |
| 2360 stack trace aren't done more than once. */ | |
| 2361 int stack_trace_displayed = 0; | |
| 2362 int debugger_entered = 0; | |
| 853 | 2363 |
| 2364 /* Fsignal() is one of these functions that's called all the time | |
| 2365 with newly-created Lisp objects. We allow this; but we must GC- | |
| 2366 protect the objects because all sorts of weird stuff could | |
| 2367 happen. */ | |
| 2368 | |
| 2369 GCPRO4 (conditions, handlers, error_symbol, data); | |
| 2370 | |
| 2371 if (!(inhibit_flags & CALL_WITH_SUSPENDED_ERRORS)) | |
| 2372 signal_1 (); | |
| 428 | 2373 |
| 2374 if (!initialized) | |
| 2375 { | |
| 2376 /* who knows how much has been initialized? Safest bet is | |
| 2377 just to bomb out immediately. */ | |
| 771 | 2378 stderr_out ("Error before initialization is complete!\n"); |
| 2500 | 2379 ABORT (); |
| 428 | 2380 } |
| 2381 | |
| 3092 | 2382 #ifndef NEW_GC |
| 1123 | 2383 assert (!gc_in_progress); |
| 3092 | 2384 #endif /* not NEW_GC */ |
| 1123 | 2385 |
| 2386 /* We abort if in_display and we are not protected, as garbage | |
| 2387 collections and non-local exits will invariably be fatal, but in | |
| 2388 messy, difficult-to-debug ways. See enter_redisplay_critical_section(). | |
| 2389 */ | |
| 2390 | |
| 1318 | 2391 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS |
| 1123 | 2392 check_proper_critical_section_nonlocal_exit_protection (); |
| 1318 | 2393 #endif |
| 428 | 2394 |
| 853 | 2395 conditions = Fget (error_symbol, Qerror_conditions, Qnil); |
| 428 | 2396 |
| 2397 for (handlers = Vcondition_handlers; | |
| 2398 CONSP (handlers); | |
| 2399 handlers = XCDR (handlers)) | |
| 2400 { | |
| 2401 Lisp_Object handler_fun = XCAR (XCAR (handlers)); | |
| 2402 Lisp_Object handler_data = XCDR (XCAR (handlers)); | |
| 2403 Lisp_Object outer_handlers = XCDR (handlers); | |
| 2404 | |
| 2405 if (!UNBOUNDP (handler_fun)) | |
| 2406 { | |
| 2407 /* call-with-condition-handler */ | |
| 2408 Lisp_Object tem; | |
| 2409 Lisp_Object all_handlers = Vcondition_handlers; | |
| 2410 struct gcpro ngcpro1; | |
| 2411 NGCPRO1 (all_handlers); | |
| 2412 Vcondition_handlers = outer_handlers; | |
| 2413 | |
| 853 | 2414 tem = signal_call_debugger (conditions, error_symbol, data, |
| 428 | 2415 outer_handlers, 1, |
| 2416 &stack_trace_displayed, | |
| 2417 &debugger_entered); | |
| 2418 if (!UNBOUNDP (tem)) | |
| 2419 RETURN_NUNGCPRO (return_from_signal (tem)); | |
| 2420 | |
| 853 | 2421 if (OPAQUE_PTRP (handler_fun)) |
| 2422 { | |
| 2423 if (NILP (handler_data)) | |
| 2424 { | |
| 2425 Lisp_Object (*hfun) (Lisp_Object, Lisp_Object) = | |
| 2426 (Lisp_Object (*) (Lisp_Object, Lisp_Object)) | |
| 2427 (get_opaque_ptr (handler_fun)); | |
| 2428 | |
| 2429 tem = (*hfun) (error_symbol, data); | |
| 2430 } | |
| 2431 else | |
| 2432 { | |
| 2433 Lisp_Object (*hfun) (Lisp_Object, Lisp_Object, Lisp_Object) = | |
| 2434 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object)) | |
| 2435 (get_opaque_ptr (handler_fun)); | |
| 2436 | |
| 2437 assert (NILP (XCDR (handler_data))); | |
| 2438 tem = (*hfun) (error_symbol, data, XCAR (handler_data)); | |
| 2439 } | |
| 2440 } | |
| 2441 else | |
| 2442 { | |
| 2443 tem = Fcons (error_symbol, data); | |
| 2444 if (NILP (handler_data)) | |
| 2445 tem = call1 (handler_fun, tem); | |
| 2446 else | |
| 2447 { | |
| 2448 /* (This code won't be used (for now?).) */ | |
| 2449 struct gcpro nngcpro1; | |
| 2450 Lisp_Object args[3]; | |
| 2451 NNGCPRO1 (args[0]); | |
| 2452 nngcpro1.nvars = 3; | |
| 2453 args[0] = handler_fun; | |
| 2454 args[1] = tem; | |
| 2455 args[2] = handler_data; | |
| 2456 nngcpro1.var = args; | |
| 2457 tem = Fapply (3, args); | |
| 2458 NNUNGCPRO; | |
| 2459 } | |
| 2460 } | |
| 428 | 2461 NUNGCPRO; |
| 2462 #if 0 | |
| 2463 if (!EQ (tem, Qsignal)) | |
| 2464 return return_from_signal (tem); | |
| 2465 #endif | |
| 2466 /* If handler didn't throw, try another handler */ | |
| 2467 Vcondition_handlers = all_handlers; | |
| 2468 } | |
| 2469 | |
| 2470 /* It's a condition-case handler */ | |
| 2471 | |
| 2472 /* t is used by handlers for all conditions, set up by C code. | |
| 2473 * debugger is not called even if debug_on_error */ | |
| 2474 else if (EQ (handler_data, Qt)) | |
| 2475 { | |
| 2476 UNGCPRO; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
2477 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
|
2478 0, Qnil, Qnil); |
| 428 | 2479 } |
| 2480 /* `error' is used similarly to the way `t' is used, but in | |
| 2481 addition it invokes the debugger if debug_on_error. | |
| 2482 This is normally used for the outer command-loop error | |
| 2483 handler. */ | |
| 2484 else if (EQ (handler_data, Qerror)) | |
| 2485 { | |
| 853 | 2486 Lisp_Object tem = signal_call_debugger (conditions, error_symbol, |
| 2487 data, | |
| 428 | 2488 outer_handlers, 0, |
| 2489 &stack_trace_displayed, | |
| 2490 &debugger_entered); | |
| 2491 | |
| 2492 UNGCPRO; | |
| 2493 if (!UNBOUNDP (tem)) | |
| 2494 return return_from_signal (tem); | |
| 2495 | |
| 853 | 2496 tem = Fcons (error_symbol, data); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
2497 throw_or_bomb_out (handlers, tem, 0, Qnil, Qnil); |
| 428 | 2498 } |
| 2499 else | |
| 2500 { | |
| 2501 /* handler established by real (Lisp) condition-case */ | |
| 2502 Lisp_Object h; | |
| 2503 | |
| 2504 for (h = handler_data; CONSP (h); h = Fcdr (h)) | |
| 2505 { | |
| 2506 Lisp_Object clause = Fcar (h); | |
| 2507 Lisp_Object tem = Fcar (clause); | |
| 2508 | |
| 2509 if (condition_type_p (tem, conditions)) | |
| 2510 { | |
| 853 | 2511 tem = signal_call_debugger (conditions, error_symbol, data, |
| 428 | 2512 outer_handlers, 1, |
| 2513 &stack_trace_displayed, | |
| 2514 &debugger_entered); | |
| 2515 UNGCPRO; | |
| 2516 if (!UNBOUNDP (tem)) | |
| 2517 return return_from_signal (tem); | |
| 2518 | |
| 2519 /* Doesn't return */ | |
| 853 | 2520 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
|
2521 throw_or_bomb_out (handlers, tem, 0, Qnil, Qnil); |
| 428 | 2522 } |
| 2523 } | |
| 2524 } | |
| 2525 } | |
| 2526 | |
| 2527 /* If no handler is present now, try to run the debugger, | |
| 2528 and if that fails, throw to top level. | |
| 2529 | |
| 2530 #### The only time that no handler is present is during | |
| 2531 temacs or perhaps very early in XEmacs. In both cases, | |
| 3025 | 2532 there is no `top-level' catch. (That's why the |
| 428 | 2533 "bomb-out" hack was added.) |
| 2534 | |
| 853 | 2535 [[#### Fix this horrifitude!]] |
| 2536 | |
| 2537 I don't think this is horrifitude, but just defensive coding. --ben */ | |
| 2538 | |
| 2539 signal_call_debugger (conditions, error_symbol, data, Qnil, 0, | |
| 428 | 2540 &stack_trace_displayed, |
| 2541 &debugger_entered); | |
| 2542 UNGCPRO; | |
| 853 | 2543 throw_or_bomb_out (Qtop_level, Qt, 1, error_symbol, |
| 2544 data); /* Doesn't return */ | |
| 2268 | 2545 RETURN_NOT_REACHED (Qnil); |
| 428 | 2546 } |
| 2547 | |
| 2548 /****************** Error functions class 1 ******************/ | |
| 2549 | |
| 2550 /* Class 1: General functions that signal an error. | |
| 2551 These functions take an error type and a list of associated error | |
| 2552 data. */ | |
| 2553 | |
| 853 | 2554 /* No signal_continuable_error_1(); it's called Fsignal(). */ |
| 428 | 2555 |
| 2556 /* Signal a non-continuable error. */ | |
| 2557 | |
| 2558 DOESNT_RETURN | |
| 563 | 2559 signal_error_1 (Lisp_Object sig, Lisp_Object data) |
| 428 | 2560 { |
| 2561 for (;;) | |
| 2562 Fsignal (sig, data); | |
| 2563 } | |
| 853 | 2564 |
| 2565 #ifdef ERROR_CHECK_CATCH | |
| 2566 | |
| 2567 void | |
| 2568 check_catchlist_sanity (void) | |
| 2569 { | |
| 2570 #if 0 | |
| 2571 /* vou me tomar no cu! i just masked andy's missing-unbind | |
| 2572 bug! */ | |
| 442 | 2573 struct catchtag *c; |
| 2574 int found_error_tag = 0; | |
| 2575 | |
| 2576 for (c = catchlist; c; c = c->next) | |
| 2577 { | |
| 2578 if (EQ (c->tag, Qunbound_suspended_errors_tag)) | |
| 2579 { | |
| 2580 found_error_tag = 1; | |
| 2581 break; | |
| 2582 } | |
| 2583 } | |
| 2584 | |
| 2585 assert (found_error_tag || NILP (Vcurrent_error_state)); | |
| 853 | 2586 #endif /* vou me tomar no cul */ |
| 2587 } | |
| 2588 | |
| 2589 void | |
| 2590 check_specbind_stack_sanity (void) | |
| 2591 { | |
| 2592 } | |
| 2593 | |
| 2594 #endif /* ERROR_CHECK_CATCH */ | |
| 428 | 2595 |
| 2596 /* Signal a non-continuable error or display a warning or do nothing, | |
| 2597 according to ERRB. CLASS is the class of warning and should | |
| 2598 refer to what sort of operation is being done (e.g. Qtoolbar, | |
| 2599 Qresource, etc.). */ | |
| 2600 | |
| 2601 void | |
| 1204 | 2602 maybe_signal_error_1 (Lisp_Object sig, Lisp_Object data, Lisp_Object class_, |
| 578 | 2603 Error_Behavior errb) |
| 428 | 2604 { |
| 2605 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2606 return; | |
| 793 | 2607 else if (ERRB_EQ (errb, ERROR_ME_DEBUG_WARN)) |
| 1204 | 2608 warn_when_safe_lispobj (class_, Qdebug, Fcons (sig, data)); |
| 428 | 2609 else if (ERRB_EQ (errb, ERROR_ME_WARN)) |
| 1204 | 2610 warn_when_safe_lispobj (class_, Qwarning, Fcons (sig, data)); |
| 428 | 2611 else |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2612 signal_error_1 (sig, data); |
| 428 | 2613 } |
| 2614 | |
| 2615 /* Signal a continuable error or display a warning or do nothing, | |
| 2616 according to ERRB. */ | |
| 2617 | |
| 2618 Lisp_Object | |
| 563 | 2619 maybe_signal_continuable_error_1 (Lisp_Object sig, Lisp_Object data, |
| 1204 | 2620 Lisp_Object class_, Error_Behavior errb) |
| 428 | 2621 { |
| 2622 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2623 return Qnil; | |
| 793 | 2624 else if (ERRB_EQ (errb, ERROR_ME_DEBUG_WARN)) |
| 2625 { | |
| 1204 | 2626 warn_when_safe_lispobj (class_, Qdebug, Fcons (sig, data)); |
| 793 | 2627 return Qnil; |
| 2628 } | |
| 428 | 2629 else if (ERRB_EQ (errb, ERROR_ME_WARN)) |
| 2630 { | |
| 1204 | 2631 warn_when_safe_lispobj (class_, Qwarning, Fcons (sig, data)); |
| 428 | 2632 return Qnil; |
| 2633 } | |
| 2634 else | |
| 2635 return Fsignal (sig, data); | |
| 2636 } | |
| 2637 | |
| 2638 | |
| 2639 /****************** Error functions class 2 ******************/ | |
| 2640 | |
| 563 | 2641 /* Class 2: Signal an error with a string and an associated object. |
| 2642 Normally these functions are used to attach one associated object, | |
| 2643 but to attach no objects, specify Qunbound for FROB, and for more | |
| 2644 than one object, make a list of the objects with Qunbound as the | |
| 2645 first element. (If you have specifically two objects to attach, | |
| 2646 consider using the function in class 3 below.) These functions | |
| 2647 signal an error of a specified type, whose data is one or more | |
| 2648 objects (usually two), a string the related Lisp object(s) | |
| 2649 specified as FROB. */ | |
| 2650 | |
| 2651 /* Out of REASON and FROB, return a list of elements suitable for passing | |
| 2652 to signal_error_1(). */ | |
| 2653 | |
| 2654 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2655 build_error_data (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 2656 { |
| 2657 if (EQ (frob, Qunbound)) | |
| 2658 frob = Qnil; | |
| 2659 else if (CONSP (frob) && EQ (XCAR (frob), Qunbound)) | |
| 2660 frob = XCDR (frob); | |
| 2661 else | |
| 2662 frob = list1 (frob); | |
| 2663 if (!reason) | |
| 2664 return frob; | |
| 2665 else | |
| 771 | 2666 return Fcons (build_msg_string (reason), frob); |
| 563 | 2667 } |
| 2668 | |
| 2669 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2670 signal_error (Lisp_Object type, const Ascbyte *reason, Lisp_Object frob) |
| 563 | 2671 { |
| 2672 signal_error_1 (type, build_error_data (reason, frob)); | |
| 2673 } | |
| 2674 | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2675 /* 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
|
2676 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
|
2677 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
|
2678 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
|
2679 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
|
2680 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
|
2681 |
| 563 | 2682 void |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2683 maybe_signal_error (Lisp_Object type, const Ascbyte *reason, |
| 1204 | 2684 Lisp_Object frob, Lisp_Object class_, |
| 578 | 2685 Error_Behavior errb) |
| 563 | 2686 { |
| 2687 /* Optimization: */ | |
| 2688 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2689 return; | |
| 1204 | 2690 maybe_signal_error_1 (type, build_error_data (reason, frob), class_, errb); |
| 563 | 2691 } |
| 2692 | |
| 2693 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2694 signal_continuable_error (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2695 Lisp_Object frob) |
| 2696 { | |
| 2697 return Fsignal (type, build_error_data (reason, frob)); | |
| 2698 } | |
| 2699 | |
| 2700 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2701 maybe_signal_continuable_error (Lisp_Object type, const Ascbyte *reason, |
| 1204 | 2702 Lisp_Object frob, Lisp_Object class_, |
| 578 | 2703 Error_Behavior errb) |
| 563 | 2704 { |
| 2705 /* Optimization: */ | |
| 2706 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2707 return Qnil; | |
| 2708 return maybe_signal_continuable_error_1 (type, | |
| 2709 build_error_data (reason, frob), | |
| 1204 | 2710 class_, errb); |
| 563 | 2711 } |
| 2712 | |
| 2713 | |
| 2714 /****************** Error functions class 3 ******************/ | |
| 2715 | |
| 2716 /* Class 3: Signal an error with a string and two associated objects. | |
| 2717 These functions signal an error of a specified type, whose data | |
| 2718 is three objects, a string and two related Lisp objects. | |
| 2719 (The equivalent could be accomplished using the class 2 functions, | |
| 2720 but these are more convenient in this particular case.) */ | |
| 2721 | |
| 2722 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2723 signal_error_2 (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2724 Lisp_Object frob0, Lisp_Object frob1) |
| 2725 { | |
| 771 | 2726 signal_error_1 (type, list3 (build_msg_string (reason), frob0, |
| 563 | 2727 frob1)); |
| 2728 } | |
| 2729 | |
| 2730 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2731 maybe_signal_error_2 (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2732 Lisp_Object frob0, Lisp_Object frob1, |
| 1204 | 2733 Lisp_Object class_, Error_Behavior errb) |
| 563 | 2734 { |
| 2735 /* Optimization: */ | |
| 2736 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2737 return; | |
| 771 | 2738 maybe_signal_error_1 (type, list3 (build_msg_string (reason), frob0, |
| 1204 | 2739 frob1), class_, errb); |
| 563 | 2740 } |
| 2741 | |
| 2742 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2743 signal_continuable_error_2 (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2744 Lisp_Object frob0, Lisp_Object frob1) |
| 2745 { | |
| 771 | 2746 return Fsignal (type, list3 (build_msg_string (reason), frob0, |
| 563 | 2747 frob1)); |
| 2748 } | |
| 2749 | |
| 2750 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2751 maybe_signal_continuable_error_2 (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2752 Lisp_Object frob0, Lisp_Object frob1, |
| 1204 | 2753 Lisp_Object class_, Error_Behavior errb) |
| 563 | 2754 { |
| 2755 /* Optimization: */ | |
| 2756 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2757 return Qnil; | |
| 2758 return maybe_signal_continuable_error_1 | |
| 771 | 2759 (type, list3 (build_msg_string (reason), frob0, frob1), |
| 1204 | 2760 class_, errb); |
| 563 | 2761 } |
| 2762 | |
| 2763 | |
| 2764 /****************** Error functions class 4 ******************/ | |
| 2765 | |
| 2766 /* Class 4: Printf-like functions that signal an error. | |
| 442 | 2767 These functions signal an error of a specified type, whose data |
| 428 | 2768 is a single string, created using the arguments. */ |
| 2769 | |
| 2770 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2771 signal_ferror (Lisp_Object type, const Ascbyte *fmt, ...) |
| 442 | 2772 { |
| 2773 Lisp_Object obj; | |
| 2774 va_list args; | |
| 2775 | |
| 2776 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2777 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 442 | 2778 va_end (args); |
| 2779 | |
| 2780 /* Fsignal GC-protects its args */ | |
| 563 | 2781 signal_error (type, 0, obj); |
| 442 | 2782 } |
| 2783 | |
| 2784 void | |
| 1204 | 2785 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
|
2786 const Ascbyte *fmt, ...) |
| 442 | 2787 { |
| 2788 Lisp_Object obj; | |
| 2789 va_list args; | |
| 2790 | |
| 2791 /* Optimization: */ | |
| 2792 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2793 return; | |
| 2794 | |
| 2795 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2796 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 442 | 2797 va_end (args); |
| 2798 | |
| 2799 /* Fsignal GC-protects its args */ | |
| 1204 | 2800 maybe_signal_error (type, 0, obj, class_, errb); |
| 442 | 2801 } |
| 2802 | |
| 2803 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2804 signal_continuable_ferror (Lisp_Object type, const Ascbyte *fmt, ...) |
| 428 | 2805 { |
| 2806 Lisp_Object obj; | |
| 2807 va_list args; | |
| 2808 | |
| 2809 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2810 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 442 | 2811 va_end (args); |
| 2812 | |
| 2813 /* Fsignal GC-protects its args */ | |
| 2814 return Fsignal (type, list1 (obj)); | |
| 2815 } | |
| 2816 | |
| 2817 Lisp_Object | |
| 1204 | 2818 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
|
2819 Error_Behavior errb, const Ascbyte *fmt, ...) |
| 442 | 2820 { |
| 2821 Lisp_Object obj; | |
| 2822 va_list args; | |
| 2823 | |
| 2824 /* Optimization: */ | |
| 2825 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2826 return Qnil; | |
| 2827 | |
| 2828 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2829 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 442 | 2830 va_end (args); |
| 2831 | |
| 2832 /* Fsignal GC-protects its args */ | |
| 1204 | 2833 return maybe_signal_continuable_error (type, 0, obj, class_, errb); |
| 442 | 2834 } |
| 2835 | |
| 2836 | |
| 2837 /****************** Error functions class 5 ******************/ | |
| 2838 | |
| 563 | 2839 /* Class 5: Printf-like functions that signal an error. |
| 442 | 2840 These functions signal an error of a specified type, whose data |
| 563 | 2841 is a one or more objects, a string (created using the arguments) |
| 2842 and additional Lisp objects specified in FROB. (The syntax of FROB | |
| 2843 is the same as for class 2.) | |
| 2844 | |
| 2845 There is no need for a class 6 because you can always attach 2 | |
| 2846 objects using class 5 (for FROB, specify a list with three | |
| 2847 elements, the first of which is Qunbound), and these functions are | |
| 2848 not commonly used. | |
| 2849 */ | |
| 442 | 2850 |
| 2851 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2852 signal_ferror_with_frob (Lisp_Object type, Lisp_Object frob, const Ascbyte *fmt, |
| 563 | 2853 ...) |
| 442 | 2854 { |
| 2855 Lisp_Object obj; | |
| 2856 va_list args; | |
| 2857 | |
| 2858 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2859 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 442 | 2860 va_end (args); |
| 2861 | |
| 2862 /* Fsignal GC-protects its args */ | |
| 563 | 2863 signal_error_1 (type, Fcons (obj, build_error_data (0, frob))); |
| 442 | 2864 } |
| 2865 | |
| 2866 void | |
| 563 | 2867 maybe_signal_ferror_with_frob (Lisp_Object type, Lisp_Object frob, |
| 1204 | 2868 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
|
2869 const Ascbyte *fmt, ...) |
| 442 | 2870 { |
| 2871 Lisp_Object obj; | |
| 2872 va_list args; | |
| 2873 | |
| 2874 /* Optimization: */ | |
| 2875 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2876 return; | |
| 2877 | |
| 2878 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2879 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 428 | 2880 va_end (args); |
| 2881 | |
| 2882 /* Fsignal GC-protects its args */ | |
| 1204 | 2883 maybe_signal_error_1 (type, Fcons (obj, build_error_data (0, frob)), class_, |
| 563 | 2884 errb); |
| 428 | 2885 } |
| 2886 | |
| 2887 Lisp_Object | |
| 563 | 2888 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
|
2889 const Ascbyte *fmt, ...) |
| 428 | 2890 { |
| 2891 Lisp_Object obj; | |
| 2892 va_list args; | |
| 2893 | |
| 2894 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2895 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 428 | 2896 va_end (args); |
| 2897 | |
| 2898 /* Fsignal GC-protects its args */ | |
| 563 | 2899 return Fsignal (type, Fcons (obj, build_error_data (0, frob))); |
| 428 | 2900 } |
| 2901 | |
| 2902 Lisp_Object | |
| 563 | 2903 maybe_signal_continuable_ferror_with_frob (Lisp_Object type, Lisp_Object frob, |
| 1204 | 2904 Lisp_Object class_, |
| 578 | 2905 Error_Behavior errb, |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2906 const Ascbyte *fmt, ...) |
| 428 | 2907 { |
| 2908 Lisp_Object obj; | |
| 2909 va_list args; | |
| 2910 | |
| 2911 /* Optimization: */ | |
| 2912 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2913 return Qnil; | |
| 2914 | |
| 2915 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2916 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 428 | 2917 va_end (args); |
| 2918 | |
| 2919 /* Fsignal GC-protects its args */ | |
| 563 | 2920 return maybe_signal_continuable_error_1 (type, |
| 2921 Fcons (obj, | |
| 2922 build_error_data (0, frob)), | |
| 1204 | 2923 class_, errb); |
| 428 | 2924 } |
| 2925 | |
| 2926 | |
| 2927 /* This is what the QUIT macro calls to signal a quit */ | |
| 2928 void | |
| 2929 signal_quit (void) | |
| 2930 { | |
| 853 | 2931 /* This function cannot GC. GC is prohibited because most callers do |
| 2932 not expect GC occurring in QUIT. Remove this if/when that gets fixed. | |
| 2933 --ben */ | |
| 2934 | |
| 2935 int count; | |
| 2936 | |
| 428 | 2937 if (EQ (Vquit_flag, Qcritical)) |
| 2938 debug_on_quit |= 2; /* set critical bit. */ | |
| 2939 Vquit_flag = Qnil; | |
| 853 | 2940 count = begin_gc_forbidden (); |
| 428 | 2941 /* note that this is continuable. */ |
| 2942 Fsignal (Qquit, Qnil); | |
| 853 | 2943 unbind_to (count); |
| 428 | 2944 } |
| 2945 | |
| 2946 | |
| 563 | 2947 /************************ convenience error functions ***********************/ |
| 2948 | |
| 436 | 2949 Lisp_Object |
| 428 | 2950 signal_void_function_error (Lisp_Object function) |
| 2951 { | |
| 436 | 2952 return Fsignal (Qvoid_function, list1 (function)); |
| 428 | 2953 } |
| 2954 | |
| 436 | 2955 Lisp_Object |
| 428 | 2956 signal_invalid_function_error (Lisp_Object function) |
| 2957 { | |
| 436 | 2958 return Fsignal (Qinvalid_function, list1 (function)); |
| 428 | 2959 } |
| 2960 | |
| 436 | 2961 Lisp_Object |
| 428 | 2962 signal_wrong_number_of_arguments_error (Lisp_Object function, int nargs) |
| 2963 { | |
| 436 | 2964 return Fsignal (Qwrong_number_of_arguments, |
| 2965 list2 (function, make_int (nargs))); | |
| 428 | 2966 } |
| 2967 | |
| 2968 /* Used in list traversal macros for efficiency. */ | |
| 436 | 2969 DOESNT_RETURN |
| 428 | 2970 signal_malformed_list_error (Lisp_Object list) |
| 2971 { | |
| 563 | 2972 signal_error (Qmalformed_list, 0, list); |
| 428 | 2973 } |
| 2974 | |
| 436 | 2975 DOESNT_RETURN |
| 428 | 2976 signal_malformed_property_list_error (Lisp_Object list) |
| 2977 { | |
| 563 | 2978 signal_error (Qmalformed_property_list, 0, list); |
| 428 | 2979 } |
| 2980 | |
| 436 | 2981 DOESNT_RETURN |
| 428 | 2982 signal_circular_list_error (Lisp_Object list) |
| 2983 { | |
| 563 | 2984 signal_error (Qcircular_list, 0, list); |
| 428 | 2985 } |
| 2986 | |
| 436 | 2987 DOESNT_RETURN |
| 428 | 2988 signal_circular_property_list_error (Lisp_Object list) |
| 2989 { | |
| 563 | 2990 signal_error (Qcircular_property_list, 0, list); |
| 428 | 2991 } |
| 442 | 2992 |
| 2267 | 2993 /* Called from within emacs_doprnt_1, so REASON is not formatted. */ |
| 442 | 2994 DOESNT_RETURN |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2995 syntax_error (const Ascbyte *reason, Lisp_Object frob) |
| 442 | 2996 { |
| 563 | 2997 signal_error (Qsyntax_error, reason, frob); |
| 442 | 2998 } |
| 2999 | |
| 3000 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3001 syntax_error_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2) |
| 442 | 3002 { |
| 563 | 3003 signal_error_2 (Qsyntax_error, reason, frob1, frob2); |
| 3004 } | |
| 3005 | |
| 3006 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3007 maybe_syntax_error (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3008 Lisp_Object class_, Error_Behavior errb) |
| 3009 { | |
| 3010 maybe_signal_error (Qsyntax_error, reason, frob, class_, errb); | |
| 563 | 3011 } |
| 3012 | |
| 3013 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3014 sferror (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3015 { |
| 3016 signal_error (Qstructure_formation_error, reason, frob); | |
| 3017 } | |
| 3018 | |
| 3019 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3020 sferror_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2) |
| 563 | 3021 { |
| 3022 signal_error_2 (Qstructure_formation_error, reason, frob1, frob2); | |
| 3023 } | |
| 3024 | |
| 3025 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3026 maybe_sferror (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3027 Lisp_Object class_, Error_Behavior errb) |
| 3028 { | |
| 3029 maybe_signal_error (Qstructure_formation_error, reason, frob, class_, errb); | |
| 442 | 3030 } |
| 3031 | |
| 3032 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3033 invalid_argument (const Ascbyte *reason, Lisp_Object frob) |
| 442 | 3034 { |
| 563 | 3035 signal_error (Qinvalid_argument, reason, frob); |
| 442 | 3036 } |
| 3037 | |
| 3038 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3039 invalid_argument_2 (const Ascbyte *reason, Lisp_Object frob1, |
| 609 | 3040 Lisp_Object frob2) |
| 442 | 3041 { |
| 563 | 3042 signal_error_2 (Qinvalid_argument, reason, frob1, frob2); |
| 3043 } | |
| 3044 | |
| 3045 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3046 maybe_invalid_argument (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3047 Lisp_Object class_, Error_Behavior errb) |
| 3048 { | |
| 3049 maybe_signal_error (Qinvalid_argument, reason, frob, class_, errb); | |
| 563 | 3050 } |
| 3051 | |
| 3052 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3053 invalid_constant (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3054 { |
| 3055 signal_error (Qinvalid_constant, reason, frob); | |
| 3056 } | |
| 3057 | |
| 3058 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3059 invalid_constant_2 (const Ascbyte *reason, Lisp_Object frob1, |
| 609 | 3060 Lisp_Object frob2) |
| 563 | 3061 { |
| 3062 signal_error_2 (Qinvalid_constant, reason, frob1, frob2); | |
| 3063 } | |
| 3064 | |
| 3065 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3066 maybe_invalid_constant (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3067 Lisp_Object class_, Error_Behavior errb) |
| 3068 { | |
| 3069 maybe_signal_error (Qinvalid_constant, reason, frob, class_, errb); | |
| 442 | 3070 } |
| 3071 | |
| 3072 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3073 invalid_operation (const Ascbyte *reason, Lisp_Object frob) |
| 442 | 3074 { |
| 563 | 3075 signal_error (Qinvalid_operation, reason, frob); |
| 442 | 3076 } |
| 3077 | |
| 3078 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3079 invalid_operation_2 (const Ascbyte *reason, Lisp_Object frob1, |
| 609 | 3080 Lisp_Object frob2) |
| 442 | 3081 { |
| 563 | 3082 signal_error_2 (Qinvalid_operation, reason, frob1, frob2); |
| 3083 } | |
| 3084 | |
| 3085 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3086 maybe_invalid_operation (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3087 Lisp_Object class_, Error_Behavior errb) |
| 3088 { | |
| 3089 maybe_signal_error (Qinvalid_operation, reason, frob, class_, errb); | |
| 442 | 3090 } |
| 3091 | |
| 3092 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3093 invalid_change (const Ascbyte *reason, Lisp_Object frob) |
| 442 | 3094 { |
| 563 | 3095 signal_error (Qinvalid_change, reason, frob); |
| 442 | 3096 } |
| 3097 | |
| 3098 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3099 invalid_change_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2) |
| 442 | 3100 { |
| 563 | 3101 signal_error_2 (Qinvalid_change, reason, frob1, frob2); |
| 3102 } | |
| 3103 | |
| 3104 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3105 maybe_invalid_change (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3106 Lisp_Object class_, Error_Behavior errb) |
| 3107 { | |
| 3108 maybe_signal_error (Qinvalid_change, reason, frob, class_, errb); | |
| 563 | 3109 } |
| 3110 | |
| 3111 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3112 invalid_state (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3113 { |
| 3114 signal_error (Qinvalid_state, reason, frob); | |
| 3115 } | |
| 3116 | |
| 3117 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3118 invalid_state_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2) |
| 563 | 3119 { |
| 3120 signal_error_2 (Qinvalid_state, reason, frob1, frob2); | |
| 3121 } | |
| 3122 | |
| 3123 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3124 maybe_invalid_state (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3125 Lisp_Object class_, Error_Behavior errb) |
| 3126 { | |
| 3127 maybe_signal_error (Qinvalid_state, reason, frob, class_, errb); | |
| 563 | 3128 } |
| 3129 | |
| 3130 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3131 wtaerror (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3132 { |
| 3133 signal_error (Qwrong_type_argument, reason, frob); | |
| 3134 } | |
| 3135 | |
| 3136 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3137 stack_overflow (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3138 { |
| 3139 signal_error (Qstack_overflow, reason, frob); | |
| 3140 } | |
| 3141 | |
| 3142 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3143 out_of_memory (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3144 { |
| 3145 signal_error (Qout_of_memory, reason, frob); | |
| 3146 } | |
| 3147 | |
| 428 | 3148 |
| 3149 /************************************************************************/ | |
| 3150 /* User commands */ | |
| 3151 /************************************************************************/ | |
| 3152 | |
| 3153 DEFUN ("commandp", Fcommandp, 1, 1, 0, /* | |
| 3154 Return t if FUNCTION makes provisions for interactive calling. | |
| 3155 This means it contains a description for how to read arguments to give it. | |
| 3156 The value is nil for an invalid function or a symbol with no function | |
| 3157 definition. | |
| 3158 | |
| 3159 Interactively callable functions include | |
| 3160 | |
| 3161 -- strings and vectors (treated as keyboard macros) | |
| 3162 -- lambda-expressions that contain a top-level call to `interactive' | |
| 3163 -- autoload definitions made by `autoload' with non-nil fourth argument | |
| 3164 (i.e. the interactive flag) | |
| 3165 -- compiled-function objects with a non-nil `compiled-function-interactive' | |
| 3166 value | |
| 3167 -- subrs (built-in functions) that are interactively callable | |
| 3168 | |
| 3169 Also, a symbol satisfies `commandp' if its function definition does so. | |
| 3170 */ | |
| 3171 (function)) | |
| 3172 { | |
| 3173 Lisp_Object fun = indirect_function (function, 0); | |
| 3174 | |
| 3175 if (COMPILED_FUNCTIONP (fun)) | |
| 3176 return XCOMPILED_FUNCTION (fun)->flags.interactivep ? Qt : Qnil; | |
| 3177 | |
| 3178 /* Lists may represent commands. */ | |
| 3179 if (CONSP (fun)) | |
| 3180 { | |
| 3181 Lisp_Object funcar = XCAR (fun); | |
| 3182 if (EQ (funcar, Qlambda)) | |
| 3183 return Fassq (Qinteractive, Fcdr (Fcdr (fun))); | |
| 3184 if (EQ (funcar, Qautoload)) | |
| 3185 return Fcar (Fcdr (Fcdr (Fcdr (fun)))); | |
| 3186 else | |
| 3187 return Qnil; | |
| 3188 } | |
| 3189 | |
| 3190 /* Emacs primitives are interactive if their DEFUN specifies an | |
| 3191 interactive spec. */ | |
| 3192 if (SUBRP (fun)) | |
| 3193 return XSUBR (fun)->prompt ? Qt : Qnil; | |
| 3194 | |
| 3195 /* Strings and vectors are keyboard macros. */ | |
| 3196 if (VECTORP (fun) || STRINGP (fun)) | |
| 3197 return Qt; | |
| 3198 | |
| 3199 /* Everything else (including Qunbound) is not a command. */ | |
| 3200 return Qnil; | |
| 3201 } | |
| 3202 | |
| 3203 DEFUN ("command-execute", Fcommand_execute, 1, 3, 0, /* | |
| 3204 Execute CMD as an editor command. | |
| 3205 CMD must be an object that satisfies the `commandp' predicate. | |
| 3206 Optional second arg RECORD-FLAG is as in `call-interactively'. | |
| 3207 The argument KEYS specifies the value to use instead of (this-command-keys) | |
| 3208 when reading the arguments. | |
| 3209 */ | |
| 444 | 3210 (cmd, record_flag, keys)) |
| 428 | 3211 { |
| 3212 /* This function can GC */ | |
| 3213 Lisp_Object prefixarg; | |
| 3214 Lisp_Object final = cmd; | |
| 4162 | 3215 PROFILE_DECLARE(); |
| 428 | 3216 struct console *con = XCONSOLE (Vselected_console); |
| 3217 | |
| 3218 prefixarg = con->prefix_arg; | |
| 3219 con->prefix_arg = Qnil; | |
| 3220 Vcurrent_prefix_arg = prefixarg; | |
| 3221 debug_on_next_call = 0; /* #### from FSFmacs; correct? */ | |
| 3222 | |
| 3223 if (SYMBOLP (cmd) && !NILP (Fget (cmd, Qdisabled, Qnil))) | |
| 733 | 3224 return run_hook (Qdisabled_command_hook); |
| 428 | 3225 |
| 3226 for (;;) | |
| 3227 { | |
| 3228 final = indirect_function (cmd, 1); | |
| 3229 if (CONSP (final) && EQ (Fcar (final), Qautoload)) | |
| 970 | 3230 { |
| 3231 /* do_autoload GCPROs both arguments */ | |
| 3232 do_autoload (final, cmd); | |
| 3233 } | |
| 428 | 3234 else |
| 3235 break; | |
| 3236 } | |
| 3237 | |
| 3238 if (CONSP (final) || SUBRP (final) || COMPILED_FUNCTIONP (final)) | |
| 3239 { | |
| 3240 backtrace.function = &Qcall_interactively; | |
| 3241 backtrace.args = &cmd; | |
| 3242 backtrace.nargs = 1; | |
| 3243 backtrace.evalargs = 0; | |
| 1292 | 3244 backtrace.pdlcount = specpdl_depth (); |
| 428 | 3245 backtrace.debug_on_exit = 0; |
| 1292 | 3246 backtrace.function_being_called = 0; |
| 428 | 3247 PUSH_BACKTRACE (backtrace); |
| 3248 | |
| 1292 | 3249 PROFILE_ENTER_FUNCTION (); |
| 444 | 3250 final = Fcall_interactively (cmd, record_flag, keys); |
| 1292 | 3251 PROFILE_EXIT_FUNCTION (); |
| 428 | 3252 |
| 3253 POP_BACKTRACE (backtrace); | |
| 3254 return final; | |
| 3255 } | |
| 3256 else if (STRINGP (final) || VECTORP (final)) | |
| 3257 { | |
| 3258 return Fexecute_kbd_macro (final, prefixarg); | |
| 3259 } | |
| 3260 else | |
| 3261 { | |
| 3262 Fsignal (Qwrong_type_argument, | |
| 3263 Fcons (Qcommandp, | |
| 3264 (EQ (cmd, final) | |
| 3265 ? list1 (cmd) | |
| 3266 : list2 (cmd, final)))); | |
| 3267 return Qnil; | |
| 3268 } | |
| 3269 } | |
| 3270 | |
| 3271 DEFUN ("interactive-p", Finteractive_p, 0, 0, 0, /* | |
| 3272 Return t if function in which this appears was called interactively. | |
| 3273 This means that the function was called with call-interactively (which | |
| 3274 includes being called as the binding of a key) | |
| 3275 and input is currently coming from the keyboard (not in keyboard macro). | |
| 3276 */ | |
| 3277 ()) | |
| 3278 { | |
| 3279 REGISTER struct backtrace *btp; | |
| 3280 REGISTER Lisp_Object fun; | |
| 3281 | |
| 3282 if (!INTERACTIVE) | |
| 3283 return Qnil; | |
| 3284 | |
| 3285 /* Unless the object was compiled, skip the frame of interactive-p itself | |
| 3286 (if interpreted) or the frame of byte-code (if called from a compiled | |
| 3287 function). Note that *btp->function may be a symbol pointing at a | |
| 3288 compiled function. */ | |
| 3289 btp = backtrace_list; | |
| 3290 | |
| 3291 #if 0 /* FSFmacs */ | |
| 3292 | |
| 3293 /* #### FSFmacs does the following instead. I can't figure | |
| 3294 out which one is more correct. */ | |
| 3295 /* If this isn't a byte-compiled function, there may be a frame at | |
| 3296 the top for Finteractive_p itself. If so, skip it. */ | |
| 3297 fun = Findirect_function (*btp->function); | |
| 3298 if (SUBRP (fun) && XSUBR (fun) == &Sinteractive_p) | |
| 3299 btp = btp->next; | |
| 3300 | |
| 3301 /* If we're running an Emacs 18-style byte-compiled function, there | |
| 3302 may be a frame for Fbyte_code. Now, given the strictest | |
| 3303 definition, this function isn't really being called | |
| 3304 interactively, but because that's the way Emacs 18 always builds | |
| 3305 byte-compiled functions, we'll accept it for now. */ | |
| 3306 if (EQ (*btp->function, Qbyte_code)) | |
| 3307 btp = btp->next; | |
| 3308 | |
| 3309 /* 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
|
3310 looking at several frames for special operators. Skip past them. */ |
| 428 | 3311 while (btp && |
| 3312 btp->nargs == UNEVALLED) | |
| 3313 btp = btp->next; | |
| 3314 | |
| 3315 #else | |
| 3316 | |
| 3317 if (! (COMPILED_FUNCTIONP (Findirect_function (*btp->function)))) | |
| 3318 btp = btp->next; | |
| 3319 for (; | |
| 3320 btp && (btp->nargs == UNEVALLED | |
| 3321 || EQ (*btp->function, Qbyte_code)); | |
| 3322 btp = btp->next) | |
| 3323 {} | |
| 3324 /* btp now points at the frame of the innermost function | |
| 3325 that DOES eval its args. | |
| 3326 If it is a built-in function (such as load or eval-region) | |
| 3327 return nil. */ | |
| 3328 /* Beats me why this is necessary, but it is */ | |
| 3329 if (btp && EQ (*btp->function, Qcall_interactively)) | |
| 3330 return Qt; | |
| 3331 | |
| 3332 #endif | |
| 3333 | |
| 3334 fun = Findirect_function (*btp->function); | |
| 3335 if (SUBRP (fun)) | |
| 3336 return Qnil; | |
| 3337 /* btp points to the frame of a Lisp function that called interactive-p. | |
| 3338 Return t if that function was called interactively. */ | |
| 3339 if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively)) | |
| 3340 return Qt; | |
| 3341 return Qnil; | |
| 3342 } | |
| 3343 | |
| 3344 | |
| 3345 /************************************************************************/ | |
| 3346 /* Autoloading */ | |
| 3347 /************************************************************************/ | |
| 3348 | |
| 3349 DEFUN ("autoload", Fautoload, 2, 5, 0, /* | |
| 444 | 3350 Define FUNCTION to autoload from FILENAME. |
| 3351 FUNCTION is a symbol; FILENAME is a file name string to pass to `load'. | |
| 3352 The remaining optional arguments provide additional info about the | |
| 3353 real definition. | |
| 3354 DOCSTRING is documentation for FUNCTION. | |
| 3355 INTERACTIVE, if non-nil, says FUNCTION can be called interactively. | |
| 3356 TYPE indicates the type of the object: | |
| 428 | 3357 nil or omitted says FUNCTION is a function, |
| 3358 `keymap' says FUNCTION is really a keymap, and | |
| 3359 `macro' or t says FUNCTION is really a macro. | |
| 444 | 3360 If FUNCTION already has a non-void function definition that is not an |
| 3361 autoload object, this function does nothing and returns nil. | |
| 428 | 3362 */ |
| 444 | 3363 (function, filename, docstring, interactive, type)) |
| 428 | 3364 { |
| 3365 /* This function can GC */ | |
| 3366 CHECK_SYMBOL (function); | |
| 444 | 3367 CHECK_STRING (filename); |
| 428 | 3368 |
| 3369 /* If function is defined and not as an autoload, don't override */ | |
| 3370 { | |
| 3371 Lisp_Object f = XSYMBOL (function)->function; | |
| 3372 if (!UNBOUNDP (f) && !(CONSP (f) && EQ (XCAR (f), Qautoload))) | |
| 3373 return Qnil; | |
| 3374 } | |
| 3375 | |
| 3376 if (purify_flag) | |
| 3377 { | |
| 3378 /* Attempt to avoid consing identical (string=) pure strings. */ | |
| 444 | 3379 filename = Fsymbol_name (Fintern (filename, Qnil)); |
| 428 | 3380 } |
| 440 | 3381 |
| 444 | 3382 return Ffset (function, Fcons (Qautoload, list4 (filename, |
| 428 | 3383 docstring, |
| 3384 interactive, | |
| 3385 type))); | |
| 3386 } | |
| 3387 | |
| 3388 Lisp_Object | |
| 3389 un_autoload (Lisp_Object oldqueue) | |
| 3390 { | |
| 3391 /* This function can GC */ | |
| 3392 REGISTER Lisp_Object queue, first, second; | |
| 3393 | |
| 3394 /* Queue to unwind is current value of Vautoload_queue. | |
| 3395 oldqueue is the shadowed value to leave in Vautoload_queue. */ | |
| 3396 queue = Vautoload_queue; | |
| 3397 Vautoload_queue = oldqueue; | |
| 3398 while (CONSP (queue)) | |
| 3399 { | |
| 3400 first = XCAR (queue); | |
| 3401 second = Fcdr (first); | |
| 3402 first = Fcar (first); | |
| 3403 if (NILP (second)) | |
| 3404 Vfeatures = first; | |
| 3405 else | |
| 3406 Ffset (first, second); | |
| 3407 queue = Fcdr (queue); | |
| 3408 } | |
| 3409 return Qnil; | |
| 3410 } | |
| 3411 | |
| 970 | 3412 /* do_autoload GCPROs both arguments */ |
| 428 | 3413 void |
| 3414 do_autoload (Lisp_Object fundef, | |
| 3415 Lisp_Object funname) | |
| 3416 { | |
| 3417 /* This function can GC */ | |
| 3418 int speccount = specpdl_depth(); | |
| 3419 Lisp_Object fun = funname; | |
| 970 | 3420 struct gcpro gcpro1, gcpro2, gcpro3; |
| 428 | 3421 |
| 3422 CHECK_SYMBOL (funname); | |
| 970 | 3423 GCPRO3 (fundef, funname, fun); |
| 428 | 3424 |
| 3425 /* Value saved here is to be restored into Vautoload_queue */ | |
| 3426 record_unwind_protect (un_autoload, Vautoload_queue); | |
| 3427 Vautoload_queue = Qt; | |
| 3428 call4 (Qload, Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, Qnil); | |
| 3429 | |
| 3430 { | |
| 3431 Lisp_Object queue; | |
| 3432 | |
| 3433 /* Save the old autoloads, in case we ever do an unload. */ | |
| 3434 for (queue = Vautoload_queue; CONSP (queue); queue = XCDR (queue)) | |
| 3435 { | |
| 3436 Lisp_Object first = XCAR (queue); | |
| 3437 Lisp_Object second = Fcdr (first); | |
| 3438 | |
| 3439 first = Fcar (first); | |
| 3440 | |
| 3441 /* Note: This test is subtle. The cdr of an autoload-queue entry | |
| 3442 may be an atom if the autoload entry was generated by a defalias | |
| 3443 or fset. */ | |
| 3444 if (CONSP (second)) | |
| 3445 Fput (first, Qautoload, (XCDR (second))); | |
| 3446 } | |
| 3447 } | |
| 3448 | |
| 3449 /* Once loading finishes, don't undo it. */ | |
| 3450 Vautoload_queue = Qt; | |
| 771 | 3451 unbind_to (speccount); |
| 428 | 3452 |
| 3453 fun = indirect_function (fun, 0); | |
| 3454 | |
| 3455 #if 0 /* FSFmacs */ | |
| 3456 if (!NILP (Fequal (fun, fundef))) | |
| 3457 #else | |
| 3458 if (UNBOUNDP (fun) | |
| 3459 || (CONSP (fun) | |
| 3460 && EQ (XCAR (fun), Qautoload))) | |
| 3461 #endif | |
| 563 | 3462 invalid_state ("Autoloading failed to define function", funname); |
| 428 | 3463 UNGCPRO; |
| 3464 } | |
| 3465 | |
| 3466 | |
| 3467 /************************************************************************/ | |
| 3468 /* eval, funcall, apply */ | |
| 3469 /************************************************************************/ | |
| 3470 | |
| 814 | 3471 /* NOTE: If you are hearing the endless complaint that function calls in |
| 3472 elisp are extremely slow, it just isn't true any more! The stuff below | |
| 3473 -- in particular, the calling of subrs and compiled functions, the most | |
| 3474 common cases -- has been highly optimized. There isn't a whole lot left | |
| 3475 to do to squeeze more speed out except by switching to lexical | |
| 3476 variables, which would eliminate the specbind loop. (But the real gain | |
| 3477 from lexical variables would come from better optimization -- with | |
| 3478 dynamic binding, you have the constant problem that any function call | |
| 3479 that you haven't explicitly proven to be side-effect-free might | |
| 3480 potentially side effect your local variables, which makes optimization | |
| 3481 extremely difficult when there are function calls anywhere in a chunk of | |
| 3482 code to be optimized. Even worse, you don't know that *your* local | |
| 3483 variables aren't side-effecting an outer function's local variables, so | |
| 3484 it's impossible to optimize away almost *any* variable assignment.) */ | |
| 3485 | |
| 428 | 3486 static Lisp_Object funcall_lambda (Lisp_Object fun, |
| 442 | 3487 int nargs, Lisp_Object args[]); |
| 428 | 3488 static int in_warnings; |
| 3489 | |
| 3490 | |
| 814 | 3491 void handle_compiled_function_with_and_rest (Lisp_Compiled_Function *f, |
| 3492 int nargs, | |
| 3493 Lisp_Object args[]); | |
| 3494 | |
| 3495 /* The theory behind making this a separate function is to shrink | |
| 3496 funcall_compiled_function() so as to increase the likelihood of a cache | |
| 3497 hit in the L1 cache -- &rest processing is not going to be fast anyway. | |
| 3498 The idea is the same as with execute_rare_opcode() in bytecode.c. We | |
| 3499 make this non-static to ensure the compiler doesn't inline it. */ | |
| 3500 | |
| 3501 void | |
| 3502 handle_compiled_function_with_and_rest (Lisp_Compiled_Function *f, int nargs, | |
| 3503 Lisp_Object args[]) | |
| 3504 { | |
| 3505 REGISTER int i = 0; | |
| 3506 int max_non_rest_args = f->args_in_array - 1; | |
| 3507 int bindargs = min (nargs, max_non_rest_args); | |
| 3508 | |
| 3509 for (i = 0; i < bindargs; i++) | |
| 3092 | 3510 #ifdef NEW_GC |
| 3511 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3512 args[i]); | |
| 3513 #else /* not NEW_GC */ | |
| 814 | 3514 SPECBIND_FAST_UNSAFE (f->args[i], args[i]); |
| 3092 | 3515 #endif /* not NEW_GC */ |
| 814 | 3516 for (i = bindargs; i < max_non_rest_args; i++) |
| 3092 | 3517 #ifdef NEW_GC |
| 3518 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3519 Qnil); | |
| 3520 #else /* not NEW_GC */ | |
| 814 | 3521 SPECBIND_FAST_UNSAFE (f->args[i], Qnil); |
| 3092 | 3522 #endif /* not NEW_GC */ |
| 3523 #ifdef NEW_GC | |
| 3524 SPECBIND_FAST_UNSAFE | |
| 3525 (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[max_non_rest_args], | |
| 3526 nargs > max_non_rest_args ? | |
| 3527 Flist (nargs - max_non_rest_args, &args[max_non_rest_args]) : | |
| 3528 Qnil); | |
| 3529 #else /* not NEW_GC */ | |
| 814 | 3530 SPECBIND_FAST_UNSAFE |
| 3531 (f->args[max_non_rest_args], | |
| 3532 nargs > max_non_rest_args ? | |
| 3533 Flist (nargs - max_non_rest_args, &args[max_non_rest_args]) : | |
| 3534 Qnil); | |
| 3092 | 3535 #endif /* not NEW_GC */ |
| 814 | 3536 } |
| 3537 | |
| 3538 /* Apply compiled-function object FUN to the NARGS evaluated arguments | |
| 3539 in ARGS, and return the result of evaluation. */ | |
| 3540 inline static Lisp_Object | |
| 3541 funcall_compiled_function (Lisp_Object fun, int nargs, Lisp_Object args[]) | |
| 3542 { | |
| 3543 /* This function can GC */ | |
| 3544 int speccount = specpdl_depth(); | |
| 3545 REGISTER int i = 0; | |
| 3546 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun); | |
| 3547 | |
| 3548 if (!OPAQUEP (f->instructions)) | |
| 3549 /* Lazily munge the instructions into a more efficient form */ | |
| 3550 optimize_compiled_function (fun); | |
| 3551 | |
| 3552 /* optimize_compiled_function() guaranteed that f->specpdl_depth is | |
| 3553 the required space on the specbinding stack for binding the args | |
| 3554 and local variables of fun. So just reserve it once. */ | |
| 3555 SPECPDL_RESERVE (f->specpdl_depth); | |
| 3556 | |
| 3557 if (nargs == f->max_args) /* Optimize for the common case -- no unspecified | |
| 3558 optional arguments. */ | |
| 3559 { | |
| 3560 #if 1 | |
| 3561 for (i = 0; i < nargs; i++) | |
| 3092 | 3562 #ifdef NEW_GC |
| 3563 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3564 args[i]); | |
| 3565 #else /* not NEW_GC */ | |
| 814 | 3566 SPECBIND_FAST_UNSAFE (f->args[i], args[i]); |
| 3092 | 3567 #endif /* not NEW_GC */ |
| 814 | 3568 #else |
| 3569 /* Here's an alternate way to write the loop that tries to further | |
| 3570 optimize funcalls for functions with few arguments by partially | |
| 3571 unrolling the loop. It's not clear whether this is a win since it | |
| 3572 increases the size of the function and the possibility of L1 cache | |
| 3573 misses. (Microsoft VC++ 6 with /O2 /G5 generates 0x90 == 144 bytes | |
| 3574 per SPECBIND_FAST_UNSAFE().) Tests under VC++ 6, running the byte | |
| 3575 compiler repeatedly and looking at the total time, show very | |
| 3576 little difference between the simple loop above, the unrolled code | |
| 3577 below, and a "partly unrolled" solution with only cases 0-2 below | |
| 3578 instead of 0-4. Therefore, I'm keeping it at the simple loop | |
| 3579 because it's smaller. */ | |
| 3580 switch (nargs) | |
| 3581 { | |
| 3582 default: | |
| 3583 for (i = nargs - 1; i >= 4; i--) | |
| 3584 SPECBIND_FAST_UNSAFE (f->args[i], args[i]); | |
| 3585 case 4: SPECBIND_FAST_UNSAFE (f->args[3], args[3]); | |
| 3586 case 3: SPECBIND_FAST_UNSAFE (f->args[2], args[2]); | |
| 3587 case 2: SPECBIND_FAST_UNSAFE (f->args[1], args[1]); | |
| 3588 case 1: SPECBIND_FAST_UNSAFE (f->args[0], args[0]); | |
| 3589 case 0: break; | |
| 3590 } | |
| 3591 #endif | |
| 3592 } | |
| 3593 else if (nargs < f->min_args) | |
| 3594 goto wrong_number_of_arguments; | |
| 3595 else if (nargs < f->max_args) | |
| 3596 { | |
| 3597 for (i = 0; i < nargs; i++) | |
| 3092 | 3598 #ifdef NEW_GC |
| 3599 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3600 args[i]); | |
| 3601 #else /* not NEW_GC */ | |
| 814 | 3602 SPECBIND_FAST_UNSAFE (f->args[i], args[i]); |
| 3092 | 3603 #endif /* not NEW_GC */ |
| 814 | 3604 for (i = nargs; i < f->max_args; i++) |
| 3092 | 3605 #ifdef NEW_GC |
| 3606 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3607 Qnil); | |
| 3608 #else /* not NEW_GC */ | |
| 814 | 3609 SPECBIND_FAST_UNSAFE (f->args[i], Qnil); |
| 3092 | 3610 #endif /* not NEW_GC */ |
| 814 | 3611 } |
| 3612 else if (f->max_args == MANY) | |
| 3613 handle_compiled_function_with_and_rest (f, nargs, args); | |
| 3614 else | |
| 3615 { | |
| 3616 wrong_number_of_arguments: | |
| 3617 /* The actual printed compiled_function object is incomprehensible. | |
| 3618 Check the backtrace to see if we can get a more meaningful symbol. */ | |
| 3619 if (EQ (fun, indirect_function (*backtrace_list->function, 0))) | |
| 3620 fun = *backtrace_list->function; | |
| 3621 return Fsignal (Qwrong_number_of_arguments, | |
| 3622 list2 (fun, make_int (nargs))); | |
| 3623 } | |
| 3624 | |
| 3625 { | |
| 3626 Lisp_Object value = | |
| 3627 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
|
3628 #ifdef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4905
diff
changeset
|
3629 XOPAQUE_SIZE (f->instructions) / |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4905
diff
changeset
|
3630 sizeof (Opbyte), |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4905
diff
changeset
|
3631 #endif |
| 814 | 3632 f->stack_depth, |
| 3633 XVECTOR_DATA (f->constants)); | |
| 3634 | |
| 3635 /* The attempt to optimize this by only unbinding variables failed | |
| 3636 because using buffer-local variables as function parameters | |
| 3637 leads to specpdl_ptr->func != 0 */ | |
| 3638 /* UNBIND_TO_GCPRO_VARIABLES_ONLY (speccount, value); */ | |
| 3639 UNBIND_TO_GCPRO (speccount, value); | |
| 3640 return value; | |
| 3641 } | |
| 3642 } | |
| 3643 | |
| 428 | 3644 DEFUN ("eval", Feval, 1, 1, 0, /* |
| 3645 Evaluate FORM and return its value. | |
| 3646 */ | |
| 3647 (form)) | |
| 3648 { | |
| 3649 /* This function can GC */ | |
| 3650 Lisp_Object fun, val, original_fun, original_args; | |
| 3651 int nargs; | |
| 4162 | 3652 PROFILE_DECLARE(); |
| 428 | 3653 |
| 1318 | 3654 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS |
| 3655 check_proper_critical_section_lisp_protection (); | |
| 3656 #endif | |
| 3657 | |
| 3989 | 3658 if (!CONSP (form)) |
| 3659 { | |
| 3660 if (SYMBOLP (form)) | |
| 3661 { | |
| 3662 return Fsymbol_value (form); | |
| 3663 } | |
| 3664 | |
| 3665 return form; | |
| 3666 } | |
| 3667 | |
| 428 | 3668 /* I think this is a pretty safe place to call Lisp code, don't you? */ |
| 853 | 3669 while (!in_warnings && !NILP (Vpending_warnings) |
| 3670 /* well, perhaps not so safe after all! */ | |
| 3671 && !(inhibit_flags & INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY)) | |
| 428 | 3672 { |
| 3673 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; | |
| 1204 | 3674 Lisp_Object this_warning_cons, this_warning, class_, level, messij; |
| 853 | 3675 int speccount = internal_bind_int (&in_warnings, 1); |
| 3676 | |
| 428 | 3677 this_warning_cons = Vpending_warnings; |
| 3678 this_warning = XCAR (this_warning_cons); | |
| 3679 /* in case an error occurs in the warn function, at least | |
| 3680 it won't happen infinitely */ | |
| 3681 Vpending_warnings = XCDR (Vpending_warnings); | |
| 853 | 3682 free_cons (this_warning_cons); |
| 1204 | 3683 class_ = XCAR (this_warning); |
| 428 | 3684 level = XCAR (XCDR (this_warning)); |
| 3685 messij = XCAR (XCDR (XCDR (this_warning))); | |
| 3686 free_list (this_warning); | |
| 3687 | |
| 3688 if (NILP (Vpending_warnings)) | |
| 3689 Vpending_warnings_tail = Qnil; /* perhaps not strictly necessary, | |
| 3690 but safer */ | |
| 3691 | |
| 1204 | 3692 GCPRO4 (form, class_, level, messij); |
| 428 | 3693 if (!STRINGP (messij)) |
| 3694 messij = Fprin1_to_string (messij, Qnil); | |
| 1204 | 3695 call3 (Qdisplay_warning, class_, messij, level); |
| 428 | 3696 UNGCPRO; |
| 771 | 3697 unbind_to (speccount); |
| 428 | 3698 } |
| 3699 | |
| 3700 QUIT; | |
| 814 | 3701 if (need_to_garbage_collect) |
| 428 | 3702 { |
| 3703 struct gcpro gcpro1; | |
| 3704 GCPRO1 (form); | |
| 3092 | 3705 #ifdef NEW_GC |
| 3706 gc_incremental (); | |
| 3707 #else /* not NEW_GC */ | |
| 428 | 3708 garbage_collect_1 (); |
| 3092 | 3709 #endif /* not NEW_GC */ |
| 428 | 3710 UNGCPRO; |
| 3711 } | |
| 3712 | |
| 3713 if (++lisp_eval_depth > max_lisp_eval_depth) | |
| 3714 { | |
| 3715 if (max_lisp_eval_depth < 100) | |
| 3716 max_lisp_eval_depth = 100; | |
| 3717 if (lisp_eval_depth > max_lisp_eval_depth) | |
| 563 | 3718 stack_overflow ("Lisp nesting exceeds `max-lisp-eval-depth'", |
| 3719 Qunbound); | |
| 428 | 3720 } |
| 3721 | |
| 3722 /* We guaranteed CONSP (form) above */ | |
| 3723 original_fun = XCAR (form); | |
| 3724 original_args = XCDR (form); | |
| 3725 | |
| 3726 GET_EXTERNAL_LIST_LENGTH (original_args, nargs); | |
| 3727 | |
| 3728 backtrace.pdlcount = specpdl_depth(); | |
| 3729 backtrace.function = &original_fun; /* This also protects them from gc */ | |
| 3730 backtrace.args = &original_args; | |
| 3731 backtrace.nargs = UNEVALLED; | |
| 3732 backtrace.evalargs = 1; | |
| 3733 backtrace.debug_on_exit = 0; | |
| 1292 | 3734 backtrace.function_being_called = 0; |
| 428 | 3735 PUSH_BACKTRACE (backtrace); |
| 3736 | |
| 3737 if (debug_on_next_call) | |
| 3738 do_debug_on_call (Qt); | |
| 3739 | |
| 3740 /* At this point, only original_fun and original_args | |
| 3741 have values that will be used below. */ | |
| 3742 retry: | |
| 3989 | 3743 /* Optimise for no indirection. */ |
| 3744 fun = original_fun; | |
| 3745 if (SYMBOLP (fun) && !EQ (fun, Qunbound) | |
| 3746 && (fun = XSYMBOL (fun)->function, SYMBOLP (fun))) | |
| 3747 { | |
| 3748 fun = indirect_function(original_fun, 1); | |
| 3749 } | |
| 428 | 3750 |
| 3751 if (SUBRP (fun)) | |
| 3752 { | |
| 3753 Lisp_Subr *subr = XSUBR (fun); | |
| 3754 int max_args = subr->max_args; | |
| 3755 | |
| 3756 if (nargs < subr->min_args) | |
| 3757 goto wrong_number_of_arguments; | |
| 3758 | |
| 3759 if (max_args == UNEVALLED) /* Optimize for the common case */ | |
| 3760 { | |
| 3761 backtrace.evalargs = 0; | |
| 1292 | 3762 PROFILE_ENTER_FUNCTION (); |
| 428 | 3763 val = (((Lisp_Object (*) (Lisp_Object)) subr_function (subr)) |
| 3764 (original_args)); | |
| 1292 | 3765 PROFILE_EXIT_FUNCTION (); |
| 428 | 3766 } |
| 3767 else if (nargs <= max_args) | |
| 3768 { | |
| 3769 struct gcpro gcpro1; | |
| 3770 Lisp_Object args[SUBR_MAX_ARGS]; | |
| 3771 REGISTER Lisp_Object *p = args; | |
| 3772 | |
| 3773 GCPRO1 (args[0]); | |
| 3774 gcpro1.nvars = 0; | |
| 3775 | |
| 3776 { | |
| 3777 LIST_LOOP_2 (arg, original_args) | |
| 3778 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
3779 *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); |
| 428 | 3780 gcpro1.nvars++; |
| 3781 } | |
| 3782 } | |
| 3783 | |
| 3784 /* &optional args default to nil. */ | |
| 3785 while (p - args < max_args) | |
| 3786 *p++ = Qnil; | |
| 3787 | |
| 3788 backtrace.args = args; | |
| 3789 backtrace.nargs = nargs; | |
| 3790 | |
| 1292 | 3791 PROFILE_ENTER_FUNCTION (); |
| 428 | 3792 FUNCALL_SUBR (val, subr, args, max_args); |
| 1292 | 3793 PROFILE_EXIT_FUNCTION (); |
| 428 | 3794 |
| 3795 UNGCPRO; | |
| 3796 } | |
| 3797 else if (max_args == MANY) | |
| 3798 { | |
| 3799 /* Pass a vector of evaluated arguments */ | |
| 3800 struct gcpro gcpro1; | |
| 3801 Lisp_Object *args = alloca_array (Lisp_Object, nargs); | |
| 3802 REGISTER Lisp_Object *p = args; | |
| 3803 | |
| 3804 GCPRO1 (args[0]); | |
| 3805 gcpro1.nvars = 0; | |
| 3806 | |
| 3807 { | |
| 3808 LIST_LOOP_2 (arg, original_args) | |
| 3809 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
3810 *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); |
| 428 | 3811 gcpro1.nvars++; |
| 3812 } | |
| 3813 } | |
| 3814 | |
| 3815 backtrace.args = args; | |
| 3816 backtrace.nargs = nargs; | |
| 3817 | |
| 1292 | 3818 PROFILE_ENTER_FUNCTION (); |
| 428 | 3819 val = (((Lisp_Object (*) (int, Lisp_Object *)) subr_function (subr)) |
| 3820 (nargs, args)); | |
| 1292 | 3821 PROFILE_EXIT_FUNCTION (); |
| 428 | 3822 |
| 3823 UNGCPRO; | |
| 3824 } | |
| 3825 else | |
| 3826 { | |
| 3827 wrong_number_of_arguments: | |
| 440 | 3828 val = signal_wrong_number_of_arguments_error (original_fun, nargs); |
| 428 | 3829 } |
| 3830 } | |
| 3831 else if (COMPILED_FUNCTIONP (fun)) | |
| 3832 { | |
| 3833 struct gcpro gcpro1; | |
| 3834 Lisp_Object *args = alloca_array (Lisp_Object, nargs); | |
| 3835 REGISTER Lisp_Object *p = args; | |
| 3836 | |
| 3837 GCPRO1 (args[0]); | |
| 3838 gcpro1.nvars = 0; | |
| 3839 | |
| 3840 { | |
| 3841 LIST_LOOP_2 (arg, original_args) | |
| 3842 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
3843 *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); |
| 428 | 3844 gcpro1.nvars++; |
| 3845 } | |
| 3846 } | |
| 3847 | |
| 3848 backtrace.args = args; | |
| 3849 backtrace.nargs = nargs; | |
| 3850 backtrace.evalargs = 0; | |
| 3851 | |
| 1292 | 3852 PROFILE_ENTER_FUNCTION (); |
| 428 | 3853 val = funcall_compiled_function (fun, nargs, args); |
| 1292 | 3854 PROFILE_EXIT_FUNCTION (); |
| 428 | 3855 |
| 3856 /* Do the debug-on-exit now, while args is still GCPROed. */ | |
| 3857 if (backtrace.debug_on_exit) | |
| 3858 val = do_debug_on_exit (val); | |
| 3859 /* Don't do it again when we return to eval. */ | |
| 3860 backtrace.debug_on_exit = 0; | |
| 3861 | |
| 3862 UNGCPRO; | |
| 3863 } | |
| 3864 else if (CONSP (fun)) | |
| 3865 { | |
| 3866 Lisp_Object funcar = XCAR (fun); | |
| 3867 | |
| 3868 if (EQ (funcar, Qautoload)) | |
| 3869 { | |
| 970 | 3870 /* do_autoload GCPROs both arguments */ |
| 428 | 3871 do_autoload (fun, original_fun); |
| 3872 goto retry; | |
| 3873 } | |
| 3874 else if (EQ (funcar, Qmacro)) | |
| 3875 { | |
| 1292 | 3876 PROFILE_ENTER_FUNCTION (); |
| 428 | 3877 val = Feval (apply1 (XCDR (fun), original_args)); |
| 1292 | 3878 PROFILE_EXIT_FUNCTION (); |
| 428 | 3879 } |
| 3880 else if (EQ (funcar, Qlambda)) | |
| 3881 { | |
| 3882 struct gcpro gcpro1; | |
| 3883 Lisp_Object *args = alloca_array (Lisp_Object, nargs); | |
| 3884 REGISTER Lisp_Object *p = args; | |
| 3885 | |
| 3886 GCPRO1 (args[0]); | |
| 3887 gcpro1.nvars = 0; | |
| 3888 | |
| 3889 { | |
| 3890 LIST_LOOP_2 (arg, original_args) | |
| 3891 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
3892 *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); |
| 428 | 3893 gcpro1.nvars++; |
| 3894 } | |
| 3895 } | |
| 3896 | |
| 3897 UNGCPRO; | |
| 3898 | |
| 3899 backtrace.args = args; /* this also GCPROs `args' */ | |
| 3900 backtrace.nargs = nargs; | |
| 3901 backtrace.evalargs = 0; | |
| 3902 | |
| 1292 | 3903 PROFILE_ENTER_FUNCTION (); |
| 428 | 3904 val = funcall_lambda (fun, nargs, args); |
| 1292 | 3905 PROFILE_EXIT_FUNCTION (); |
| 428 | 3906 |
| 3907 /* Do the debug-on-exit now, while args is still GCPROed. */ | |
| 3908 if (backtrace.debug_on_exit) | |
| 3909 val = do_debug_on_exit (val); | |
| 3910 /* Don't do it again when we return to eval. */ | |
| 3911 backtrace.debug_on_exit = 0; | |
| 3912 } | |
| 3913 else | |
| 3914 { | |
| 3915 goto invalid_function; | |
| 3916 } | |
| 3917 } | |
| 4104 | 3918 else if (UNBOUNDP (fun)) |
| 3919 { | |
| 3920 val = signal_void_function_error (original_fun); | |
| 3921 } | |
| 3922 else /* ! (SUBRP (fun) || COMPILED_FUNCTIONP (fun) || CONSP (fun) | |
| 3923 UNBOUNDP (fun)) */ | |
| 428 | 3924 { |
| 3925 invalid_function: | |
| 436 | 3926 val = signal_invalid_function_error (fun); |
| 428 | 3927 } |
| 3928 | |
| 3929 lisp_eval_depth--; | |
| 3930 if (backtrace.debug_on_exit) | |
| 3931 val = do_debug_on_exit (val); | |
| 3932 POP_BACKTRACE (backtrace); | |
| 3933 return val; | |
| 3934 } | |
| 3935 | |
| 3936 | |
| 1111 | 3937 |
| 3938 static void | |
| 3939 run_post_gc_hook (void) | |
| 3940 { | |
| 3941 Lisp_Object args[2]; | |
| 3942 | |
| 3943 args[0] = Qpost_gc_hook; | |
| 3944 args[1] = Fcons (Fcons (Qfinalize_list, zap_finalize_list ()), Qnil); | |
| 3945 | |
| 3946 run_hook_with_args_trapping_problems | |
| 1333 | 3947 (Qgarbage_collecting, 2, args, RUN_HOOKS_TO_COMPLETION, |
| 1111 | 3948 INHIBIT_QUIT | NO_INHIBIT_ERRORS); |
| 3949 } | |
| 3950 | |
| 428 | 3951 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
|
3952 Call FUNCTION as a function, passing the remaining arguments to it. |
| 428 | 3953 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
|
3954 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
3955 arguments: (FUNCTION &rest ARGS) |
| 428 | 3956 */ |
| 3957 (int nargs, Lisp_Object *args)) | |
| 3958 { | |
| 3959 /* This function can GC */ | |
| 3960 Lisp_Object fun; | |
| 3961 Lisp_Object val; | |
| 4162 | 3962 PROFILE_DECLARE(); |
| 428 | 3963 int fun_nargs = nargs - 1; |
| 3964 Lisp_Object *fun_args = args + 1; | |
| 3965 | |
| 1318 | 3966 /* QUIT will check for proper redisplay wrapping */ |
| 3967 | |
| 428 | 3968 QUIT; |
| 851 | 3969 |
| 3970 if (funcall_allocation_flag) | |
| 3971 { | |
| 3972 if (need_to_garbage_collect) | |
| 3973 /* Callers should gcpro lexpr args */ | |
| 3092 | 3974 #ifdef NEW_GC |
| 3975 gc_incremental (); | |
| 3976 #else /* not NEW_GC */ | |
| 851 | 3977 garbage_collect_1 (); |
| 3092 | 3978 #endif /* not NEW_GC */ |
| 851 | 3979 if (need_to_check_c_alloca) |
| 3980 { | |
| 3981 if (++funcall_alloca_count >= MAX_FUNCALLS_BETWEEN_ALLOCA_CLEANUP) | |
| 3982 { | |
| 3983 xemacs_c_alloca (0); | |
| 3984 funcall_alloca_count = 0; | |
| 3985 } | |
| 3986 } | |
| 887 | 3987 if (need_to_signal_post_gc) |
| 3988 { | |
| 3989 need_to_signal_post_gc = 0; | |
| 1111 | 3990 recompute_funcall_allocation_flag (); |
| 3263 | 3991 #ifdef NEW_GC |
| 3992 run_finalizers (); | |
| 3993 #endif /* NEW_GC */ | |
| 1111 | 3994 run_post_gc_hook (); |
| 887 | 3995 } |
| 851 | 3996 } |
| 428 | 3997 |
| 3998 if (++lisp_eval_depth > max_lisp_eval_depth) | |
| 3999 { | |
| 4000 if (max_lisp_eval_depth < 100) | |
| 4001 max_lisp_eval_depth = 100; | |
| 4002 if (lisp_eval_depth > max_lisp_eval_depth) | |
| 563 | 4003 stack_overflow ("Lisp nesting exceeds `max-lisp-eval-depth'", |
| 4004 Qunbound); | |
| 428 | 4005 } |
| 4006 | |
| 1292 | 4007 backtrace.pdlcount = specpdl_depth (); |
| 428 | 4008 backtrace.function = &args[0]; |
| 4009 backtrace.args = fun_args; | |
| 4010 backtrace.nargs = fun_nargs; | |
| 4011 backtrace.evalargs = 0; | |
| 4012 backtrace.debug_on_exit = 0; | |
| 1292 | 4013 backtrace.function_being_called = 0; |
| 428 | 4014 PUSH_BACKTRACE (backtrace); |
| 4015 | |
| 4016 if (debug_on_next_call) | |
| 4017 do_debug_on_call (Qlambda); | |
| 4018 | |
| 4019 retry: | |
| 4020 | |
| 4021 fun = args[0]; | |
| 4022 | |
| 4023 /* We could call indirect_function directly, but profiling shows | |
| 4024 this is worth optimizing by partially unrolling the loop. */ | |
| 4025 if (SYMBOLP (fun)) | |
| 4026 { | |
| 4027 fun = XSYMBOL (fun)->function; | |
| 4028 if (SYMBOLP (fun)) | |
| 4029 { | |
| 4030 fun = XSYMBOL (fun)->function; | |
| 4031 if (SYMBOLP (fun)) | |
| 4032 fun = indirect_function (fun, 1); | |
| 4033 } | |
| 4034 } | |
| 4035 | |
| 4036 if (SUBRP (fun)) | |
| 4037 { | |
| 4038 Lisp_Subr *subr = XSUBR (fun); | |
| 4039 int max_args = subr->max_args; | |
| 4040 Lisp_Object spacious_args[SUBR_MAX_ARGS]; | |
| 4041 | |
| 4042 if (fun_nargs == max_args) /* Optimize for the common case */ | |
| 4043 { | |
| 4044 funcall_subr: | |
| 1292 | 4045 PROFILE_ENTER_FUNCTION (); |
| 428 | 4046 FUNCALL_SUBR (val, subr, fun_args, max_args); |
| 1292 | 4047 PROFILE_EXIT_FUNCTION (); |
| 428 | 4048 } |
| 436 | 4049 else if (fun_nargs < subr->min_args) |
| 4050 { | |
| 4051 goto wrong_number_of_arguments; | |
| 4052 } | |
| 428 | 4053 else if (fun_nargs < max_args) |
| 4054 { | |
| 4055 Lisp_Object *p = spacious_args; | |
| 4056 | |
| 4057 /* Default optionals to nil */ | |
| 4058 while (fun_nargs--) | |
| 4059 *p++ = *fun_args++; | |
| 4060 while (p - spacious_args < max_args) | |
| 4061 *p++ = Qnil; | |
| 4062 | |
| 4063 fun_args = spacious_args; | |
| 4064 goto funcall_subr; | |
| 4065 } | |
| 4066 else if (max_args == MANY) | |
| 4067 { | |
| 1292 | 4068 PROFILE_ENTER_FUNCTION (); |
| 436 | 4069 val = SUBR_FUNCTION (subr, MANY) (fun_nargs, fun_args); |
| 1292 | 4070 PROFILE_EXIT_FUNCTION (); |
| 428 | 4071 } |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
4072 else if (max_args == UNEVALLED) /* Can't funcall a special operator */ |
| 428 | 4073 { |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4074 /* Ugh, ugh, ugh. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4075 if (EQ (fun, XSYMBOL_FUNCTION (Qthrow))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4076 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4077 args[0] = Qobsolete_throw; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4078 goto retry; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4079 } |
| 428 | 4080 goto invalid_function; |
| 4081 } | |
| 4082 else | |
| 4083 { | |
| 4084 wrong_number_of_arguments: | |
| 436 | 4085 val = signal_wrong_number_of_arguments_error (fun, fun_nargs); |
| 428 | 4086 } |
| 4087 } | |
| 4088 else if (COMPILED_FUNCTIONP (fun)) | |
| 4089 { | |
| 1292 | 4090 PROFILE_ENTER_FUNCTION (); |
| 428 | 4091 val = funcall_compiled_function (fun, fun_nargs, fun_args); |
| 1292 | 4092 PROFILE_EXIT_FUNCTION (); |
| 428 | 4093 } |
| 4094 else if (CONSP (fun)) | |
| 4095 { | |
| 4096 Lisp_Object funcar = XCAR (fun); | |
| 4097 | |
| 4098 if (EQ (funcar, Qlambda)) | |
| 4099 { | |
| 1292 | 4100 PROFILE_ENTER_FUNCTION (); |
| 428 | 4101 val = funcall_lambda (fun, fun_nargs, fun_args); |
| 1292 | 4102 PROFILE_EXIT_FUNCTION (); |
| 428 | 4103 } |
| 4104 else if (EQ (funcar, Qautoload)) | |
| 4105 { | |
| 970 | 4106 /* do_autoload GCPROs both arguments */ |
| 428 | 4107 do_autoload (fun, args[0]); |
| 4108 goto retry; | |
| 4109 } | |
| 4110 else /* Can't funcall a macro */ | |
| 4111 { | |
| 4112 goto invalid_function; | |
| 4113 } | |
| 4114 } | |
| 4115 else if (UNBOUNDP (fun)) | |
| 4116 { | |
| 436 | 4117 val = signal_void_function_error (args[0]); |
| 428 | 4118 } |
| 4119 else | |
| 4120 { | |
| 4121 invalid_function: | |
| 436 | 4122 val = signal_invalid_function_error (fun); |
| 428 | 4123 } |
| 4124 | |
| 4125 lisp_eval_depth--; | |
| 4126 if (backtrace.debug_on_exit) | |
| 4127 val = do_debug_on_exit (val); | |
| 4128 POP_BACKTRACE (backtrace); | |
| 4129 return val; | |
| 4130 } | |
| 4131 | |
| 4132 DEFUN ("functionp", Ffunctionp, 1, 1, 0, /* | |
| 4133 Return t if OBJECT can be called as a function, else nil. | |
| 4134 A function is an object that can be applied to arguments, | |
| 4135 using for example `funcall' or `apply'. | |
| 4136 */ | |
| 4137 (object)) | |
| 4138 { | |
| 4139 if (SYMBOLP (object)) | |
| 4140 object = indirect_function (object, 0); | |
| 4141 | |
|
4795
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4744
diff
changeset
|
4142 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
|
4143 || (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
|
4144 && (XSUBR (object)->max_args != UNEVALLED))) |
| 919 | 4145 return Qt; |
| 4146 if (CONSP (object)) | |
| 4147 { | |
| 4148 Lisp_Object car = XCAR (object); | |
| 4149 if (EQ (car, Qlambda)) | |
| 4150 return Qt; | |
| 4151 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
|
4152 && 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
|
4153 (Fcdr_safe (XCDR (object))))))) |
| 919 | 4154 return Qt; |
| 4155 } | |
| 4156 return Qnil; | |
| 428 | 4157 } |
| 4158 | |
| 4159 static Lisp_Object | |
| 4160 function_argcount (Lisp_Object function, int function_min_args_p) | |
| 4161 { | |
| 4162 Lisp_Object orig_function = function; | |
| 4163 Lisp_Object arglist; | |
| 4164 | |
| 4165 retry: | |
| 4166 | |
| 4167 if (SYMBOLP (function)) | |
| 4168 function = indirect_function (function, 1); | |
| 4169 | |
| 4170 if (SUBRP (function)) | |
| 4171 { | |
| 442 | 4172 /* Using return with the ?: operator tickles a DEC CC compiler bug. */ |
| 4173 if (function_min_args_p) | |
| 4174 return Fsubr_min_args (function); | |
| 4175 else | |
| 4176 return Fsubr_max_args (function); | |
| 428 | 4177 } |
| 4178 else if (COMPILED_FUNCTIONP (function)) | |
| 4179 { | |
| 814 | 4180 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (function); |
| 4181 | |
| 1737 | 4182 if (!OPAQUEP (f->instructions)) |
| 4183 /* Lazily munge the instructions into a more efficient form */ | |
| 4184 /* Needed to set max_args */ | |
| 4185 optimize_compiled_function (function); | |
| 4186 | |
| 814 | 4187 if (function_min_args_p) |
| 4188 return make_int (f->min_args); | |
| 4189 else if (f->max_args == MANY) | |
| 4190 return Qnil; | |
| 4191 else | |
| 4192 return make_int (f->max_args); | |
| 428 | 4193 } |
| 4194 else if (CONSP (function)) | |
| 4195 { | |
| 4196 Lisp_Object funcar = XCAR (function); | |
| 4197 | |
| 4198 if (EQ (funcar, Qmacro)) | |
| 4199 { | |
| 4200 function = XCDR (function); | |
| 4201 goto retry; | |
| 4202 } | |
| 4203 else if (EQ (funcar, Qautoload)) | |
| 4204 { | |
| 970 | 4205 /* do_autoload GCPROs both arguments */ |
| 428 | 4206 do_autoload (function, orig_function); |
| 442 | 4207 function = orig_function; |
| 428 | 4208 goto retry; |
| 4209 } | |
| 4210 else if (EQ (funcar, Qlambda)) | |
| 4211 { | |
| 4212 arglist = Fcar (XCDR (function)); | |
| 4213 } | |
| 4214 else | |
| 4215 { | |
| 4216 goto invalid_function; | |
| 4217 } | |
| 4218 } | |
| 4219 else | |
| 4220 { | |
| 4221 invalid_function: | |
| 442 | 4222 return signal_invalid_function_error (orig_function); |
| 428 | 4223 } |
| 4224 | |
| 4225 { | |
| 4226 int argcount = 0; | |
| 4227 | |
| 4228 EXTERNAL_LIST_LOOP_2 (arg, arglist) | |
| 4229 { | |
| 4230 if (EQ (arg, Qand_optional)) | |
| 4231 { | |
| 4232 if (function_min_args_p) | |
| 4233 break; | |
| 4234 } | |
| 4235 else if (EQ (arg, Qand_rest)) | |
| 4236 { | |
| 4237 if (function_min_args_p) | |
| 4238 break; | |
| 4239 else | |
| 4240 return Qnil; | |
| 4241 } | |
| 4242 else | |
| 4243 { | |
| 4244 argcount++; | |
| 4245 } | |
| 4246 } | |
| 4247 | |
| 4248 return make_int (argcount); | |
| 4249 } | |
| 4250 } | |
| 4251 | |
| 4252 DEFUN ("function-min-args", Ffunction_min_args, 1, 1, 0, /* | |
| 617 | 4253 Return the minimum number of arguments a function may be called with. |
| 428 | 4254 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
|
4255 any special operator, or any macro. |
| 853 | 4256 |
| 4257 To check if a function can be called with a specified number of | |
| 4258 arguments, use `function-allows-args'. | |
| 428 | 4259 */ |
| 4260 (function)) | |
| 4261 { | |
| 4262 return function_argcount (function, 1); | |
| 4263 } | |
| 4264 | |
| 4265 DEFUN ("function-max-args", Ffunction_max_args, 1, 1, 0, /* | |
| 617 | 4266 Return the maximum number of arguments a function may be called with. |
| 428 | 4267 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
|
4268 any special operator, or any macro. |
| 428 | 4269 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
|
4270 a built-in special operator, nil is returned. |
| 853 | 4271 |
| 4272 To check if a function can be called with a specified number of | |
| 4273 arguments, use `function-allows-args'. | |
| 428 | 4274 */ |
| 4275 (function)) | |
| 4276 { | |
| 4277 return function_argcount (function, 0); | |
| 4278 } | |
| 4279 | |
| 4280 | |
| 4281 DEFUN ("apply", Fapply, 2, MANY, 0, /* | |
| 4282 Call FUNCTION with the remaining args, using the last arg as a list of args. | |
| 4283 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
|
4284 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
4285 arguments: (FUNCTION &rest ARGS) |
| 428 | 4286 */ |
| 4287 (int nargs, Lisp_Object *args)) | |
| 4288 { | |
| 4289 /* This function can GC */ | |
| 4290 Lisp_Object fun = args[0]; | |
| 4291 Lisp_Object spread_arg = args [nargs - 1]; | |
| 4292 int numargs; | |
| 4293 int funcall_nargs; | |
| 4294 | |
| 4295 GET_EXTERNAL_LIST_LENGTH (spread_arg, numargs); | |
| 4296 | |
| 4297 if (numargs == 0) | |
| 4298 /* (apply foo 0 1 '()) */ | |
| 4299 return Ffuncall (nargs - 1, args); | |
| 4300 else if (numargs == 1) | |
| 4301 { | |
| 4302 /* (apply foo 0 1 '(2)) */ | |
| 4303 args [nargs - 1] = XCAR (spread_arg); | |
| 4304 return Ffuncall (nargs, args); | |
| 4305 } | |
| 4306 | |
| 4307 /* -1 for function, -1 for spread arg */ | |
| 4308 numargs = nargs - 2 + numargs; | |
| 4309 /* +1 for function */ | |
| 4310 funcall_nargs = 1 + numargs; | |
| 4311 | |
| 4312 if (SYMBOLP (fun)) | |
| 4313 fun = indirect_function (fun, 0); | |
| 4314 | |
| 4315 if (SUBRP (fun)) | |
| 4316 { | |
| 4317 Lisp_Subr *subr = XSUBR (fun); | |
| 4318 int max_args = subr->max_args; | |
| 4319 | |
| 4320 if (numargs < subr->min_args | |
| 4321 || (max_args >= 0 && max_args < numargs)) | |
| 4322 { | |
| 4323 /* Let funcall get the error */ | |
| 4324 } | |
| 4325 else if (max_args > numargs) | |
| 4326 { | |
| 4327 /* Avoid having funcall cons up yet another new vector of arguments | |
| 4328 by explicitly supplying nil's for optional values */ | |
| 4329 funcall_nargs += (max_args - numargs); | |
| 4330 } | |
| 4331 } | |
| 4332 else if (UNBOUNDP (fun)) | |
| 4333 { | |
| 4334 /* Let funcall get the error */ | |
| 4335 fun = args[0]; | |
| 4336 } | |
| 4337 | |
| 4338 { | |
| 4339 REGISTER int i; | |
| 4340 Lisp_Object *funcall_args = alloca_array (Lisp_Object, funcall_nargs); | |
| 4341 struct gcpro gcpro1; | |
| 4342 | |
| 4343 GCPRO1 (*funcall_args); | |
| 4344 gcpro1.nvars = funcall_nargs; | |
| 4345 | |
| 4346 /* Copy in the unspread args */ | |
| 4347 memcpy (funcall_args, args, (nargs - 1) * sizeof (Lisp_Object)); | |
| 4348 /* Spread the last arg we got. Its first element goes in | |
| 4349 the slot that it used to occupy, hence this value of I. */ | |
| 4350 for (i = nargs - 1; | |
| 4351 !NILP (spread_arg); /* i < 1 + numargs */ | |
| 4352 i++, spread_arg = XCDR (spread_arg)) | |
| 4353 { | |
| 4354 funcall_args [i] = XCAR (spread_arg); | |
| 4355 } | |
| 4356 /* Supply nil for optional args (to subrs) */ | |
| 4357 for (; i < funcall_nargs; i++) | |
| 4358 funcall_args[i] = Qnil; | |
| 4359 | |
| 4360 | |
| 4361 RETURN_UNGCPRO (Ffuncall (funcall_nargs, funcall_args)); | |
| 4362 } | |
| 4363 } | |
| 4364 | |
| 4365 /* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and | |
| 4366 return the result of evaluation. */ | |
| 4367 | |
| 4368 static Lisp_Object | |
| 4369 funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object args[]) | |
| 4370 { | |
| 4371 /* This function can GC */ | |
| 442 | 4372 Lisp_Object arglist, body, tail; |
| 428 | 4373 int speccount = specpdl_depth(); |
| 4374 REGISTER int i = 0; | |
| 4375 | |
| 4376 tail = XCDR (fun); | |
| 4377 | |
| 4378 if (!CONSP (tail)) | |
| 4379 goto invalid_function; | |
| 4380 | |
| 4381 arglist = XCAR (tail); | |
| 4382 body = XCDR (tail); | |
| 4383 | |
| 4384 { | |
| 4385 int optional = 0, rest = 0; | |
| 4386 | |
| 442 | 4387 EXTERNAL_LIST_LOOP_2 (symbol, arglist) |
| 428 | 4388 { |
| 4389 if (!SYMBOLP (symbol)) | |
| 4390 goto invalid_function; | |
| 4391 if (EQ (symbol, Qand_rest)) | |
| 4392 rest = 1; | |
| 4393 else if (EQ (symbol, Qand_optional)) | |
| 4394 optional = 1; | |
| 4395 else if (rest) | |
| 4396 { | |
| 4397 specbind (symbol, Flist (nargs - i, &args[i])); | |
| 4398 i = nargs; | |
| 4399 } | |
| 4400 else if (i < nargs) | |
| 4401 specbind (symbol, args[i++]); | |
| 4402 else if (!optional) | |
| 4403 goto wrong_number_of_arguments; | |
| 4404 else | |
| 4405 specbind (symbol, Qnil); | |
| 4406 } | |
| 4407 } | |
| 4408 | |
| 4409 if (i < nargs) | |
| 4410 goto wrong_number_of_arguments; | |
| 4411 | |
| 771 | 4412 return unbind_to_1 (speccount, Fprogn (body)); |
| 428 | 4413 |
| 4414 wrong_number_of_arguments: | |
| 436 | 4415 return signal_wrong_number_of_arguments_error (fun, nargs); |
| 428 | 4416 |
| 4417 invalid_function: | |
| 436 | 4418 return signal_invalid_function_error (fun); |
| 428 | 4419 } |
| 4420 | |
| 4421 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4422 /* Multiple values. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4423 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4424 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
|
4425 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4426 -- 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
|
4427 -- 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
|
4428 one multiple value. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4429 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4430 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
|
4431 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4432 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
|
4433 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
|
4434 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
|
4435 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
|
4436 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
|
4437 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
|
4438 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
|
4439 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
|
4440 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4441 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
|
4442 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
|
4443 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
|
4444 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
|
4445 #'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
|
4446 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
|
4447 be saved and returned. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4448 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4449 (#'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
|
4450 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
|
4451 #'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
|
4452 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
|
4453 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
|
4454 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4455 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
|
4456 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
|
4457 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
|
4458 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
|
4459 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4460 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
|
4461 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
|
4462 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
|
4463 on being printed from within GDB. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4464 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4465 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
|
4466 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
|
4467 #'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
|
4468 #'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
|
4469 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
|
4470 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
|
4471 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
|
4472 *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
|
4473 not have this penalty. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4474 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4475 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
|
4476 admirable clarity by CLTL2: |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4477 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4478 "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
|
4479 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
|
4480 used." |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4481 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4482 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
|
4483 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
|
4484 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
|
4485 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
|
4486 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4487 static Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4488 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
|
4489 Elemcount first_desired, Elemcount upper_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4490 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4491 Bytecount sizem; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4492 struct multiple_value *mv; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4493 Elemcount i, allocated_count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4494 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4495 assert (count != 1); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4496 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4497 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
|
4498 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4499 /* 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
|
4500 working out allocated_count: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4501 first_desired = 1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4502 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4503 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4504 if (first_desired >= count) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4505 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4506 /* 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
|
4507 allocate for the first argument. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4508 allocated_count = 1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4509 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4510 else |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4511 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4512 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
|
4513 - first_desired); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4514 } |
|
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 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
|
4517 Lisp_Object, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4518 contents, allocated_count); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4519 mv = (multiple_value *) BASIC_ALLOC_LCRECORD (sizem, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4520 &lrecord_multiple_value); |
|
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 mv->count = count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4523 mv->first_desired = first_desired; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4524 mv->allocated_count = allocated_count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4525 mv->contents[0] = first_value; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4526 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4527 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
|
4528 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4529 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
|
4530 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4531 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4532 return wrap_multiple_value (mv); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4533 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4534 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4535 void |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4536 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
|
4537 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4538 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
|
4539 Elemcount first_desired = mv->first_desired; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4540 Elemcount allocated_count = mv->allocated_count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4541 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4542 if (index != 0 && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4543 (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
|
4544 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4545 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
|
4546 make_int (first_desired + allocated_count)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4547 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4548 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4549 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
|
4550 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4551 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4552 Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4553 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
|
4554 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4555 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
|
4556 Elemcount first_desired = mv->first_desired; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4557 Elemcount allocated_count = mv->allocated_count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4558 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4559 if (index != 0 && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4560 (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
|
4561 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4562 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
|
4563 make_int (first_desired + allocated_count)); |
|
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 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4566 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
|
4567 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4568 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4569 static void |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4570 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
|
4571 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4572 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
|
4573 Elemcount first_desired = mv->first_desired; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4574 Elemcount allocated_count = mv->allocated_count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4575 Elemcount count = mv->count, index; |
|
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 if (print_readably) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4578 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4579 printing_unreadable_object ("multiple values"); |
|
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 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4582 if (0 == count) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4583 { |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
4584 write_msg_string (printcharfun, "#<zero-length multiple value>"); |
|
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 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4587 for (index = 0; index < count;) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4588 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4589 if (index != 0 && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4590 (index < first_desired || |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4591 index >= (first_desired + (allocated_count - 1)))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4592 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4593 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
|
4594 index); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4595 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4596 else |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4597 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4598 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
|
4599 printcharfun, escapeflag); |
|
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 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4602 ++index; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4603 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4604 if (count > 1 && index < count) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4605 { |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
4606 write_ascstring (printcharfun, " ;\n"); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4607 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4608 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4609 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4610 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4611 static Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4612 mark_multiple_value (Lisp_Object obj) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4613 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4614 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
|
4615 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
|
4616 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4617 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
|
4618 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4619 mark_object (mv->contents[index]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4620 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4621 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4622 return Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4623 } |
|
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 static Bytecount |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4626 size_multiple_value (const void *lheader) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4627 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4628 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
|
4629 Lisp_Object, contents, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4630 ((struct multiple_value *) lheader)-> |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4631 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 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4634 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
|
4635 { 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
|
4636 { 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
|
4637 { 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
|
4638 { 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
|
4639 XD_INDIRECT (1, 0) }, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4640 { XD_END } |
|
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 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("multiple-value", multiple_value, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4644 1, /*dumpable-flag*/ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4645 mark_multiple_value, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4646 print_multiple_value, 0, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4647 0, /* No equal method. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4648 0, /* No hash method. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4649 multiple_value_description, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4650 size_multiple_value, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4651 struct multiple_value); |
|
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 /* 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
|
4654 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
|
4655 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
|
4656 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
|
4657 int |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4658 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
|
4659 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4660 int result = specpdl_depth(); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4661 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4662 if (!(upper > first)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4663 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4664 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
|
4665 " FIRST-DESIRED-MULTIPLE-VALUE", Qunbound); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4666 } |
|
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 (upper > Vmultiple_values_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4669 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4670 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
|
4671 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4672 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4673 /* 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
|
4674 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
|
4675 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
|
4676 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
|
4677 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4678 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
|
4679 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
|
4680 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4681 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
|
4682 if (0 == first) |
|
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 first = 1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4685 } |
|
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 if (0 == first_desired_multiple_value |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4688 || first < first_desired_multiple_value) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4689 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4690 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
|
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 if (upper > multiple_value_current_limit) |
|
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 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
|
4696 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4697 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4698 return result; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4699 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4700 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4701 Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4702 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
|
4703 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4704 /* The argument order here is horrible: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4705 int i, speccount = XINT (args[3]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4706 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
|
4707 struct gcpro gcpro1, gcpro2; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4708 Lisp_Object apply_args[2]; |
|
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 GCPRO2 (head, result); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4711 list_offset = head; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4712 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4713 assert (!(MULTIPLE_VALUEP (args[0]))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4714 CHECK_FUNCTION (args[0]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4715 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4716 /* 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
|
4717 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
|
4718 #'multiple-value-list-internal needs them): */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4719 for (i = 4; i < nargs; ++i) |
|
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 result = args[i]; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4722 if (MULTIPLE_VALUEP (result)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4723 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4724 Lisp_Object val; |
|
5016
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
4725 Elemcount j, count = XMULTIPLE_VALUE_COUNT (result); |
|
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
4726 |
|
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
4727 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
|
4728 { |
|
5016
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
4729 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
|
4730 assert (!UNBOUNDP (val)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4731 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4732 XSETCDR (list_offset, Fcons (val, Qnil)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4733 list_offset = XCDR (list_offset); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4734 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4735 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4736 else |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4737 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4738 XSETCDR (list_offset, Fcons (result, Qnil)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4739 list_offset = XCDR (list_offset); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4740 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4741 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4742 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4743 apply_args [0] = XCAR (head); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4744 apply_args [1] = XCDR (head); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4745 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4746 unbind_to (speccount); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4747 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4748 RETURN_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
|
4749 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4750 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4751 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
|
4752 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
|
4753 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4754 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
|
4755 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
|
4756 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
|
4757 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
|
4758 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4759 arguments: (FUNCTION &rest FORMS) |
|
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)) |
|
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 int listcount, i = 0, speccount; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4764 Lisp_Object *constructed_args; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4765 struct gcpro gcpro1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4766 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4767 GET_EXTERNAL_LIST_LENGTH (args, listcount); |
|
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 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
|
4770 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4771 /* 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
|
4772 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
|
4773 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4774 GCPRO1 (*constructed_args); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4775 gcpro1.nvars = ++i; |
|
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 /* The argument order is horrible here. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4778 constructed_args[i] = make_int (0); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4779 gcpro1.nvars = ++i; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4780 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
|
4781 gcpro1.nvars = ++i; |
|
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 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
|
4784 constructed_args[i] = make_int (speccount); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4785 gcpro1.nvars = ++i; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4786 |
|
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 LIST_LOOP_2 (elt, XCDR (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4789 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4790 constructed_args[i] = Feval (elt); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4791 gcpro1.nvars = ++i; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4792 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4793 } |
|
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 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
|
4796 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4797 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4798 Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4799 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
|
4800 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4801 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
|
4802 speccount = XINT(args[2]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4803 Lisp_Object result = Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4804 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4805 assert (nargs == 4); |
|
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 result = args[3]; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4808 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4809 unbind_to (speccount); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4810 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4811 if (MULTIPLE_VALUEP (result)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4812 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4813 Lisp_Object head = Fcons (Qnil, Qnil); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4814 Lisp_Object list_offset = head, val; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4815 Elemcount count = XMULTIPLE_VALUE_COUNT(result); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4816 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4817 for (; first < upper && first < count; ++first) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4818 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4819 val = multiple_value_aref (result, first); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4820 assert (!UNBOUNDP (val)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4821 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4822 XSETCDR (list_offset, Fcons (val, Qnil)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4823 list_offset = XCDR (list_offset); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4824 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4825 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4826 return XCDR (head); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4827 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4828 else |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4829 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4830 if (first == 0) |
|
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 return Fcons (result, Qnil); |
|
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 else |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4835 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4836 return Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4837 } |
|
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 } |
|
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 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
|
4842 UNEVALLED, 0, /* |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4843 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
|
4844 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4845 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
|
4846 Lisp, instead. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4847 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4848 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
|
4849 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
|
4850 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
|
4851 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
|
4852 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
|
4853 `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
|
4854 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4855 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
|
4856 */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4857 (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4858 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4859 Lisp_Object argv[4]; |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4860 int first, upper, nargs; |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4861 struct gcpro gcpro1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4862 |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4863 GET_LIST_LENGTH (args, nargs); |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4864 if (nargs != 3) |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4865 { |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4866 Fsignal (Qwrong_number_of_arguments, |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4867 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
|
4868 } |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4869 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4870 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
|
4871 CHECK_NATNUM (argv[0]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4872 first = XINT (argv[0]); |
|
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 GCPRO1 (argv[0]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4875 gcpro1.nvars = 1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4876 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4877 args = XCDR (args); |
|
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 argv[1] = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4880 CHECK_NATNUM (argv[1]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4881 upper = XINT (argv[1]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4882 gcpro1.nvars = 2; |
|
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 /* 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
|
4885 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
|
4886 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
|
4887 arguments. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4888 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
|
4889 gcpro1.nvars = 3; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4890 args = XCDR (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 /* 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
|
4893 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
|
4894 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
|
4895 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
|
4896 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
|
4897 it doesn't matter for performance. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4898 argv[3] = Feval (XCAR (args)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4899 gcpro1.nvars = 4; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4900 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4901 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
|
4902 } |
|
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 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
|
4905 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
|
4906 `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
|
4907 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4908 arguments: (FIRST &rest BODY) |
|
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 (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4911 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4912 /* This function can GC */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4913 Lisp_Object val; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4914 struct gcpro gcpro1; |
|
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 val = Feval (XCAR (args)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4917 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4918 GCPRO1 (val); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4919 |
|
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 LIST_LOOP_2 (form, XCDR (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4922 Feval (form); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4923 } |
|
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 RETURN_UNGCPRO (val); |
|
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 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4928 DEFUN ("values", Fvalues, 0, MANY, 0, /* |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4929 Return all ARGS as multiple values. |
|
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 arguments: (&rest ARGS) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4932 */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4933 (int nargs, Lisp_Object *args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4934 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4935 Lisp_Object result = Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4936 int counting = 1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4937 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4938 /* 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
|
4939 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
|
4940 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4941 return nargs ? args[0] : Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4942 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4943 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4944 /* 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
|
4945 #'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
|
4946 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
|
4947 transform them to nil. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4948 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
|
4949 first_desired_multiple_value, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4950 multiple_value_current_limit); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4951 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4952 for (; counting < nargs; ++counting) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4953 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4954 if (counting >= first_desired_multiple_value && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4955 counting < multiple_value_current_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4956 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4957 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
|
4958 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4959 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4960 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4961 return result; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4962 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4963 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4964 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
|
4965 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
|
4966 */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4967 (list)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4968 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4969 Lisp_Object result = Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4970 int counting = 1, listcount; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4971 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4972 GET_EXTERNAL_LIST_LENGTH (list, listcount); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4973 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4974 /* 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
|
4975 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
|
4976 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4977 return Fcar_safe (list); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4978 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4979 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4980 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
|
4981 first_desired_multiple_value, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4982 multiple_value_current_limit); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4983 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4984 list = Fcdr_safe (list); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4985 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4986 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4987 EXTERNAL_LIST_LOOP_2 (elt, list) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4988 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4989 if (counting >= first_desired_multiple_value && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4990 counting < multiple_value_current_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4991 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4992 multiple_value_aset (result, counting, elt); |
|
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 ++counting; |
|
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 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4998 return result; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4999 } |
|
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 Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5002 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
|
5003 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5004 Lisp_Object argv[2]; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5005 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5006 argv[0] = first; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5007 argv[1] = second; |
|
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 return Fvalues (countof (argv), argv); |
|
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 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5012 |
| 428 | 5013 /************************************************************************/ |
| 5014 /* Run hook variables in various ways. */ | |
| 5015 /************************************************************************/ | |
| 5016 | |
| 5017 DEFUN ("run-hooks", Frun_hooks, 1, MANY, 0, /* | |
| 5018 Run each hook in HOOKS. Major mode functions use this. | |
| 5019 Each argument should be a symbol, a hook variable. | |
| 5020 These symbols are processed in the order specified. | |
| 5021 If a hook symbol has a non-nil value, that value may be a function | |
| 5022 or a list of functions to be called to run the hook. | |
| 5023 If the value is a function, it is called with no arguments. | |
| 5024 If it is a list, the elements are called, in order, with no arguments. | |
| 5025 | |
| 5026 To make a hook variable buffer-local, use `make-local-hook', | |
| 5027 not `make-local-variable'. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5028 |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
5029 arguments: (FIRST &rest REST) |
| 428 | 5030 */ |
| 5031 (int nargs, Lisp_Object *args)) | |
| 5032 { | |
| 5033 REGISTER int i; | |
| 5034 | |
| 5035 for (i = 0; i < nargs; i++) | |
| 5036 run_hook_with_args (1, args + i, RUN_HOOKS_TO_COMPLETION); | |
| 5037 | |
| 5038 return Qnil; | |
| 5039 } | |
| 5040 | |
| 5041 DEFUN ("run-hook-with-args", Frun_hook_with_args, 1, MANY, 0, /* | |
| 5042 Run HOOK with the specified arguments ARGS. | |
| 5043 HOOK should be a symbol, a hook variable. If HOOK has a non-nil | |
| 5044 value, that value may be a function or a list of functions to be | |
| 5045 called to run the hook. If the value is a function, it is called with | |
| 5046 the given arguments and its return value is returned. If it is a list | |
| 5047 of functions, those functions are called, in order, | |
| 5048 with the given arguments ARGS. | |
| 444 | 5049 It is best not to depend on the value returned by `run-hook-with-args', |
| 428 | 5050 as that may change. |
| 5051 | |
| 5052 To make a hook variable buffer-local, use `make-local-hook', | |
| 5053 not `make-local-variable'. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5054 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5055 arguments: (HOOK &rest ARGS) |
| 428 | 5056 */ |
| 5057 (int nargs, Lisp_Object *args)) | |
| 5058 { | |
| 5059 return run_hook_with_args (nargs, args, RUN_HOOKS_TO_COMPLETION); | |
| 5060 } | |
| 5061 | |
| 5062 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success, 1, MANY, 0, /* | |
| 5063 Run HOOK with the specified arguments ARGS. | |
| 5064 HOOK should be a symbol, a hook variable. Its value should | |
| 5065 be a list of functions. We call those functions, one by one, | |
| 5066 passing arguments ARGS to each of them, until one of them | |
| 5067 returns a non-nil value. Then we return that value. | |
| 5068 If all the functions return nil, we return nil. | |
| 5069 | |
| 5070 To make a hook variable buffer-local, use `make-local-hook', | |
| 5071 not `make-local-variable'. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5072 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5073 arguments: (HOOK &rest ARGS) |
| 428 | 5074 */ |
| 5075 (int nargs, Lisp_Object *args)) | |
| 5076 { | |
| 5077 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_SUCCESS); | |
| 5078 } | |
| 5079 | |
| 5080 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure, 1, MANY, 0, /* | |
| 5081 Run HOOK with the specified arguments ARGS. | |
| 5082 HOOK should be a symbol, a hook variable. Its value should | |
| 5083 be a list of functions. We call those functions, one by one, | |
| 5084 passing arguments ARGS to each of them, until one of them | |
| 5085 returns nil. Then we return nil. | |
| 5086 If all the functions return non-nil, we return non-nil. | |
| 5087 | |
| 5088 To make a hook variable buffer-local, use `make-local-hook', | |
| 5089 not `make-local-variable'. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5090 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5091 arguments: (HOOK &rest ARGS) |
| 428 | 5092 */ |
| 5093 (int nargs, Lisp_Object *args)) | |
| 5094 { | |
| 5095 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_FAILURE); | |
| 5096 } | |
| 5097 | |
| 5098 /* ARGS[0] should be a hook symbol. | |
| 5099 Call each of the functions in the hook value, passing each of them | |
| 5100 as arguments all the rest of ARGS (all NARGS - 1 elements). | |
| 5101 COND specifies a condition to test after each call | |
| 5102 to decide whether to stop. | |
| 5103 The caller (or its caller, etc) must gcpro all of ARGS, | |
| 5104 except that it isn't necessary to gcpro ARGS[0]. */ | |
| 5105 | |
| 5106 Lisp_Object | |
| 5107 run_hook_with_args_in_buffer (struct buffer *buf, int nargs, Lisp_Object *args, | |
| 5108 enum run_hooks_condition cond) | |
| 5109 { | |
| 5110 Lisp_Object sym, val, ret; | |
| 5111 | |
| 5112 if (!initialized || preparing_for_armageddon) | |
| 5113 /* We need to bail out of here pronto. */ | |
| 5114 return Qnil; | |
| 5115 | |
| 3092 | 5116 #ifndef NEW_GC |
| 428 | 5117 /* Whenever gc_in_progress is true, preparing_for_armageddon |
| 5118 will also be true unless something is really hosed. */ | |
| 5119 assert (!gc_in_progress); | |
| 3092 | 5120 #endif /* not NEW_GC */ |
| 428 | 5121 |
| 5122 sym = args[0]; | |
| 771 | 5123 val = symbol_value_in_buffer (sym, wrap_buffer (buf)); |
| 428 | 5124 ret = (cond == RUN_HOOKS_UNTIL_FAILURE ? Qt : Qnil); |
| 5125 | |
| 5126 if (UNBOUNDP (val) || NILP (val)) | |
| 5127 return ret; | |
| 5128 else if (!CONSP (val) || EQ (XCAR (val), Qlambda)) | |
| 5129 { | |
| 5130 args[0] = val; | |
| 5131 return Ffuncall (nargs, args); | |
| 5132 } | |
| 5133 else | |
| 5134 { | |
| 5135 struct gcpro gcpro1, gcpro2, gcpro3; | |
| 5136 Lisp_Object globals = Qnil; | |
| 5137 GCPRO3 (sym, val, globals); | |
| 5138 | |
| 5139 for (; | |
| 5140 CONSP (val) && ((cond == RUN_HOOKS_TO_COMPLETION) | |
| 5141 || (cond == RUN_HOOKS_UNTIL_SUCCESS ? NILP (ret) | |
| 5142 : !NILP (ret))); | |
| 5143 val = XCDR (val)) | |
| 5144 { | |
| 5145 if (EQ (XCAR (val), Qt)) | |
| 5146 { | |
| 5147 /* t indicates this hook has a local binding; | |
| 5148 it means to run the global binding too. */ | |
| 5149 globals = Fdefault_value (sym); | |
| 5150 | |
| 5151 if ((! CONSP (globals) || EQ (XCAR (globals), Qlambda)) && | |
| 5152 ! NILP (globals)) | |
| 5153 { | |
| 5154 args[0] = globals; | |
| 5155 ret = Ffuncall (nargs, args); | |
| 5156 } | |
| 5157 else | |
| 5158 { | |
| 5159 for (; | |
| 5160 CONSP (globals) && ((cond == RUN_HOOKS_TO_COMPLETION) | |
| 5161 || (cond == RUN_HOOKS_UNTIL_SUCCESS | |
| 5162 ? NILP (ret) | |
| 5163 : !NILP (ret))); | |
| 5164 globals = XCDR (globals)) | |
| 5165 { | |
| 5166 args[0] = XCAR (globals); | |
| 5167 /* In a global value, t should not occur. If it does, we | |
| 5168 must ignore it to avoid an endless loop. */ | |
| 5169 if (!EQ (args[0], Qt)) | |
| 5170 ret = Ffuncall (nargs, args); | |
| 5171 } | |
| 5172 } | |
| 5173 } | |
| 5174 else | |
| 5175 { | |
| 5176 args[0] = XCAR (val); | |
| 5177 ret = Ffuncall (nargs, args); | |
| 5178 } | |
| 5179 } | |
| 5180 | |
| 5181 UNGCPRO; | |
| 5182 return ret; | |
| 5183 } | |
| 5184 } | |
| 5185 | |
| 5186 Lisp_Object | |
| 5187 run_hook_with_args (int nargs, Lisp_Object *args, | |
| 5188 enum run_hooks_condition cond) | |
| 5189 { | |
| 5190 return run_hook_with_args_in_buffer (current_buffer, nargs, args, cond); | |
| 5191 } | |
| 5192 | |
| 5193 #if 0 | |
| 5194 | |
| 853 | 5195 /* From FSF 19.30, not currently used; seems like a big kludge. */ |
| 428 | 5196 |
| 5197 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual | |
| 5198 present value of that symbol. | |
| 5199 Call each element of FUNLIST, | |
| 5200 passing each of them the rest of ARGS. | |
| 5201 The caller (or its caller, etc) must gcpro all of ARGS, | |
| 5202 except that it isn't necessary to gcpro ARGS[0]. */ | |
| 5203 | |
| 5204 Lisp_Object | |
| 5205 run_hook_list_with_args (Lisp_Object funlist, int nargs, Lisp_Object *args) | |
| 5206 { | |
| 853 | 5207 omitted; |
| 428 | 5208 } |
| 5209 | |
| 5210 #endif /* 0 */ | |
| 5211 | |
| 5212 void | |
| 5213 va_run_hook_with_args (Lisp_Object hook_var, int nargs, ...) | |
| 5214 { | |
| 5215 /* This function can GC */ | |
| 5216 struct gcpro gcpro1; | |
| 5217 int i; | |
| 5218 va_list vargs; | |
| 5219 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs); | |
| 5220 | |
| 5221 va_start (vargs, nargs); | |
| 5222 funcall_args[0] = hook_var; | |
| 5223 for (i = 0; i < nargs; i++) | |
| 5224 funcall_args[i + 1] = va_arg (vargs, Lisp_Object); | |
| 5225 va_end (vargs); | |
| 5226 | |
| 5227 GCPRO1 (*funcall_args); | |
| 5228 gcpro1.nvars = nargs + 1; | |
| 5229 run_hook_with_args (nargs + 1, funcall_args, RUN_HOOKS_TO_COMPLETION); | |
| 5230 UNGCPRO; | |
| 5231 } | |
| 5232 | |
| 5233 void | |
| 5234 va_run_hook_with_args_in_buffer (struct buffer *buf, Lisp_Object hook_var, | |
| 5235 int nargs, ...) | |
| 5236 { | |
| 5237 /* This function can GC */ | |
| 5238 struct gcpro gcpro1; | |
| 5239 int i; | |
| 5240 va_list vargs; | |
| 5241 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs); | |
| 5242 | |
| 5243 va_start (vargs, nargs); | |
| 5244 funcall_args[0] = hook_var; | |
| 5245 for (i = 0; i < nargs; i++) | |
| 5246 funcall_args[i + 1] = va_arg (vargs, Lisp_Object); | |
| 5247 va_end (vargs); | |
| 5248 | |
| 5249 GCPRO1 (*funcall_args); | |
| 5250 gcpro1.nvars = nargs + 1; | |
| 5251 run_hook_with_args_in_buffer (buf, nargs + 1, funcall_args, | |
| 5252 RUN_HOOKS_TO_COMPLETION); | |
| 5253 UNGCPRO; | |
| 5254 } | |
| 5255 | |
| 5256 Lisp_Object | |
| 5257 run_hook (Lisp_Object hook) | |
| 5258 { | |
| 853 | 5259 return run_hook_with_args (1, &hook, RUN_HOOKS_TO_COMPLETION); |
| 428 | 5260 } |
| 5261 | |
| 5262 | |
| 5263 /************************************************************************/ | |
| 5264 /* Front-ends to eval, funcall, apply */ | |
| 5265 /************************************************************************/ | |
| 5266 | |
| 5267 /* Apply fn to arg */ | |
| 5268 Lisp_Object | |
| 5269 apply1 (Lisp_Object fn, Lisp_Object arg) | |
| 5270 { | |
| 5271 /* This function can GC */ | |
| 5272 struct gcpro gcpro1; | |
| 5273 Lisp_Object args[2]; | |
| 5274 | |
| 5275 if (NILP (arg)) | |
| 5276 return Ffuncall (1, &fn); | |
| 5277 GCPRO1 (args[0]); | |
| 5278 gcpro1.nvars = 2; | |
| 5279 args[0] = fn; | |
| 5280 args[1] = arg; | |
| 5281 RETURN_UNGCPRO (Fapply (2, args)); | |
| 5282 } | |
| 5283 | |
| 5284 /* Call function fn on no arguments */ | |
| 5285 Lisp_Object | |
| 5286 call0 (Lisp_Object fn) | |
| 5287 { | |
| 5288 /* This function can GC */ | |
| 5289 struct gcpro gcpro1; | |
| 5290 | |
| 5291 GCPRO1 (fn); | |
| 5292 RETURN_UNGCPRO (Ffuncall (1, &fn)); | |
| 5293 } | |
| 5294 | |
| 5295 /* Call function fn with argument arg0 */ | |
| 5296 Lisp_Object | |
| 5297 call1 (Lisp_Object fn, | |
| 5298 Lisp_Object arg0) | |
| 5299 { | |
| 5300 /* This function can GC */ | |
| 5301 struct gcpro gcpro1; | |
| 5302 Lisp_Object args[2]; | |
| 5303 args[0] = fn; | |
| 5304 args[1] = arg0; | |
| 5305 GCPRO1 (args[0]); | |
| 5306 gcpro1.nvars = 2; | |
| 5307 RETURN_UNGCPRO (Ffuncall (2, args)); | |
| 5308 } | |
| 5309 | |
| 5310 /* Call function fn with arguments arg0, arg1 */ | |
| 5311 Lisp_Object | |
| 5312 call2 (Lisp_Object fn, | |
| 5313 Lisp_Object arg0, Lisp_Object arg1) | |
| 5314 { | |
| 5315 /* This function can GC */ | |
| 5316 struct gcpro gcpro1; | |
| 5317 Lisp_Object args[3]; | |
| 5318 args[0] = fn; | |
| 5319 args[1] = arg0; | |
| 5320 args[2] = arg1; | |
| 5321 GCPRO1 (args[0]); | |
| 5322 gcpro1.nvars = 3; | |
| 5323 RETURN_UNGCPRO (Ffuncall (3, args)); | |
| 5324 } | |
| 5325 | |
| 5326 /* Call function fn with arguments arg0, arg1, arg2 */ | |
| 5327 Lisp_Object | |
| 5328 call3 (Lisp_Object fn, | |
| 5329 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2) | |
| 5330 { | |
| 5331 /* This function can GC */ | |
| 5332 struct gcpro gcpro1; | |
| 5333 Lisp_Object args[4]; | |
| 5334 args[0] = fn; | |
| 5335 args[1] = arg0; | |
| 5336 args[2] = arg1; | |
| 5337 args[3] = arg2; | |
| 5338 GCPRO1 (args[0]); | |
| 5339 gcpro1.nvars = 4; | |
| 5340 RETURN_UNGCPRO (Ffuncall (4, args)); | |
| 5341 } | |
| 5342 | |
| 5343 /* Call function fn with arguments arg0, arg1, arg2, arg3 */ | |
| 5344 Lisp_Object | |
| 5345 call4 (Lisp_Object fn, | |
| 5346 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5347 Lisp_Object arg3) | |
| 5348 { | |
| 5349 /* This function can GC */ | |
| 5350 struct gcpro gcpro1; | |
| 5351 Lisp_Object args[5]; | |
| 5352 args[0] = fn; | |
| 5353 args[1] = arg0; | |
| 5354 args[2] = arg1; | |
| 5355 args[3] = arg2; | |
| 5356 args[4] = arg3; | |
| 5357 GCPRO1 (args[0]); | |
| 5358 gcpro1.nvars = 5; | |
| 5359 RETURN_UNGCPRO (Ffuncall (5, args)); | |
| 5360 } | |
| 5361 | |
| 5362 /* Call function fn with arguments arg0, arg1, arg2, arg3, arg4 */ | |
| 5363 Lisp_Object | |
| 5364 call5 (Lisp_Object fn, | |
| 5365 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5366 Lisp_Object arg3, Lisp_Object arg4) | |
| 5367 { | |
| 5368 /* This function can GC */ | |
| 5369 struct gcpro gcpro1; | |
| 5370 Lisp_Object args[6]; | |
| 5371 args[0] = fn; | |
| 5372 args[1] = arg0; | |
| 5373 args[2] = arg1; | |
| 5374 args[3] = arg2; | |
| 5375 args[4] = arg3; | |
| 5376 args[5] = arg4; | |
| 5377 GCPRO1 (args[0]); | |
| 5378 gcpro1.nvars = 6; | |
| 5379 RETURN_UNGCPRO (Ffuncall (6, args)); | |
| 5380 } | |
| 5381 | |
| 5382 Lisp_Object | |
| 5383 call6 (Lisp_Object fn, | |
| 5384 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5385 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5) | |
| 5386 { | |
| 5387 /* This function can GC */ | |
| 5388 struct gcpro gcpro1; | |
| 5389 Lisp_Object args[7]; | |
| 5390 args[0] = fn; | |
| 5391 args[1] = arg0; | |
| 5392 args[2] = arg1; | |
| 5393 args[3] = arg2; | |
| 5394 args[4] = arg3; | |
| 5395 args[5] = arg4; | |
| 5396 args[6] = arg5; | |
| 5397 GCPRO1 (args[0]); | |
| 5398 gcpro1.nvars = 7; | |
| 5399 RETURN_UNGCPRO (Ffuncall (7, args)); | |
| 5400 } | |
| 5401 | |
| 5402 Lisp_Object | |
| 5403 call7 (Lisp_Object fn, | |
| 5404 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5405 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5, | |
| 5406 Lisp_Object arg6) | |
| 5407 { | |
| 5408 /* This function can GC */ | |
| 5409 struct gcpro gcpro1; | |
| 5410 Lisp_Object args[8]; | |
| 5411 args[0] = fn; | |
| 5412 args[1] = arg0; | |
| 5413 args[2] = arg1; | |
| 5414 args[3] = arg2; | |
| 5415 args[4] = arg3; | |
| 5416 args[5] = arg4; | |
| 5417 args[6] = arg5; | |
| 5418 args[7] = arg6; | |
| 5419 GCPRO1 (args[0]); | |
| 5420 gcpro1.nvars = 8; | |
| 5421 RETURN_UNGCPRO (Ffuncall (8, args)); | |
| 5422 } | |
| 5423 | |
| 5424 Lisp_Object | |
| 5425 call8 (Lisp_Object fn, | |
| 5426 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5427 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5, | |
| 5428 Lisp_Object arg6, Lisp_Object arg7) | |
| 5429 { | |
| 5430 /* This function can GC */ | |
| 5431 struct gcpro gcpro1; | |
| 5432 Lisp_Object args[9]; | |
| 5433 args[0] = fn; | |
| 5434 args[1] = arg0; | |
| 5435 args[2] = arg1; | |
| 5436 args[3] = arg2; | |
| 5437 args[4] = arg3; | |
| 5438 args[5] = arg4; | |
| 5439 args[6] = arg5; | |
| 5440 args[7] = arg6; | |
| 5441 args[8] = arg7; | |
| 5442 GCPRO1 (args[0]); | |
| 5443 gcpro1.nvars = 9; | |
| 5444 RETURN_UNGCPRO (Ffuncall (9, args)); | |
| 5445 } | |
| 5446 | |
| 5447 Lisp_Object | |
| 5448 call0_in_buffer (struct buffer *buf, Lisp_Object fn) | |
| 5449 { | |
| 5450 if (current_buffer == buf) | |
| 5451 return call0 (fn); | |
| 5452 else | |
| 5453 { | |
| 5454 Lisp_Object val; | |
| 5455 int speccount = specpdl_depth(); | |
| 5456 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5457 set_buffer_internal (buf); | |
| 5458 val = call0 (fn); | |
| 771 | 5459 unbind_to (speccount); |
| 428 | 5460 return val; |
| 5461 } | |
| 5462 } | |
| 5463 | |
| 5464 Lisp_Object | |
| 5465 call1_in_buffer (struct buffer *buf, Lisp_Object fn, | |
| 5466 Lisp_Object arg0) | |
| 5467 { | |
| 5468 if (current_buffer == buf) | |
| 5469 return call1 (fn, arg0); | |
| 5470 else | |
| 5471 { | |
| 5472 Lisp_Object val; | |
| 5473 int speccount = specpdl_depth(); | |
| 5474 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5475 set_buffer_internal (buf); | |
| 5476 val = call1 (fn, arg0); | |
| 771 | 5477 unbind_to (speccount); |
| 428 | 5478 return val; |
| 5479 } | |
| 5480 } | |
| 5481 | |
| 5482 Lisp_Object | |
| 5483 call2_in_buffer (struct buffer *buf, Lisp_Object fn, | |
| 5484 Lisp_Object arg0, Lisp_Object arg1) | |
| 5485 { | |
| 5486 if (current_buffer == buf) | |
| 5487 return call2 (fn, arg0, arg1); | |
| 5488 else | |
| 5489 { | |
| 5490 Lisp_Object val; | |
| 5491 int speccount = specpdl_depth(); | |
| 5492 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5493 set_buffer_internal (buf); | |
| 5494 val = call2 (fn, arg0, arg1); | |
| 771 | 5495 unbind_to (speccount); |
| 428 | 5496 return val; |
| 5497 } | |
| 5498 } | |
| 5499 | |
| 5500 Lisp_Object | |
| 5501 call3_in_buffer (struct buffer *buf, Lisp_Object fn, | |
| 5502 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2) | |
| 5503 { | |
| 5504 if (current_buffer == buf) | |
| 5505 return call3 (fn, arg0, arg1, arg2); | |
| 5506 else | |
| 5507 { | |
| 5508 Lisp_Object val; | |
| 5509 int speccount = specpdl_depth(); | |
| 5510 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5511 set_buffer_internal (buf); | |
| 5512 val = call3 (fn, arg0, arg1, arg2); | |
| 771 | 5513 unbind_to (speccount); |
| 428 | 5514 return val; |
| 5515 } | |
| 5516 } | |
| 5517 | |
| 5518 Lisp_Object | |
| 5519 call4_in_buffer (struct buffer *buf, Lisp_Object fn, | |
| 5520 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5521 Lisp_Object arg3) | |
| 5522 { | |
| 5523 if (current_buffer == buf) | |
| 5524 return call4 (fn, arg0, arg1, arg2, arg3); | |
| 5525 else | |
| 5526 { | |
| 5527 Lisp_Object val; | |
| 5528 int speccount = specpdl_depth(); | |
| 5529 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5530 set_buffer_internal (buf); | |
| 5531 val = call4 (fn, arg0, arg1, arg2, arg3); | |
| 771 | 5532 unbind_to (speccount); |
| 428 | 5533 return val; |
| 5534 } | |
| 5535 } | |
| 5536 | |
| 5537 Lisp_Object | |
| 5538 eval_in_buffer (struct buffer *buf, Lisp_Object form) | |
| 5539 { | |
| 5540 if (current_buffer == buf) | |
| 5541 return Feval (form); | |
| 5542 else | |
| 5543 { | |
| 5544 Lisp_Object val; | |
| 5545 int speccount = specpdl_depth(); | |
| 5546 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5547 set_buffer_internal (buf); | |
| 5548 val = Feval (form); | |
| 771 | 5549 unbind_to (speccount); |
| 428 | 5550 return val; |
| 5551 } | |
| 5552 } | |
| 5553 | |
| 5554 | |
| 5555 /************************************************************************/ | |
| 5556 /* Error-catching front-ends to eval, funcall, apply */ | |
| 5557 /************************************************************************/ | |
| 5558 | |
| 853 | 5559 int |
| 5560 get_inhibit_flags (void) | |
| 5561 { | |
| 5562 return inhibit_flags; | |
| 5563 } | |
| 5564 | |
| 5565 void | |
| 2286 | 5566 check_allowed_operation (int what, Lisp_Object obj, Lisp_Object UNUSED (prop)) |
| 853 | 5567 { |
| 5568 if (inhibit_flags & INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION) | |
| 5569 { | |
| 5570 if (what == OPERATION_MODIFY_BUFFER_TEXT && BUFFERP (obj) | |
| 5571 && NILP (memq_no_quit (obj, Vmodifiable_buffers))) | |
| 5572 invalid_change | |
| 5573 ("Modification of this buffer not currently permitted", obj); | |
| 5574 } | |
| 5575 if (inhibit_flags & INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION) | |
| 5576 { | |
| 5577 if (what == OPERATION_DELETE_OBJECT | |
| 5578 && (BUFFERP (obj) || WINDOWP (obj) || FRAMEP (obj) || DEVICEP (obj) | |
| 5579 || CONSOLEP (obj)) | |
| 5580 && NILP (memq_no_quit (obj, Vdeletable_permanent_display_objects))) | |
| 5581 invalid_change | |
| 5582 ("Deletion of this object not currently permitted", obj); | |
| 5583 } | |
| 5584 } | |
| 5585 | |
| 5586 void | |
| 5587 note_object_created (Lisp_Object obj) | |
| 5588 { | |
| 5589 if (inhibit_flags & INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION) | |
| 5590 { | |
| 5591 if (BUFFERP (obj)) | |
| 5592 Vmodifiable_buffers = Fcons (obj, Vmodifiable_buffers); | |
| 5593 } | |
| 5594 if (inhibit_flags & INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION) | |
| 5595 { | |
| 5596 if (BUFFERP (obj) || WINDOWP (obj) || FRAMEP (obj) || DEVICEP (obj) | |
| 5597 || CONSOLEP (obj)) | |
| 5598 Vdeletable_permanent_display_objects = | |
| 5599 Fcons (obj, Vdeletable_permanent_display_objects); | |
| 5600 } | |
| 5601 } | |
| 5602 | |
| 5603 void | |
| 5604 note_object_deleted (Lisp_Object obj) | |
| 5605 { | |
| 5606 if (inhibit_flags & INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION) | |
| 5607 { | |
| 5608 if (BUFFERP (obj)) | |
| 5609 Vmodifiable_buffers = delq_no_quit (obj, Vmodifiable_buffers); | |
| 5610 } | |
| 5611 if (inhibit_flags & INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION) | |
| 5612 { | |
| 5613 if (BUFFERP (obj) || WINDOWP (obj) || FRAMEP (obj) || DEVICEP (obj) | |
| 5614 || CONSOLEP (obj)) | |
| 5615 Vdeletable_permanent_display_objects = | |
| 5616 delq_no_quit (obj, Vdeletable_permanent_display_objects); | |
| 5617 } | |
| 5618 } | |
| 5619 | |
| 5620 struct call_trapping_problems | |
| 5621 { | |
| 5622 Lisp_Object catchtag; | |
| 5623 Lisp_Object error_conditions; | |
| 5624 Lisp_Object data; | |
| 5625 Lisp_Object backtrace; | |
| 5626 Lisp_Object warning_class; | |
| 5627 | |
| 867 | 5628 const CIbyte *warning_string; |
| 853 | 5629 Lisp_Object (*fun) (void *); |
| 5630 void *arg; | |
| 5631 }; | |
| 428 | 5632 |
| 2532 | 5633 static Lisp_Object |
| 5634 maybe_get_trapping_problems_backtrace (void) | |
| 5635 { | |
| 5636 Lisp_Object backtrace; | |
| 853 | 5637 |
| 1123 | 5638 if (!(inhibit_flags & INHIBIT_WARNING_ISSUE) |
| 2532 | 5639 && !warning_will_be_discarded (current_warning_level ())) |
| 428 | 5640 { |
| 1333 | 5641 struct gcpro gcpro1; |
| 5642 Lisp_Object lstream = Qnil; | |
| 5643 int speccount = specpdl_depth (); | |
| 5644 | |
| 853 | 5645 /* We're no longer protected against errors or quit here, so at |
| 5646 least let's temporarily inhibit quit. We definitely do not | |
| 5647 want to inhibit quit during the calling of the function | |
| 5648 itself!!!!!!!!!!! */ | |
| 5649 | |
| 5650 specbind (Qinhibit_quit, Qt); | |
| 5651 | |
| 5652 GCPRO1 (lstream); | |
| 5653 lstream = make_resizing_buffer_output_stream (); | |
| 5654 Fbacktrace (lstream, Qt); | |
| 5655 Lstream_flush (XLSTREAM (lstream)); | |
| 2532 | 5656 backtrace = resizing_buffer_to_lisp_string (XLSTREAM (lstream)); |
| 853 | 5657 Lstream_delete (XLSTREAM (lstream)); |
| 5658 UNGCPRO; | |
| 5659 | |
| 5660 unbind_to (speccount); | |
| 428 | 5661 } |
| 853 | 5662 else |
| 2532 | 5663 backtrace = Qnil; |
| 5664 | |
| 5665 return backtrace; | |
| 5666 } | |
| 5667 | |
| 5668 static DECLARE_DOESNT_RETURN_TYPE | |
| 5669 (Lisp_Object, flagged_a_squirmer (Lisp_Object, Lisp_Object, Lisp_Object)); | |
| 5670 | |
| 5671 static DOESNT_RETURN_TYPE (Lisp_Object) | |
| 5672 flagged_a_squirmer (Lisp_Object error_conditions, Lisp_Object data, | |
| 5673 Lisp_Object opaque) | |
| 5674 { | |
| 5675 struct call_trapping_problems *p = | |
| 5676 (struct call_trapping_problems *) get_opaque_ptr (opaque); | |
| 5677 | |
| 5678 if (!EQ (error_conditions, Qquit)) | |
| 5679 p->backtrace = maybe_get_trapping_problems_backtrace (); | |
| 5680 else | |
| 853 | 5681 p->backtrace = Qnil; |
| 5682 p->error_conditions = error_conditions; | |
| 5683 p->data = data; | |
| 5684 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5685 throw_or_bomb_out (p->catchtag, Qnil, 0, Qnil, Qnil); |
| 2268 | 5686 RETURN_NOT_REACHED (Qnil); |
| 853 | 5687 } |
| 5688 | |
| 5689 static Lisp_Object | |
| 5690 call_trapping_problems_2 (Lisp_Object opaque) | |
| 5691 { | |
| 5692 struct call_trapping_problems *p = | |
| 5693 (struct call_trapping_problems *) get_opaque_ptr (opaque); | |
| 5694 | |
| 5695 return (p->fun) (p->arg); | |
| 428 | 5696 } |
| 5697 | |
| 5698 static Lisp_Object | |
| 853 | 5699 call_trapping_problems_1 (Lisp_Object opaque) |
| 5700 { | |
| 5701 return call_with_condition_handler (flagged_a_squirmer, opaque, | |
| 5702 call_trapping_problems_2, opaque); | |
| 5703 } | |
| 5704 | |
| 1333 | 5705 static void |
| 5706 issue_call_trapping_problems_warning (Lisp_Object warning_class, | |
| 5707 const CIbyte *warning_string, | |
| 5708 struct call_trapping_problems_result *p) | |
| 5709 { | |
| 5710 if (!warning_will_be_discarded (current_warning_level ())) | |
| 5711 { | |
| 5712 int depth = specpdl_depth (); | |
| 5713 | |
| 5714 /* We're no longer protected against errors or quit here, so at | |
| 5715 least let's temporarily inhibit quit. */ | |
| 5716 specbind (Qinhibit_quit, Qt); | |
| 5717 | |
| 5718 if (p->caught_throw) | |
| 5719 { | |
| 5720 Lisp_Object errstr = | |
| 5721 emacs_sprintf_string_lisp | |
| 2532 | 5722 ("%s: Attempt to throw outside of function:" |
| 5723 "To catch `%s' with value `%s'\n\nBacktrace follows:\n\n%s", | |
| 2725 | 5724 Qnil, 4, |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
5725 build_msg_cistring (warning_string ? warning_string : "error"), |
| 2532 | 5726 p->thrown_tag, p->thrown_value, p->backtrace); |
| 1333 | 5727 warn_when_safe_lispobj (Qerror, current_warning_level (), errstr); |
| 5728 } | |
| 2421 | 5729 else if (p->caught_error && !EQ (p->error_conditions, Qquit)) |
| 1333 | 5730 { |
| 5731 Lisp_Object errstr; | |
| 5732 /* #### This should call | |
| 5733 (with-output-to-string (display-error (cons error_conditions | |
| 5734 data)) | |
| 5735 but that stuff is all in Lisp currently. */ | |
| 5736 errstr = | |
| 5737 emacs_sprintf_string_lisp | |
| 5738 ("%s: (%s %s)\n\nBacktrace follows:\n\n%s", | |
| 5739 Qnil, 4, | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
5740 build_msg_cistring (warning_string ? warning_string : "error"), |
| 1333 | 5741 p->error_conditions, p->data, p->backtrace); |
| 5742 | |
| 5743 warn_when_safe_lispobj (warning_class, current_warning_level (), | |
| 5744 errstr); | |
| 5745 } | |
| 5746 | |
| 5747 unbind_to (depth); | |
| 5748 } | |
| 5749 } | |
| 5750 | |
| 1318 | 5751 /* Turn on the trapping flags in FLAGS -- see call_trapping_problems(). |
| 5752 This cannot handle INTERNAL_INHIBIT_THROWS() or INTERNAL_INHIBIT_ERRORS | |
| 5753 (because they ultimately boil down to a setjmp()!) -- you must directly | |
| 5754 use call_trapping_problems() for that. Turn the flags off with | |
| 5755 unbind_to(). Returns the "canonicalized" flags (particularly in the | |
| 5756 case of INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY, which is shorthand for | |
| 5757 various other flags). */ | |
| 5758 | |
| 5759 int | |
| 5760 set_trapping_problems_flags (int flags) | |
| 5761 { | |
| 5762 int new_inhibit_flags; | |
| 5763 | |
| 5764 if (flags & INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY) | |
| 5765 flags |= INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION | |
| 5766 | INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION | |
| 5767 | INHIBIT_ENTERING_DEBUGGER | |
| 5768 | INHIBIT_WARNING_ISSUE | |
| 5769 | INHIBIT_GC; | |
| 5770 | |
| 5771 new_inhibit_flags = inhibit_flags | flags; | |
| 5772 if (new_inhibit_flags != inhibit_flags) | |
| 5773 internal_bind_int (&inhibit_flags, new_inhibit_flags); | |
| 5774 | |
| 5775 if (flags & INHIBIT_QUIT) | |
| 5776 specbind (Qinhibit_quit, Qt); | |
| 5777 | |
| 5778 if (flags & UNINHIBIT_QUIT) | |
| 5779 begin_do_check_for_quit (); | |
| 5780 | |
| 5781 if (flags & INHIBIT_GC) | |
| 5782 begin_gc_forbidden (); | |
| 5783 | |
| 5784 /* #### If we have nested calls to call_trapping_problems(), and the | |
| 5785 inner one creates some buffers/etc., should the outer one be able | |
| 5786 to delete them? I think so, but it means we need to combine rather | |
| 5787 than just reset the value. */ | |
| 5788 if (flags & INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION) | |
| 5789 internal_bind_lisp_object (&Vdeletable_permanent_display_objects, Qnil); | |
| 5790 | |
| 5791 if (flags & INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION) | |
| 5792 internal_bind_lisp_object (&Vmodifiable_buffers, Qnil); | |
| 5793 | |
| 5794 return flags; | |
| 5795 } | |
| 5796 | |
| 853 | 5797 /* This is equivalent to (*fun) (arg), except that various conditions |
| 5798 can be trapped or inhibited, according to FLAGS. | |
| 5799 | |
| 5800 If FLAGS does not contain NO_INHIBIT_ERRORS, when an error occurs, | |
| 5801 the error is caught and a warning is issued, specifying the | |
| 5802 specific error that occurred and a backtrace. In that case, | |
| 5803 WARNING_STRING should be given, and will be printed at the | |
| 5804 beginning of the error to indicate where the error occurred. | |
| 5805 | |
| 5806 If FLAGS does not contain NO_INHIBIT_THROWS, all attempts to | |
| 5807 `throw' out of the function being called are trapped, and a warning | |
| 5808 issued. (Again, WARNING_STRING should be given.) | |
| 5809 | |
| 2367 | 5810 If FLAGS contains INHIBIT_WARNING_ISSUE, no warnings are issued; |
| 853 | 5811 this applies to recursive invocations of call_trapping_problems, too. |
| 5812 | |
| 1333 | 5813 If FLAGS contains POSTPONE_WARNING_ISSUE, no warnings are issued; |
| 5814 but values useful for generating a warning are still computed (in | |
| 5815 particular, the backtrace), so that the calling function can issue | |
| 5816 a warning. | |
| 5817 | |
| 853 | 5818 If FLAGS contains ISSUE_WARNINGS_AT_DEBUG_LEVEL, warnings will be |
| 5819 issued, but at level `debug', which normally is below the minimum | |
| 5820 specified by `log-warning-minimum-level', meaning such warnings will | |
| 5821 be ignored entirely. The user can change this variable, however, | |
| 5822 to see the warnings.) | |
| 5823 | |
| 5824 Note: If neither of NO_INHIBIT_THROWS or NO_INHIBIT_ERRORS is | |
| 5825 given, you are *guaranteed* that there will be no non-local exits | |
| 5826 out of this function. | |
| 5827 | |
| 5828 If FLAGS contains INHIBIT_QUIT, QUIT using C-g is inhibited. (This | |
| 5829 is *rarely* a good idea. Unless you use NO_INHIBIT_ERRORS, QUIT is | |
| 5830 automatically caught as well, and treated as an error; you can | |
| 5831 check for this using EQ (problems->error_conditions, Qquit). | |
| 5832 | |
| 5833 If FLAGS contains UNINHIBIT_QUIT, QUIT checking will be explicitly | |
| 5834 turned on. (It will abort the code being called, but will still be | |
| 5835 trapped and reported as an error, unless NO_INHIBIT_ERRORS is | |
| 5836 given.) This is useful when QUIT checking has been turned off by a | |
| 5837 higher-level caller. | |
| 5838 | |
| 5839 If FLAGS contains INHIBIT_GC, garbage collection is inhibited. | |
| 1123 | 5840 This is useful for Lisp called within redisplay, for example. |
| 853 | 5841 |
| 5842 If FLAGS contains INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION, | |
| 5843 Lisp code is not allowed to delete any window, buffers, frames, devices, | |
| 5844 or consoles that were already in existence at the time this function | |
| 5845 was called. (However, it's perfectly legal for code to create a new | |
| 5846 buffer and then delete it.) | |
| 5847 | |
| 5848 #### It might be useful to have a flag that inhibits deletion of a | |
| 5849 specific permanent display object and everything it's attached to | |
| 5850 (e.g. a window, and the buffer, frame, device, and console it's | |
| 5851 attached to. | |
| 5852 | |
| 5853 If FLAGS contains INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION, Lisp | |
| 5854 code is not allowed to modify the text of any buffers that were | |
| 5855 already in existence at the time this function was called. | |
| 5856 (However, it's perfectly legal for code to create a new buffer and | |
| 5857 then modify its text.) | |
| 5858 | |
| 5859 [These last two flags are implemented using global variables | |
| 5860 Vdeletable_permanent_display_objects and Vmodifiable_buffers, | |
| 5861 which keep track of a list of all buffers or permanent display | |
| 5862 objects created since the last time one of these flags was set. | |
| 5863 The code that deletes buffers, etc. and modifies buffers checks | |
| 5864 | |
| 5865 (1) if the corresponding flag is set (through the global variable | |
| 5866 inhibit_flags or its accessor function get_inhibit_flags()), and | |
| 5867 | |
| 5868 (2) if the object to be modified or deleted is not in the | |
| 5869 appropriate list. | |
| 5870 | |
| 5871 If so, it signals an error. | |
| 5872 | |
| 5873 Recursive calls to call_trapping_problems() are allowed. In | |
| 5874 the case of the two flags mentioned above, the current values | |
| 5875 of the global variables are stored in an unwind-protect, and | |
| 5876 they're reset to nil.] | |
| 5877 | |
| 5878 If FLAGS contains INHIBIT_ENTERING_DEBUGGER, the debugger will not | |
| 5879 be entered if an error occurs inside the Lisp code being called, | |
| 5880 even when the user has requested an error. In such case, a warning | |
| 5881 is issued stating that access to the debugger is denied, unless | |
| 5882 INHIBIT_WARNING_ISSUE has also been supplied. This is useful when | |
| 5883 calling Lisp code inside redisplay, in menu callbacks, etc. because | |
| 5884 in such cases either the display is in an inconsistent state or | |
| 5885 doing window operations is explicitly forbidden by the OS, and the | |
| 5886 debugger would causes visual changes on the screen and might create | |
| 5887 another frame. | |
| 5888 | |
| 5889 If FLAGS contains INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY, no | |
| 5890 changes of any sort to extents, faces, glyphs, buffer text, | |
| 5891 specifiers relating to display, other variables relating to | |
| 5892 display, splitting, deleting, or resizing windows or frames, | |
| 5893 deleting buffers, windows, frames, devices, or consoles, etc. is | |
| 5894 allowed. This is for things called absolutely in the middle of | |
| 5895 redisplay, which expects things to be *exactly* the same after the | |
| 5896 call as before. This isn't completely implemented and needs to be | |
| 5897 thought out some more to determine exactly what its semantics are. | |
| 5898 For the moment, turning on this flag also turns on | |
| 5899 | |
| 5900 INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION | |
| 5901 INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION | |
| 5902 INHIBIT_ENTERING_DEBUGGER | |
| 5903 INHIBIT_WARNING_ISSUE | |
| 5904 INHIBIT_GC | |
| 5905 | |
| 5906 #### The following five flags are defined, but unimplemented: | |
| 5907 | |
| 5908 #define INHIBIT_EXISTING_CODING_SYSTEM_DELETION (1<<6) | |
| 5909 #define INHIBIT_EXISTING_CHARSET_DELETION (1<<7) | |
| 5910 #define INHIBIT_PERMANENT_DISPLAY_OBJECT_CREATION (1<<8) | |
| 5911 #define INHIBIT_CODING_SYSTEM_CREATION (1<<9) | |
| 5912 #define INHIBIT_CHARSET_CREATION (1<<10) | |
| 5913 | |
| 5914 FLAGS containing CALL_WITH_SUSPENDED_ERRORS is a sign that | |
| 5915 call_with_suspended_errors() was invoked. This exists only for | |
| 5916 debugging purposes -- often we want to break when a signal happens, | |
| 5917 but ignore signals from call_with_suspended_errors(), because they | |
| 5918 occur often and for legitimate reasons. | |
| 5919 | |
| 5920 If PROBLEM is non-zero, it should be a pointer to a structure into | |
| 5921 which exact information about any occurring problems (either an | |
| 5922 error or an attempted throw past this boundary). | |
| 5923 | |
| 5924 If a problem occurred and aborted operation (error, quit, or | |
| 5925 invalid throw), Qunbound is returned. Otherwise the return value | |
| 5926 from the call to (*fun) (arg) is returned. */ | |
| 5927 | |
| 5928 Lisp_Object | |
| 5929 call_trapping_problems (Lisp_Object warning_class, | |
| 867 | 5930 const CIbyte *warning_string, |
| 853 | 5931 int flags, |
| 5932 struct call_trapping_problems_result *problem, | |
| 5933 Lisp_Object (*fun) (void *), | |
| 5934 void *arg) | |
| 5935 { | |
| 1318 | 5936 int speccount = specpdl_depth (); |
| 853 | 5937 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; |
| 5938 struct call_trapping_problems package; | |
| 1333 | 5939 struct call_trapping_problems_result real_problem; |
| 2532 | 5940 Lisp_Object opaque, thrown_tag, tem, thrown_backtrace; |
| 853 | 5941 int thrown = 0; |
| 5942 | |
| 5943 assert (SYMBOLP (warning_class)); /* sanity-check */ | |
| 5944 assert (!NILP (warning_class)); | |
| 5945 | |
| 5946 flags ^= INTERNAL_INHIBIT_ERRORS | INTERNAL_INHIBIT_THROWS; | |
| 5947 | |
| 5948 package.warning_class = warning_class; | |
| 5949 package.warning_string = warning_string; | |
| 5950 package.fun = fun; | |
| 5951 package.arg = arg; | |
| 5952 package.catchtag = | |
| 5953 flags & INTERNAL_INHIBIT_THROWS ? Vcatch_everything_tag : | |
| 5954 flags & INTERNAL_INHIBIT_ERRORS ? make_opaque_ptr (0) : | |
| 5955 Qnil; | |
| 5956 package.error_conditions = Qnil; | |
| 5957 package.data = Qnil; | |
| 5958 package.backtrace = Qnil; | |
| 5959 | |
| 1318 | 5960 flags = set_trapping_problems_flags (flags); |
| 853 | 5961 |
| 5962 if (flags & (INTERNAL_INHIBIT_THROWS | INTERNAL_INHIBIT_ERRORS)) | |
| 5963 opaque = make_opaque_ptr (&package); | |
| 5964 else | |
| 5965 opaque = Qnil; | |
| 5966 | |
| 5967 GCPRO5 (package.catchtag, package.error_conditions, package.data, | |
| 5968 package.backtrace, opaque); | |
| 5969 | |
| 5970 if (flags & INTERNAL_INHIBIT_ERRORS) | |
| 5971 /* We need a catch so that our condition-handler can throw back here | |
| 5972 after printing the warning. (We print the warning in the stack | |
| 5973 context of the error, so we can get a backtrace.) */ | |
| 5974 tem = internal_catch (package.catchtag, call_trapping_problems_1, opaque, | |
| 2532 | 5975 &thrown, &thrown_tag, &thrown_backtrace); |
| 853 | 5976 else if (flags & INTERNAL_INHIBIT_THROWS) |
| 5977 /* We skip over the first wrapper, which traps errors. */ | |
| 5978 tem = internal_catch (package.catchtag, call_trapping_problems_2, opaque, | |
| 2532 | 5979 &thrown, &thrown_tag, &thrown_backtrace); |
| 853 | 5980 else |
| 5981 /* Nothing special. */ | |
| 5982 tem = (fun) (arg); | |
| 5983 | |
| 1333 | 5984 if (!problem) |
| 5985 problem = &real_problem; | |
| 5986 | |
| 5987 if (!thrown) | |
| 853 | 5988 { |
| 1333 | 5989 problem->caught_error = 0; |
| 5990 problem->caught_throw = 0; | |
| 5991 problem->error_conditions = Qnil; | |
| 5992 problem->data = Qnil; | |
| 5993 problem->backtrace = Qnil; | |
| 5994 problem->thrown_tag = Qnil; | |
| 5995 problem->thrown_value = Qnil; | |
| 853 | 5996 } |
| 1333 | 5997 else if (EQ (thrown_tag, package.catchtag)) |
| 853 | 5998 { |
| 1333 | 5999 problem->caught_error = 1; |
| 6000 problem->caught_throw = 0; | |
| 6001 problem->error_conditions = package.error_conditions; | |
| 6002 problem->data = package.data; | |
| 6003 problem->backtrace = package.backtrace; | |
| 6004 problem->thrown_tag = Qnil; | |
| 6005 problem->thrown_value = Qnil; | |
| 853 | 6006 } |
| 1333 | 6007 else |
| 6008 { | |
| 6009 problem->caught_error = 0; | |
| 6010 problem->caught_throw = 1; | |
| 6011 problem->error_conditions = Qnil; | |
| 6012 problem->data = Qnil; | |
| 2532 | 6013 problem->backtrace = thrown_backtrace; |
| 1333 | 6014 problem->thrown_tag = thrown_tag; |
| 6015 problem->thrown_value = tem; | |
| 6016 } | |
| 6017 | |
| 6018 if (!(flags & INHIBIT_WARNING_ISSUE) && !(flags & POSTPONE_WARNING_ISSUE)) | |
| 6019 issue_call_trapping_problems_warning (warning_class, warning_string, | |
| 6020 problem); | |
| 853 | 6021 |
| 6022 if (!NILP (package.catchtag) && | |
| 6023 !EQ (package.catchtag, Vcatch_everything_tag)) | |
| 6024 free_opaque_ptr (package.catchtag); | |
| 6025 | |
| 6026 if (!NILP (opaque)) | |
| 6027 free_opaque_ptr (opaque); | |
| 6028 | |
| 6029 unbind_to (speccount); | |
| 6030 RETURN_UNGCPRO (thrown ? Qunbound : tem); | |
| 6031 } | |
| 6032 | |
| 6033 struct va_call_trapping_problems | |
| 6034 { | |
| 6035 lisp_fn_t fun; | |
| 6036 int nargs; | |
| 6037 Lisp_Object *args; | |
| 6038 }; | |
| 6039 | |
| 6040 static Lisp_Object | |
| 6041 va_call_trapping_problems_1 (void *ai_mi_madre) | |
| 6042 { | |
| 6043 struct va_call_trapping_problems *ai_no_corrida = | |
| 6044 (struct va_call_trapping_problems *) ai_mi_madre; | |
| 6045 Lisp_Object pegar_no_bumbum; | |
| 6046 | |
| 6047 PRIMITIVE_FUNCALL (pegar_no_bumbum, ai_no_corrida->fun, | |
| 6048 ai_no_corrida->args, ai_no_corrida->nargs); | |
| 6049 return pegar_no_bumbum; | |
| 6050 } | |
| 6051 | |
| 6052 /* #### document me. */ | |
| 6053 | |
| 6054 Lisp_Object | |
| 6055 va_call_trapping_problems (Lisp_Object warning_class, | |
| 867 | 6056 const CIbyte *warning_string, |
| 853 | 6057 int flags, |
| 6058 struct call_trapping_problems_result *problem, | |
| 6059 lisp_fn_t fun, int nargs, ...) | |
| 6060 { | |
| 6061 va_list vargs; | |
| 6062 Lisp_Object args[20]; | |
| 6063 int i; | |
| 6064 struct va_call_trapping_problems fazer_invocacao_atrapalhando_problemas; | |
| 6065 struct gcpro gcpro1; | |
| 6066 | |
| 6067 assert (nargs >= 0 && nargs < 20); | |
| 6068 | |
| 6069 va_start (vargs, nargs); | |
| 6070 for (i = 0; i < nargs; i++) | |
| 6071 args[i] = va_arg (vargs, Lisp_Object); | |
| 6072 va_end (vargs); | |
| 6073 | |
| 6074 fazer_invocacao_atrapalhando_problemas.fun = fun; | |
| 6075 fazer_invocacao_atrapalhando_problemas.nargs = nargs; | |
| 6076 fazer_invocacao_atrapalhando_problemas.args = args; | |
| 6077 | |
| 6078 GCPRO1_ARRAY (args, nargs); | |
| 6079 RETURN_UNGCPRO | |
| 6080 (call_trapping_problems | |
| 6081 (warning_class, warning_string, flags, problem, | |
| 6082 va_call_trapping_problems_1, &fazer_invocacao_atrapalhando_problemas)); | |
| 6083 } | |
| 6084 | |
| 6085 /* this is an older interface, barely different from | |
| 6086 va_call_trapping_problems. | |
| 6087 | |
| 6088 #### eliminate this or at least merge the ERROR_BEHAVIOR stuff into | |
| 6089 va_call_trapping_problems(). */ | |
| 6090 | |
| 6091 Lisp_Object | |
| 6092 call_with_suspended_errors (lisp_fn_t fun, Lisp_Object retval, | |
| 1204 | 6093 Lisp_Object class_, Error_Behavior errb, |
| 853 | 6094 int nargs, ...) |
| 6095 { | |
| 6096 va_list vargs; | |
| 6097 Lisp_Object args[20]; | |
| 6098 int i; | |
| 6099 struct va_call_trapping_problems fazer_invocacao_atrapalhando_problemas; | |
| 6100 int flags; | |
| 6101 struct gcpro gcpro1; | |
| 6102 | |
| 1204 | 6103 assert (SYMBOLP (class_)); /* sanity-check */ |
| 6104 assert (!NILP (class_)); | |
| 853 | 6105 assert (nargs >= 0 && nargs < 20); |
| 6106 | |
| 6107 va_start (vargs, nargs); | |
| 6108 for (i = 0; i < nargs; i++) | |
| 6109 args[i] = va_arg (vargs, Lisp_Object); | |
| 6110 va_end (vargs); | |
| 6111 | |
| 6112 /* If error-checking is not disabled, just call the function. */ | |
| 6113 | |
| 6114 if (ERRB_EQ (errb, ERROR_ME)) | |
| 6115 { | |
| 6116 Lisp_Object val; | |
| 6117 PRIMITIVE_FUNCALL (val, fun, args, nargs); | |
| 6118 return val; | |
| 6119 } | |
| 6120 | |
| 6121 if (ERRB_EQ (errb, ERROR_ME_NOT)) /* person wants no warnings */ | |
| 6122 flags = INHIBIT_WARNING_ISSUE | INHIBIT_ENTERING_DEBUGGER; | |
| 6123 else if (ERRB_EQ (errb, ERROR_ME_DEBUG_WARN)) | |
| 6124 flags = ISSUE_WARNINGS_AT_DEBUG_LEVEL | INHIBIT_ENTERING_DEBUGGER; | |
| 6125 else | |
| 6126 { | |
| 6127 assert (ERRB_EQ (errb, ERROR_ME_WARN)); | |
| 6128 flags = INHIBIT_ENTERING_DEBUGGER; | |
| 6129 } | |
| 6130 | |
| 6131 flags |= CALL_WITH_SUSPENDED_ERRORS; | |
| 6132 | |
| 6133 fazer_invocacao_atrapalhando_problemas.fun = fun; | |
| 6134 fazer_invocacao_atrapalhando_problemas.nargs = nargs; | |
| 6135 fazer_invocacao_atrapalhando_problemas.args = args; | |
| 6136 | |
| 6137 GCPRO1_ARRAY (args, nargs); | |
| 6138 { | |
| 6139 Lisp_Object its_way_too_goddamn_late = | |
| 6140 call_trapping_problems | |
| 1204 | 6141 (class_, 0, flags, 0, va_call_trapping_problems_1, |
| 853 | 6142 &fazer_invocacao_atrapalhando_problemas); |
| 6143 UNGCPRO; | |
| 6144 if (UNBOUNDP (its_way_too_goddamn_late)) | |
| 6145 return retval; | |
| 6146 else | |
| 6147 return its_way_too_goddamn_late; | |
| 6148 } | |
| 6149 } | |
| 6150 | |
| 6151 struct calln_trapping_problems | |
| 6152 { | |
| 6153 int nargs; | |
| 6154 Lisp_Object *args; | |
| 6155 }; | |
| 6156 | |
| 6157 static Lisp_Object | |
| 6158 calln_trapping_problems_1 (void *puta) | |
| 6159 { | |
| 6160 struct calln_trapping_problems *p = (struct calln_trapping_problems *) puta; | |
| 6161 | |
| 6162 return Ffuncall (p->nargs, p->args); | |
| 428 | 6163 } |
| 6164 | |
| 6165 static Lisp_Object | |
| 853 | 6166 calln_trapping_problems (Lisp_Object warning_class, |
| 867 | 6167 const CIbyte *warning_string, int flags, |
| 853 | 6168 struct call_trapping_problems_result *problem, |
| 6169 int nargs, Lisp_Object *args) | |
| 6170 { | |
| 6171 struct calln_trapping_problems foo; | |
| 6172 struct gcpro gcpro1; | |
| 6173 | |
| 6174 if (SYMBOLP (args[0])) | |
| 6175 { | |
| 6176 Lisp_Object tem = XSYMBOL (args[0])->function; | |
| 6177 if (NILP (tem) || UNBOUNDP (tem)) | |
| 6178 { | |
| 6179 if (problem) | |
| 6180 { | |
| 6181 problem->caught_error = 0; | |
| 6182 problem->caught_throw = 0; | |
| 6183 problem->error_conditions = Qnil; | |
| 6184 problem->data = Qnil; | |
| 6185 problem->backtrace = Qnil; | |
| 6186 problem->thrown_tag = Qnil; | |
| 6187 problem->thrown_value = Qnil; | |
| 6188 } | |
| 6189 return Qnil; | |
| 6190 } | |
| 6191 } | |
| 6192 | |
| 6193 foo.nargs = nargs; | |
| 6194 foo.args = args; | |
| 6195 | |
| 6196 GCPRO1_ARRAY (args, nargs); | |
| 6197 RETURN_UNGCPRO (call_trapping_problems (warning_class, warning_string, | |
| 6198 flags, problem, | |
| 6199 calln_trapping_problems_1, | |
| 6200 &foo)); | |
| 6201 } | |
| 6202 | |
| 6203 /* #### fix these functions to follow the calling convention of | |
| 6204 call_trapping_problems! */ | |
| 6205 | |
| 6206 Lisp_Object | |
| 867 | 6207 call0_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6208 int flags) |
| 6209 { | |
| 6210 return calln_trapping_problems (Qerror, warning_string, flags, 0, 1, | |
| 6211 &function); | |
| 428 | 6212 } |
| 6213 | |
| 6214 Lisp_Object | |
| 867 | 6215 call1_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6216 Lisp_Object object, int flags) |
| 6217 { | |
| 6218 Lisp_Object args[2]; | |
| 6219 | |
| 6220 args[0] = function; | |
| 6221 args[1] = object; | |
| 6222 | |
| 6223 return calln_trapping_problems (Qerror, warning_string, flags, 0, 2, | |
| 6224 args); | |
| 6225 } | |
| 6226 | |
| 6227 Lisp_Object | |
| 867 | 6228 call2_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6229 Lisp_Object object1, Lisp_Object object2, |
| 6230 int flags) | |
| 6231 { | |
| 6232 Lisp_Object args[3]; | |
| 6233 | |
| 6234 args[0] = function; | |
| 6235 args[1] = object1; | |
| 6236 args[2] = object2; | |
| 6237 | |
| 6238 return calln_trapping_problems (Qerror, warning_string, flags, 0, 3, | |
| 6239 args); | |
| 6240 } | |
| 6241 | |
| 6242 Lisp_Object | |
| 867 | 6243 call3_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6244 Lisp_Object object1, Lisp_Object object2, |
| 6245 Lisp_Object object3, int flags) | |
| 6246 { | |
| 6247 Lisp_Object args[4]; | |
| 6248 | |
| 6249 args[0] = function; | |
| 6250 args[1] = object1; | |
| 6251 args[2] = object2; | |
| 6252 args[3] = object3; | |
| 6253 | |
| 6254 return calln_trapping_problems (Qerror, warning_string, flags, 0, 4, | |
| 6255 args); | |
| 6256 } | |
| 6257 | |
| 6258 Lisp_Object | |
| 867 | 6259 call4_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6260 Lisp_Object object1, Lisp_Object object2, |
| 6261 Lisp_Object object3, Lisp_Object object4, | |
| 6262 int flags) | |
| 6263 { | |
| 6264 Lisp_Object args[5]; | |
| 6265 | |
| 6266 args[0] = function; | |
| 6267 args[1] = object1; | |
| 6268 args[2] = object2; | |
| 6269 args[3] = object3; | |
| 6270 args[4] = object4; | |
| 6271 | |
| 6272 return calln_trapping_problems (Qerror, warning_string, flags, 0, 5, | |
| 6273 args); | |
| 6274 } | |
| 6275 | |
| 6276 Lisp_Object | |
| 867 | 6277 call5_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6278 Lisp_Object object1, Lisp_Object object2, |
| 6279 Lisp_Object object3, Lisp_Object object4, | |
| 6280 Lisp_Object object5, int flags) | |
| 6281 { | |
| 6282 Lisp_Object args[6]; | |
| 6283 | |
| 6284 args[0] = function; | |
| 6285 args[1] = object1; | |
| 6286 args[2] = object2; | |
| 6287 args[3] = object3; | |
| 6288 args[4] = object4; | |
| 6289 args[5] = object5; | |
| 6290 | |
| 6291 return calln_trapping_problems (Qerror, warning_string, flags, 0, 6, | |
| 6292 args); | |
| 6293 } | |
| 6294 | |
| 6295 struct eval_in_buffer_trapping_problems | |
| 6296 { | |
| 6297 struct buffer *buf; | |
| 6298 Lisp_Object form; | |
| 6299 }; | |
| 6300 | |
| 6301 static Lisp_Object | |
| 6302 eval_in_buffer_trapping_problems_1 (void *arg) | |
| 6303 { | |
| 6304 struct eval_in_buffer_trapping_problems *p = | |
| 6305 (struct eval_in_buffer_trapping_problems *) arg; | |
| 6306 | |
| 6307 return eval_in_buffer (p->buf, p->form); | |
| 6308 } | |
| 6309 | |
| 6310 /* #### fix these functions to follow the calling convention of | |
| 6311 call_trapping_problems! */ | |
| 6312 | |
| 6313 Lisp_Object | |
| 867 | 6314 eval_in_buffer_trapping_problems (const CIbyte *warning_string, |
| 853 | 6315 struct buffer *buf, Lisp_Object form, |
| 6316 int flags) | |
| 6317 { | |
| 6318 struct eval_in_buffer_trapping_problems p; | |
| 6319 Lisp_Object buffer = wrap_buffer (buf); | |
| 428 | 6320 struct gcpro gcpro1, gcpro2; |
| 6321 | |
| 853 | 6322 GCPRO2 (buffer, form); |
| 6323 p.buf = buf; | |
| 6324 p.form = form; | |
| 6325 RETURN_UNGCPRO (call_trapping_problems (Qerror, warning_string, flags, 0, | |
| 6326 eval_in_buffer_trapping_problems_1, | |
| 6327 &p)); | |
| 6328 } | |
| 6329 | |
| 6330 Lisp_Object | |
| 1333 | 6331 run_hook_trapping_problems (Lisp_Object warning_class, |
| 853 | 6332 Lisp_Object hook_symbol, |
| 6333 int flags) | |
| 6334 { | |
| 1333 | 6335 return run_hook_with_args_trapping_problems (warning_class, 1, &hook_symbol, |
| 853 | 6336 RUN_HOOKS_TO_COMPLETION, |
| 6337 flags); | |
| 428 | 6338 } |
| 6339 | |
| 6340 static Lisp_Object | |
| 853 | 6341 safe_run_hook_trapping_problems_1 (void *puta) |
| 6342 { | |
| 5013 | 6343 Lisp_Object hook = GET_LISP_FROM_VOID (puta); |
| 853 | 6344 |
| 6345 run_hook (hook); | |
| 428 | 6346 return Qnil; |
| 6347 } | |
| 6348 | |
| 853 | 6349 /* Same as run_hook_trapping_problems() but also set the hook to nil |
| 6350 if an error occurs (but not a quit). */ | |
| 6351 | |
| 428 | 6352 Lisp_Object |
| 1333 | 6353 safe_run_hook_trapping_problems (Lisp_Object warning_class, |
| 6354 Lisp_Object hook_symbol, int flags) | |
| 853 | 6355 { |
| 428 | 6356 Lisp_Object tem; |
| 853 | 6357 struct gcpro gcpro1, gcpro2; |
| 6358 struct call_trapping_problems_result prob; | |
| 428 | 6359 |
| 6360 if (!initialized || preparing_for_armageddon) | |
| 6361 return Qnil; | |
| 6362 tem = find_symbol_value (hook_symbol); | |
| 6363 if (NILP (tem) || UNBOUNDP (tem)) | |
| 6364 return Qnil; | |
| 6365 | |
| 853 | 6366 GCPRO2 (hook_symbol, tem); |
| 1333 | 6367 tem = call_trapping_problems (Qerror, NULL, |
| 6368 flags | POSTPONE_WARNING_ISSUE, | |
| 853 | 6369 &prob, |
| 6370 safe_run_hook_trapping_problems_1, | |
| 5013 | 6371 STORE_LISP_IN_VOID (hook_symbol)); |
| 1333 | 6372 { |
| 6373 Lisp_Object hook_name = XSYMBOL_NAME (hook_symbol); | |
| 6374 Ibyte *hook_str = XSTRING_DATA (hook_name); | |
| 6375 Ibyte *err = alloca_ibytes (XSTRING_LENGTH (hook_name) + 100); | |
| 6376 | |
| 6377 if (prob.caught_throw || (prob.caught_error && !EQ (prob.error_conditions, | |
| 6378 Qquit))) | |
| 6379 { | |
| 6380 Fset (hook_symbol, Qnil); | |
| 6381 qxesprintf (err, "Error in `%s' (resetting to nil)", hook_str); | |
| 6382 } | |
| 6383 else | |
| 6384 qxesprintf (err, "Quit in `%s'", hook_str); | |
| 6385 | |
| 6386 | |
| 6387 issue_call_trapping_problems_warning (warning_class, (CIbyte *) err, | |
| 6388 &prob); | |
| 6389 } | |
| 6390 | |
| 6391 UNGCPRO; | |
| 6392 return tem; | |
| 853 | 6393 } |
| 6394 | |
| 6395 struct run_hook_with_args_in_buffer_trapping_problems | |
| 6396 { | |
| 6397 struct buffer *buf; | |
| 6398 int nargs; | |
| 6399 Lisp_Object *args; | |
| 6400 enum run_hooks_condition cond; | |
| 6401 }; | |
| 6402 | |
| 6403 static Lisp_Object | |
| 6404 run_hook_with_args_in_buffer_trapping_problems_1 (void *puta) | |
| 6405 { | |
| 6406 struct run_hook_with_args_in_buffer_trapping_problems *porra = | |
| 6407 (struct run_hook_with_args_in_buffer_trapping_problems *) puta; | |
| 6408 | |
| 6409 return run_hook_with_args_in_buffer (porra->buf, porra->nargs, porra->args, | |
| 6410 porra->cond); | |
| 6411 } | |
| 6412 | |
| 6413 /* #### fix these functions to follow the calling convention of | |
| 6414 call_trapping_problems! */ | |
| 428 | 6415 |
| 6416 Lisp_Object | |
| 1333 | 6417 run_hook_with_args_in_buffer_trapping_problems (Lisp_Object warning_class, |
| 853 | 6418 struct buffer *buf, int nargs, |
| 6419 Lisp_Object *args, | |
| 6420 enum run_hooks_condition cond, | |
| 6421 int flags) | |
| 6422 { | |
| 6423 Lisp_Object sym, val, ret; | |
| 6424 struct run_hook_with_args_in_buffer_trapping_problems diversity_and_distrust; | |
| 428 | 6425 struct gcpro gcpro1; |
| 1333 | 6426 Lisp_Object hook_name; |
| 6427 Ibyte *hook_str; | |
| 6428 Ibyte *err; | |
| 428 | 6429 |
| 6430 if (!initialized || preparing_for_armageddon) | |
| 853 | 6431 /* We need to bail out of here pronto. */ |
| 428 | 6432 return Qnil; |
| 6433 | |
| 853 | 6434 GCPRO1_ARRAY (args, nargs); |
| 6435 | |
| 6436 sym = args[0]; | |
| 6437 val = symbol_value_in_buffer (sym, wrap_buffer (buf)); | |
| 6438 ret = (cond == RUN_HOOKS_UNTIL_FAILURE ? Qt : Qnil); | |
| 6439 | |
| 6440 if (UNBOUNDP (val) || NILP (val)) | |
| 6441 RETURN_UNGCPRO (ret); | |
| 6442 | |
| 6443 diversity_and_distrust.buf = buf; | |
| 6444 diversity_and_distrust.nargs = nargs; | |
| 6445 diversity_and_distrust.args = args; | |
| 6446 diversity_and_distrust.cond = cond; | |
| 6447 | |
| 1333 | 6448 hook_name = XSYMBOL_NAME (args[0]); |
| 6449 hook_str = XSTRING_DATA (hook_name); | |
| 6450 err = alloca_ibytes (XSTRING_LENGTH (hook_name) + 100); | |
| 6451 qxesprintf (err, "Error in `%s'", hook_str); | |
| 853 | 6452 RETURN_UNGCPRO |
| 6453 (call_trapping_problems | |
| 1333 | 6454 (warning_class, (CIbyte *) err, flags, 0, |
| 853 | 6455 run_hook_with_args_in_buffer_trapping_problems_1, |
| 6456 &diversity_and_distrust)); | |
| 428 | 6457 } |
| 6458 | |
| 6459 Lisp_Object | |
| 1333 | 6460 run_hook_with_args_trapping_problems (Lisp_Object warning_class, |
| 853 | 6461 int nargs, |
| 6462 Lisp_Object *args, | |
| 6463 enum run_hooks_condition cond, | |
| 6464 int flags) | |
| 6465 { | |
| 6466 return run_hook_with_args_in_buffer_trapping_problems | |
| 1333 | 6467 (warning_class, current_buffer, nargs, args, cond, flags); |
| 428 | 6468 } |
| 6469 | |
| 6470 Lisp_Object | |
| 1333 | 6471 va_run_hook_with_args_trapping_problems (Lisp_Object warning_class, |
| 853 | 6472 Lisp_Object hook_var, |
| 6473 int nargs, ...) | |
| 6474 { | |
| 6475 /* This function can GC */ | |
| 6476 struct gcpro gcpro1; | |
| 6477 int i; | |
| 6478 va_list vargs; | |
| 6479 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs); | |
| 6480 int flags; | |
| 6481 | |
| 6482 va_start (vargs, nargs); | |
| 6483 funcall_args[0] = hook_var; | |
| 6484 for (i = 0; i < nargs; i++) | |
| 6485 funcall_args[i + 1] = va_arg (vargs, Lisp_Object); | |
| 6486 flags = va_arg (vargs, int); | |
| 6487 va_end (vargs); | |
| 6488 | |
| 6489 GCPRO1_ARRAY (funcall_args, nargs + 1); | |
| 6490 RETURN_UNGCPRO (run_hook_with_args_in_buffer_trapping_problems | |
| 1333 | 6491 (warning_class, current_buffer, nargs + 1, funcall_args, |
| 853 | 6492 RUN_HOOKS_TO_COMPLETION, flags)); |
| 428 | 6493 } |
| 6494 | |
| 6495 Lisp_Object | |
| 1333 | 6496 va_run_hook_with_args_in_buffer_trapping_problems (Lisp_Object warning_class, |
| 853 | 6497 struct buffer *buf, |
| 6498 Lisp_Object hook_var, | |
| 6499 int nargs, ...) | |
| 6500 { | |
| 6501 /* This function can GC */ | |
| 6502 struct gcpro gcpro1; | |
| 6503 int i; | |
| 6504 va_list vargs; | |
| 6505 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs); | |
| 6506 int flags; | |
| 6507 | |
| 6508 va_start (vargs, nargs); | |
| 6509 funcall_args[0] = hook_var; | |
| 6510 for (i = 0; i < nargs; i++) | |
| 6511 funcall_args[i + 1] = va_arg (vargs, Lisp_Object); | |
| 6512 flags = va_arg (vargs, int); | |
| 6513 va_end (vargs); | |
| 6514 | |
| 6515 GCPRO1_ARRAY (funcall_args, nargs + 1); | |
| 6516 RETURN_UNGCPRO (run_hook_with_args_in_buffer_trapping_problems | |
| 1333 | 6517 (warning_class, buf, nargs + 1, funcall_args, |
| 853 | 6518 RUN_HOOKS_TO_COMPLETION, flags)); |
| 428 | 6519 } |
| 6520 | |
| 6521 | |
| 6522 /************************************************************************/ | |
| 6523 /* The special binding stack */ | |
| 771 | 6524 /* Most C code should simply use specbind() and unbind_to_1(). */ |
| 428 | 6525 /* When performance is critical, use the macros in backtrace.h. */ |
| 6526 /************************************************************************/ | |
| 6527 | |
| 6528 #define min_max_specpdl_size 400 | |
| 6529 | |
| 6530 void | |
| 647 | 6531 grow_specpdl (EMACS_INT reserved) |
| 6532 { | |
| 6533 EMACS_INT size_needed = specpdl_depth() + reserved; | |
| 428 | 6534 if (size_needed >= max_specpdl_size) |
| 6535 { | |
| 6536 if (max_specpdl_size < min_max_specpdl_size) | |
| 6537 max_specpdl_size = min_max_specpdl_size; | |
| 6538 if (size_needed >= max_specpdl_size) | |
| 6539 { | |
| 1951 | 6540 /* Leave room for some specpdl in the debugger. */ |
| 6541 max_specpdl_size = size_needed + 100; | |
| 6542 if (max_specpdl_size > specpdl_size) | |
| 6543 { | |
| 6544 specpdl_size = max_specpdl_size; | |
| 6545 XREALLOC_ARRAY (specpdl, struct specbinding, specpdl_size); | |
| 6546 specpdl_ptr = specpdl + specpdl_depth(); | |
| 6547 } | |
| 563 | 6548 signal_continuable_error |
| 6549 (Qstack_overflow, | |
| 6550 "Variable binding depth exceeds max-specpdl-size", Qunbound); | |
| 428 | 6551 } |
| 6552 } | |
| 6553 while (specpdl_size < size_needed) | |
| 6554 { | |
| 6555 specpdl_size *= 2; | |
| 6556 if (specpdl_size > max_specpdl_size) | |
| 6557 specpdl_size = max_specpdl_size; | |
| 6558 } | |
| 6559 XREALLOC_ARRAY (specpdl, struct specbinding, specpdl_size); | |
| 6560 specpdl_ptr = specpdl + specpdl_depth(); | |
| 853 | 6561 check_specbind_stack_sanity (); |
| 428 | 6562 } |
| 6563 | |
| 6564 | |
| 6565 /* Handle unbinding buffer-local variables */ | |
| 6566 static Lisp_Object | |
| 6567 specbind_unwind_local (Lisp_Object ovalue) | |
| 6568 { | |
| 6569 Lisp_Object current = Fcurrent_buffer (); | |
| 6570 Lisp_Object symbol = specpdl_ptr->symbol; | |
| 853 | 6571 Lisp_Object victim = ovalue; |
| 6572 Lisp_Object buf = get_buffer (XCAR (victim), 0); | |
| 6573 ovalue = XCDR (victim); | |
| 428 | 6574 |
| 6575 free_cons (victim); | |
| 6576 | |
| 6577 if (NILP (buf)) | |
| 6578 { | |
| 6579 /* Deleted buffer -- do nothing */ | |
| 6580 } | |
| 6581 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buf)) == 0) | |
| 6582 { | |
| 6583 /* Was buffer-local when binding was made, now no longer is. | |
| 6584 * (kill-local-variable can do this.) | |
| 6585 * Do nothing in this case. | |
| 6586 */ | |
| 6587 } | |
| 6588 else if (EQ (buf, current)) | |
| 6589 Fset (symbol, ovalue); | |
| 6590 else | |
| 6591 { | |
| 6592 /* Urk! Somebody switched buffers */ | |
| 6593 struct gcpro gcpro1; | |
| 6594 GCPRO1 (current); | |
| 6595 Fset_buffer (buf); | |
| 6596 Fset (symbol, ovalue); | |
| 6597 Fset_buffer (current); | |
| 6598 UNGCPRO; | |
| 6599 } | |
| 6600 return symbol; | |
| 6601 } | |
| 6602 | |
| 6603 static Lisp_Object | |
| 6604 specbind_unwind_wasnt_local (Lisp_Object buffer) | |
| 6605 { | |
| 6606 Lisp_Object current = Fcurrent_buffer (); | |
| 6607 Lisp_Object symbol = specpdl_ptr->symbol; | |
| 6608 | |
| 6609 buffer = get_buffer (buffer, 0); | |
| 6610 if (NILP (buffer)) | |
| 6611 { | |
| 6612 /* Deleted buffer -- do nothing */ | |
| 6613 } | |
| 6614 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buffer)) == 0) | |
| 6615 { | |
| 6616 /* Was buffer-local when binding was made, now no longer is. | |
| 6617 * (kill-local-variable can do this.) | |
| 6618 * Do nothing in this case. | |
| 6619 */ | |
| 6620 } | |
| 6621 else if (EQ (buffer, current)) | |
| 6622 Fkill_local_variable (symbol); | |
| 6623 else | |
| 6624 { | |
| 6625 /* Urk! Somebody switched buffers */ | |
| 6626 struct gcpro gcpro1; | |
| 6627 GCPRO1 (current); | |
| 6628 Fset_buffer (buffer); | |
| 6629 Fkill_local_variable (symbol); | |
| 6630 Fset_buffer (current); | |
| 6631 UNGCPRO; | |
| 6632 } | |
| 6633 return symbol; | |
| 6634 } | |
| 6635 | |
| 6636 | |
| 6637 void | |
| 6638 specbind (Lisp_Object symbol, Lisp_Object value) | |
| 6639 { | |
| 6640 SPECBIND (symbol, value); | |
| 853 | 6641 |
| 6642 check_specbind_stack_sanity (); | |
| 428 | 6643 } |
| 6644 | |
| 6645 void | |
| 6646 specbind_magic (Lisp_Object symbol, Lisp_Object value) | |
| 6647 { | |
| 6648 int buffer_local = | |
| 6649 symbol_value_buffer_local_info (symbol, current_buffer); | |
| 6650 | |
| 6651 if (buffer_local == 0) | |
| 6652 { | |
| 6653 specpdl_ptr->old_value = find_symbol_value (symbol); | |
| 771 | 6654 specpdl_ptr->func = 0; /* Handled specially by unbind_to_1 */ |
| 428 | 6655 } |
| 6656 else if (buffer_local > 0) | |
| 6657 { | |
| 6658 /* Already buffer-local */ | |
| 6659 specpdl_ptr->old_value = noseeum_cons (Fcurrent_buffer (), | |
| 6660 find_symbol_value (symbol)); | |
| 6661 specpdl_ptr->func = specbind_unwind_local; | |
| 6662 } | |
| 6663 else | |
| 6664 { | |
| 6665 /* About to become buffer-local */ | |
| 6666 specpdl_ptr->old_value = Fcurrent_buffer (); | |
| 6667 specpdl_ptr->func = specbind_unwind_wasnt_local; | |
| 6668 } | |
| 6669 | |
| 6670 specpdl_ptr->symbol = symbol; | |
| 6671 specpdl_ptr++; | |
| 6672 specpdl_depth_counter++; | |
| 6673 | |
| 6674 Fset (symbol, value); | |
| 853 | 6675 |
| 6676 check_specbind_stack_sanity (); | |
| 428 | 6677 } |
| 6678 | |
| 771 | 6679 /* Record an unwind-protect -- FUNCTION will be called with ARG no matter |
| 6680 whether a normal or non-local exit occurs. (You need to call unbind_to_1() | |
| 6681 before your function returns normally, passing in the integer returned | |
| 6682 by this function.) Note: As long as the unwind-protect exists, ARG is | |
| 6683 automatically GCPRO'd. The return value from FUNCTION is completely | |
| 6684 ignored. #### We should eliminate it entirely. */ | |
| 6685 | |
| 6686 int | |
| 428 | 6687 record_unwind_protect (Lisp_Object (*function) (Lisp_Object arg), |
| 6688 Lisp_Object arg) | |
| 6689 { | |
| 6690 SPECPDL_RESERVE (1); | |
| 6691 specpdl_ptr->func = function; | |
| 6692 specpdl_ptr->symbol = Qnil; | |
| 6693 specpdl_ptr->old_value = arg; | |
| 6694 specpdl_ptr++; | |
| 6695 specpdl_depth_counter++; | |
| 853 | 6696 check_specbind_stack_sanity (); |
| 771 | 6697 return specpdl_depth_counter - 1; |
| 6698 } | |
| 6699 | |
| 6700 static Lisp_Object | |
| 802 | 6701 restore_lisp_object (Lisp_Object cons) |
| 6702 { | |
| 5013 | 6703 Lisp_Object laddr = XCAR (cons); |
| 6704 Lisp_Object *addr = (Lisp_Object *) GET_VOID_FROM_LISP (laddr); | |
| 802 | 6705 *addr = XCDR (cons); |
| 853 | 6706 free_cons (cons); |
| 802 | 6707 return Qnil; |
| 6708 } | |
| 6709 | |
| 6710 /* Establish an unwind-protect which will restore the Lisp_Object pointed to | |
| 6711 by ADDR with the value VAL. */ | |
| 814 | 6712 static int |
| 802 | 6713 record_unwind_protect_restoring_lisp_object (Lisp_Object *addr, |
| 6714 Lisp_Object val) | |
| 6715 { | |
| 5013 | 6716 /* We use a cons rather than a malloc()ed structure because we want the |
| 6717 Lisp object to have garbage-collection protection */ | |
| 6718 Lisp_Object laddr = STORE_VOID_IN_LISP (addr); | |
| 802 | 6719 return record_unwind_protect (restore_lisp_object, |
| 5013 | 6720 noseeum_cons (laddr, val)); |
| 802 | 6721 } |
| 6722 | |
| 6723 /* Similar to specbind() but for any C variable whose value is a | |
| 6724 Lisp_Object. Sets up an unwind-protect to restore the variable | |
| 6725 pointed to by ADDR to its existing value, and then changes its | |
| 6726 value to NEWVAL. Returns the previous value of specpdl_depth(); | |
| 6727 pass this to unbind_to() after you are done. */ | |
| 6728 int | |
| 6729 internal_bind_lisp_object (Lisp_Object *addr, Lisp_Object newval) | |
| 6730 { | |
| 6731 int count = specpdl_depth (); | |
| 6732 record_unwind_protect_restoring_lisp_object (addr, *addr); | |
| 6733 *addr = newval; | |
| 6734 return count; | |
| 6735 } | |
| 6736 | |
| 5013 | 6737 struct restore_int |
| 6738 { | |
| 6739 int *addr; | |
| 802 | 6740 int val; |
| 5013 | 6741 }; |
| 6742 | |
| 6743 static Lisp_Object | |
| 6744 restore_int (Lisp_Object obj) | |
| 6745 { | |
| 6746 struct restore_int *ri = (struct restore_int *) GET_VOID_FROM_LISP (obj); | |
| 6747 *(ri->addr) = ri->val; | |
| 6748 xfree (ri); | |
| 802 | 6749 return Qnil; |
| 6750 } | |
| 6751 | |
| 6752 /* Establish an unwind-protect which will restore the int pointed to | |
| 6753 by ADDR with the value VAL. This function works correctly with | |
| 6754 all ints, even those that don't fit into a Lisp integer. */ | |
| 1333 | 6755 int |
| 802 | 6756 record_unwind_protect_restoring_int (int *addr, int val) |
| 6757 { | |
| 5013 | 6758 struct restore_int *ri = xnew (struct restore_int); |
| 6759 ri->addr = addr; | |
| 6760 ri->val = val; | |
| 6761 return record_unwind_protect (restore_int, STORE_VOID_IN_LISP (ri)); | |
| 802 | 6762 } |
| 6763 | |
| 6764 /* Similar to specbind() but for any C variable whose value is an int. | |
| 6765 Sets up an unwind-protect to restore the variable pointed to by | |
| 6766 ADDR to its existing value, and then changes its value to NEWVAL. | |
| 6767 Returns the previous value of specpdl_depth(); pass this to | |
| 6768 unbind_to() after you are done. This function works correctly with | |
| 6769 all ints, even those that don't fit into a Lisp integer. */ | |
| 6770 int | |
| 6771 internal_bind_int (int *addr, int newval) | |
| 6772 { | |
| 6773 int count = specpdl_depth (); | |
| 6774 record_unwind_protect_restoring_int (addr, *addr); | |
| 6775 *addr = newval; | |
| 6776 return count; | |
| 6777 } | |
| 6778 | |
| 6779 static Lisp_Object | |
| 771 | 6780 free_pointer (Lisp_Object opaque) |
| 6781 { | |
| 5013 | 6782 void *ptr = GET_VOID_FROM_LISP (opaque); |
| 6783 xfree (ptr); | |
| 771 | 6784 return Qnil; |
| 6785 } | |
| 6786 | |
| 6787 /* Establish an unwind-protect which will free the specified block. | |
| 6788 */ | |
| 6789 int | |
| 6790 record_unwind_protect_freeing (void *ptr) | |
| 6791 { | |
| 5013 | 6792 return record_unwind_protect (free_pointer, STORE_VOID_IN_LISP (ptr)); |
| 771 | 6793 } |
| 6794 | |
| 6795 static Lisp_Object | |
| 6796 free_dynarr (Lisp_Object opaque) | |
| 6797 { | |
| 5013 | 6798 Dynarr_free (GET_VOID_FROM_LISP (opaque)); |
| 771 | 6799 return Qnil; |
| 6800 } | |
| 6801 | |
| 6802 int | |
| 6803 record_unwind_protect_freeing_dynarr (void *ptr) | |
| 6804 { | |
| 5013 | 6805 return record_unwind_protect (free_dynarr, STORE_VOID_IN_LISP (ptr)); |
| 771 | 6806 } |
| 428 | 6807 |
| 6808 /* Unwind the stack till specpdl_depth() == COUNT. | |
| 6809 VALUE is not used, except that, purely as a convenience to the | |
| 771 | 6810 caller, it is protected from garbage-protection and returned. */ |
| 428 | 6811 Lisp_Object |
| 771 | 6812 unbind_to_1 (int count, Lisp_Object value) |
| 428 | 6813 { |
| 6814 UNBIND_TO_GCPRO (count, value); | |
| 853 | 6815 check_specbind_stack_sanity (); |
| 428 | 6816 return value; |
| 6817 } | |
| 6818 | |
| 6819 /* Don't call this directly. | |
| 6820 Only for use by UNBIND_TO* macros in backtrace.h */ | |
| 6821 void | |
| 6822 unbind_to_hairy (int count) | |
| 6823 { | |
| 442 | 6824 ++specpdl_ptr; |
| 6825 ++specpdl_depth_counter; | |
| 6826 | |
| 428 | 6827 while (specpdl_depth_counter != count) |
| 6828 { | |
| 1313 | 6829 Lisp_Object oquit = Qunbound; |
| 6830 | |
| 6831 /* Do this check BEFORE decrementing the values below, because once | |
| 6832 they're decremented, GC protection is lost on | |
| 6833 specpdl_ptr->old_value. */ | |
| 1322 | 6834 if (specpdl_ptr[-1].func == Fprogn) |
| 1313 | 6835 { |
| 6836 /* Allow QUIT within unwind-protect routines, but defer any | |
| 6837 existing QUIT until afterwards. Only do this, however, for | |
| 6838 unwind-protects established by Lisp code, not by C code | |
| 6839 (e.g. free_opaque_ptr() or something), because the act of | |
| 6840 checking for QUIT can cause all sorts of weird things to | |
| 6841 happen, since it churns the event loop -- redisplay, running | |
| 6842 Lisp, etc. Code should not have to worry about this just | |
| 6843 because of establishing an unwind-protect. */ | |
| 6844 check_quit (); /* make Vquit_flag accurate */ | |
| 6845 oquit = Vquit_flag; | |
| 6846 Vquit_flag = Qnil; | |
| 6847 } | |
| 6848 | |
| 428 | 6849 --specpdl_ptr; |
| 6850 --specpdl_depth_counter; | |
| 6851 | |
| 1313 | 6852 /* #### At this point, there is no GC protection on old_value. This |
| 6853 could be a real problem, depending on what unwind-protect function | |
| 6854 is called. It looks like it just so happens that the ones | |
| 6855 actually called don't have a problem with this, e.g. Fprogn. But | |
| 6856 we should look into fixing this. (Many unwind-protect functions | |
| 6857 free values. Is it a problem if freed values are | |
| 6858 GC-protected?) */ | |
| 428 | 6859 if (specpdl_ptr->func != 0) |
| 1313 | 6860 { |
| 6861 /* An unwind-protect */ | |
| 6862 (*specpdl_ptr->func) (specpdl_ptr->old_value); | |
| 6863 } | |
| 6864 | |
| 428 | 6865 else |
| 6866 { | |
| 6867 /* We checked symbol for validity when we specbound it, | |
| 6868 so only need to call Fset if symbol has magic value. */ | |
| 440 | 6869 Lisp_Symbol *sym = XSYMBOL (specpdl_ptr->symbol); |
| 428 | 6870 if (!SYMBOL_VALUE_MAGIC_P (sym->value)) |
| 6871 sym->value = specpdl_ptr->old_value; | |
| 6872 else | |
| 6873 Fset (specpdl_ptr->symbol, specpdl_ptr->old_value); | |
| 6874 } | |
| 6875 | |
| 6876 #if 0 /* martin */ | |
| 6877 #ifndef EXCEEDINGLY_QUESTIONABLE_CODE | |
| 6878 /* There should never be anything here for us to remove. | |
| 6879 If so, it indicates a logic error in Emacs. Catches | |
| 6880 should get removed when a throw or signal occurs, or | |
| 6881 when a catch or condition-case exits normally. But | |
| 6882 it's too dangerous to just remove this code. --ben */ | |
| 6883 | |
| 6884 /* Furthermore, this code is not in FSFmacs!!! | |
| 6885 Braino on mly's part? */ | |
| 6886 /* If we're unwound past the pdlcount of a catch frame, | |
| 6887 that catch can't possibly still be valid. */ | |
| 6888 while (catchlist && catchlist->pdlcount > specpdl_depth_counter) | |
| 6889 { | |
| 6890 catchlist = catchlist->next; | |
| 6891 /* Don't mess with gcprolist, backtrace_list here */ | |
| 6892 } | |
| 6893 #endif | |
| 6894 #endif | |
| 1313 | 6895 |
| 6896 if (!UNBOUNDP (oquit)) | |
| 6897 Vquit_flag = oquit; | |
| 428 | 6898 } |
| 853 | 6899 check_specbind_stack_sanity (); |
| 428 | 6900 } |
| 6901 | |
| 6902 | |
| 6903 | |
| 6904 /* Get the value of symbol's global binding, even if that binding is | |
| 6905 not now dynamically visible. May return Qunbound or magic values. */ | |
| 6906 | |
| 6907 Lisp_Object | |
| 6908 top_level_value (Lisp_Object symbol) | |
| 6909 { | |
| 6910 REGISTER struct specbinding *ptr = specpdl; | |
| 6911 | |
| 6912 CHECK_SYMBOL (symbol); | |
| 6913 for (; ptr != specpdl_ptr; ptr++) | |
| 6914 { | |
| 6915 if (EQ (ptr->symbol, symbol)) | |
| 6916 return ptr->old_value; | |
| 6917 } | |
| 6918 return XSYMBOL (symbol)->value; | |
| 6919 } | |
| 6920 | |
| 6921 #if 0 | |
| 6922 | |
| 6923 Lisp_Object | |
| 6924 top_level_set (Lisp_Object symbol, Lisp_Object newval) | |
| 6925 { | |
| 6926 REGISTER struct specbinding *ptr = specpdl; | |
| 6927 | |
| 6928 CHECK_SYMBOL (symbol); | |
| 6929 for (; ptr != specpdl_ptr; ptr++) | |
| 6930 { | |
| 6931 if (EQ (ptr->symbol, symbol)) | |
| 6932 { | |
| 6933 ptr->old_value = newval; | |
| 6934 return newval; | |
| 6935 } | |
| 6936 } | |
| 6937 return Fset (symbol, newval); | |
| 6938 } | |
| 6939 | |
| 6940 #endif /* 0 */ | |
| 6941 | |
| 6942 | |
| 6943 /************************************************************************/ | |
| 6944 /* Backtraces */ | |
| 6945 /************************************************************************/ | |
| 6946 | |
| 6947 DEFUN ("backtrace-debug", Fbacktrace_debug, 2, 2, 0, /* | |
| 6948 Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG. | |
| 6949 The debugger is entered when that frame exits, if the flag is non-nil. | |
| 6950 */ | |
| 6951 (level, flag)) | |
| 6952 { | |
| 6953 REGISTER struct backtrace *backlist = backtrace_list; | |
| 6954 REGISTER int i; | |
| 6955 | |
| 6956 CHECK_INT (level); | |
| 6957 | |
| 6958 for (i = 0; backlist && i < XINT (level); i++) | |
| 6959 { | |
| 6960 backlist = backlist->next; | |
| 6961 } | |
| 6962 | |
| 6963 if (backlist) | |
| 6964 backlist->debug_on_exit = !NILP (flag); | |
| 6965 | |
| 6966 return flag; | |
| 6967 } | |
| 6968 | |
| 6969 static void | |
| 6970 backtrace_specials (int speccount, int speclimit, Lisp_Object stream) | |
| 6971 { | |
| 6972 int printing_bindings = 0; | |
| 6973 | |
| 6974 for (; speccount > speclimit; speccount--) | |
| 6975 { | |
| 6976 if (specpdl[speccount - 1].func == 0 | |
| 6977 || specpdl[speccount - 1].func == specbind_unwind_local | |
| 6978 || specpdl[speccount - 1].func == specbind_unwind_wasnt_local) | |
| 6979 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
6980 write_ascstring (stream, !printing_bindings ? " # bind (" : " "); |
| 428 | 6981 Fprin1 (specpdl[speccount - 1].symbol, stream); |
| 6982 printing_bindings = 1; | |
| 6983 } | |
| 6984 else | |
| 6985 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
6986 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
|
6987 write_ascstring (stream, " # (unwind-protect ...)\n"); |
| 428 | 6988 printing_bindings = 0; |
| 6989 } | |
| 6990 } | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
6991 if (printing_bindings) write_ascstring (stream, ")\n"); |
| 428 | 6992 } |
| 6993 | |
| 1292 | 6994 static Lisp_Object |
| 6995 backtrace_unevalled_args (Lisp_Object *args) | |
| 6996 { | |
| 6997 if (args) | |
| 6998 return *args; | |
| 6999 else | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7000 return list1 (build_ascstring ("[internal]")); |
| 1292 | 7001 } |
| 7002 | |
| 428 | 7003 DEFUN ("backtrace", Fbacktrace, 0, 2, "", /* |
| 7004 Print a trace of Lisp function calls currently active. | |
| 438 | 7005 Optional arg STREAM specifies the output stream to send the backtrace to, |
| 444 | 7006 and defaults to the value of `standard-output'. |
| 7007 Optional second arg DETAILED non-nil means show places where currently | |
| 7008 active variable bindings, catches, condition-cases, and | |
| 7009 unwind-protects, as well as function calls, were made. | |
| 428 | 7010 */ |
| 7011 (stream, detailed)) | |
| 7012 { | |
| 7013 /* This function can GC */ | |
| 7014 struct backtrace *backlist = backtrace_list; | |
| 7015 struct catchtag *catches = catchlist; | |
| 7016 int speccount = specpdl_depth(); | |
| 7017 | |
| 7018 int old_nl = print_escape_newlines; | |
| 7019 int old_pr = print_readably; | |
| 7020 Lisp_Object old_level = Vprint_level; | |
| 7021 Lisp_Object oiq = Vinhibit_quit; | |
| 7022 struct gcpro gcpro1, gcpro2; | |
| 7023 | |
| 7024 /* We can't allow quits in here because that could cause the values | |
| 7025 of print_readably and print_escape_newlines to get screwed up. | |
| 7026 Normally we would use a record_unwind_protect but that would | |
| 7027 screw up the functioning of this function. */ | |
| 7028 Vinhibit_quit = Qt; | |
| 7029 | |
| 7030 entering_debugger = 0; | |
| 7031 | |
| 872 | 7032 if (!NILP (detailed)) |
| 7033 Vprint_level = make_int (50); | |
| 7034 else | |
| 7035 Vprint_level = make_int (3); | |
| 428 | 7036 print_readably = 0; |
| 7037 print_escape_newlines = 1; | |
| 7038 | |
| 7039 GCPRO2 (stream, old_level); | |
| 7040 | |
| 1261 | 7041 stream = canonicalize_printcharfun (stream); |
| 428 | 7042 |
| 7043 for (;;) | |
| 7044 { | |
| 7045 if (!NILP (detailed) && catches && catches->backlist == backlist) | |
| 7046 { | |
| 7047 int catchpdl = catches->pdlcount; | |
| 438 | 7048 if (speccount > catchpdl |
| 7049 && specpdl[catchpdl].func == condition_case_unwind) | |
| 428 | 7050 /* This is a condition-case catchpoint */ |
| 7051 catchpdl = catchpdl + 1; | |
| 7052 | |
| 7053 backtrace_specials (speccount, catchpdl, stream); | |
| 7054 | |
| 7055 speccount = catches->pdlcount; | |
| 7056 if (catchpdl == speccount) | |
| 7057 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7058 write_ascstring (stream, " # (catch "); |
| 428 | 7059 Fprin1 (catches->tag, stream); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7060 write_ascstring (stream, " ...)\n"); |
| 428 | 7061 } |
| 7062 else | |
| 7063 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7064 write_ascstring (stream, " # (condition-case ... . "); |
| 428 | 7065 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
|
7066 write_ascstring (stream, ")\n"); |
| 428 | 7067 } |
| 7068 catches = catches->next; | |
| 7069 } | |
| 7070 else if (!backlist) | |
| 7071 break; | |
| 7072 else | |
| 7073 { | |
| 7074 if (!NILP (detailed) && backlist->pdlcount < speccount) | |
| 7075 { | |
| 7076 backtrace_specials (speccount, backlist->pdlcount, stream); | |
| 7077 speccount = backlist->pdlcount; | |
| 7078 } | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7079 write_ascstring (stream, backlist->debug_on_exit ? "* " : " "); |
| 428 | 7080 if (backlist->nargs == UNEVALLED) |
| 7081 { | |
| 1292 | 7082 Fprin1 (Fcons (*backlist->function, |
| 7083 backtrace_unevalled_args (backlist->args)), | |
| 7084 stream); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7085 write_ascstring (stream, "\n"); /* from FSFmacs 19.30 */ |
| 428 | 7086 } |
| 7087 else | |
| 7088 { | |
| 7089 Lisp_Object tem = *backlist->function; | |
| 7090 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
|
7091 write_ascstring (stream, "("); |
| 428 | 7092 if (backlist->nargs == MANY) |
| 7093 { | |
| 7094 int i; | |
| 7095 Lisp_Object tail = Qnil; | |
| 7096 struct gcpro ngcpro1; | |
| 7097 | |
| 7098 NGCPRO1 (tail); | |
| 7099 for (tail = *backlist->args, i = 0; | |
| 7100 !NILP (tail); | |
| 7101 tail = Fcdr (tail), i++) | |
| 7102 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7103 if (i != 0) write_ascstring (stream, " "); |
| 428 | 7104 Fprin1 (Fcar (tail), stream); |
| 7105 } | |
| 7106 NUNGCPRO; | |
| 7107 } | |
| 7108 else | |
| 7109 { | |
| 7110 int i; | |
| 7111 for (i = 0; i < backlist->nargs; i++) | |
| 7112 { | |
| 826 | 7113 if (!i && EQ (tem, Qbyte_code)) |
| 7114 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7115 write_ascstring (stream, "\"...\""); |
| 826 | 7116 continue; |
| 7117 } | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7118 if (i != 0) write_ascstring (stream, " "); |
| 428 | 7119 Fprin1 (backlist->args[i], stream); |
| 7120 } | |
| 7121 } | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7122 write_ascstring (stream, ")\n"); |
| 428 | 7123 } |
| 7124 backlist = backlist->next; | |
| 7125 } | |
| 7126 } | |
| 7127 Vprint_level = old_level; | |
| 7128 print_readably = old_pr; | |
| 7129 print_escape_newlines = old_nl; | |
| 7130 UNGCPRO; | |
| 7131 Vinhibit_quit = oiq; | |
| 7132 return Qnil; | |
| 7133 } | |
| 7134 | |
| 7135 | |
| 444 | 7136 DEFUN ("backtrace-frame", Fbacktrace_frame, 1, 1, 0, /* |
| 7137 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
|
7138 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
|
7139 operator), the value is (nil FUNCTION ARG-FORMS...). |
| 428 | 7140 If that frame has evaluated its arguments and called its function already, |
| 7141 the value is (t FUNCTION ARG-VALUES...). | |
| 7142 A &rest arg is represented as the tail of the list ARG-VALUES. | |
| 7143 FUNCTION is whatever was supplied as car of evaluated list, | |
| 7144 or a lambda expression for macro calls. | |
| 444 | 7145 If NFRAMES is more than the number of frames, the value is nil. |
| 428 | 7146 */ |
| 7147 (nframes)) | |
| 7148 { | |
| 7149 REGISTER struct backtrace *backlist = backtrace_list; | |
| 7150 REGISTER int i; | |
| 7151 Lisp_Object tem; | |
| 7152 | |
| 7153 CHECK_NATNUM (nframes); | |
| 7154 | |
| 7155 /* Find the frame requested. */ | |
| 7156 for (i = XINT (nframes); backlist && (i-- > 0);) | |
| 7157 backlist = backlist->next; | |
| 7158 | |
| 7159 if (!backlist) | |
| 7160 return Qnil; | |
| 7161 if (backlist->nargs == UNEVALLED) | |
| 1292 | 7162 return Fcons (Qnil, Fcons (*backlist->function, |
| 7163 backtrace_unevalled_args (backlist->args))); | |
| 428 | 7164 else |
| 7165 { | |
| 7166 if (backlist->nargs == MANY) | |
| 7167 tem = *backlist->args; | |
| 7168 else | |
| 7169 tem = Flist (backlist->nargs, backlist->args); | |
| 7170 | |
| 7171 return Fcons (Qt, Fcons (*backlist->function, tem)); | |
| 7172 } | |
| 7173 } | |
| 7174 | |
| 7175 | |
| 7176 /************************************************************************/ | |
| 7177 /* Warnings */ | |
| 7178 /************************************************************************/ | |
| 7179 | |
| 1123 | 7180 static int |
| 7181 warning_will_be_discarded (Lisp_Object level) | |
| 7182 { | |
| 7183 /* Don't even generate debug warnings if they're going to be discarded, | |
| 7184 to avoid excessive consing. */ | |
| 7185 return (EQ (level, Qdebug) && !NILP (Vlog_warning_minimum_level) && | |
| 7186 !EQ (Vlog_warning_minimum_level, Qdebug)); | |
| 7187 } | |
| 7188 | |
| 428 | 7189 void |
| 1204 | 7190 warn_when_safe_lispobj (Lisp_Object class_, Lisp_Object level, |
| 428 | 7191 Lisp_Object obj) |
| 7192 { | |
| 1123 | 7193 if (warning_will_be_discarded (level)) |
| 793 | 7194 return; |
| 1123 | 7195 |
| 1204 | 7196 obj = list1 (list3 (class_, level, obj)); |
| 428 | 7197 if (NILP (Vpending_warnings)) |
| 7198 Vpending_warnings = Vpending_warnings_tail = obj; | |
| 7199 else | |
| 7200 { | |
| 7201 Fsetcdr (Vpending_warnings_tail, obj); | |
| 7202 Vpending_warnings_tail = obj; | |
| 7203 } | |
| 7204 } | |
| 7205 | |
| 7206 /* #### This should probably accept Lisp objects; but then we have | |
| 7207 to make sure that Feval() isn't called, since it might not be safe. | |
| 7208 | |
| 7209 An alternative approach is to just pass some non-string type of | |
| 7210 Lisp_Object to warn_when_safe_lispobj(); `prin1-to-string' will | |
| 7211 automatically be called when it is safe to do so. */ | |
| 7212 | |
| 7213 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7214 warn_when_safe (Lisp_Object class_, Lisp_Object level, const Ascbyte *fmt, ...) |
| 428 | 7215 { |
| 7216 Lisp_Object obj; | |
| 7217 va_list args; | |
| 7218 | |
| 1123 | 7219 if (warning_will_be_discarded (level)) |
| 793 | 7220 return; |
| 1123 | 7221 |
| 428 | 7222 va_start (args, fmt); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7223 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 428 | 7224 va_end (args); |
| 7225 | |
| 1204 | 7226 warn_when_safe_lispobj (class_, level, obj); |
| 428 | 7227 } |
| 7228 | |
| 7229 | |
| 7230 | |
| 7231 | |
| 7232 /************************************************************************/ | |
| 7233 /* Initialization */ | |
| 7234 /************************************************************************/ | |
| 7235 | |
| 7236 void | |
| 7237 syms_of_eval (void) | |
| 7238 { | |
| 442 | 7239 INIT_LRECORD_IMPLEMENTATION (subr); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7240 INIT_LRECORD_IMPLEMENTATION (multiple_value); |
| 442 | 7241 |
| 563 | 7242 DEFSYMBOL (Qinhibit_quit); |
| 7243 DEFSYMBOL (Qautoload); | |
| 7244 DEFSYMBOL (Qdebug_on_error); | |
| 7245 DEFSYMBOL (Qstack_trace_on_error); | |
| 7246 DEFSYMBOL (Qdebug_on_signal); | |
| 7247 DEFSYMBOL (Qstack_trace_on_signal); | |
| 7248 DEFSYMBOL (Qdebugger); | |
| 7249 DEFSYMBOL (Qmacro); | |
| 428 | 7250 defsymbol (&Qand_rest, "&rest"); |
| 7251 defsymbol (&Qand_optional, "&optional"); | |
| 7252 /* Note that the process code also uses Qexit */ | |
| 563 | 7253 DEFSYMBOL (Qexit); |
| 7254 DEFSYMBOL (Qsetq); | |
| 7255 DEFSYMBOL (Qinteractive); | |
| 7256 DEFSYMBOL (Qcommandp); | |
| 7257 DEFSYMBOL (Qdefun); | |
| 7258 DEFSYMBOL (Qprogn); | |
| 7259 DEFSYMBOL (Qvalues); | |
| 7260 DEFSYMBOL (Qdisplay_warning); | |
| 7261 DEFSYMBOL (Qrun_hooks); | |
| 887 | 7262 DEFSYMBOL (Qfinalize_list); |
| 563 | 7263 DEFSYMBOL (Qif); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7264 DEFSYMBOL (Qthrow); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7265 DEFSYMBOL (Qobsolete_throw); |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
7266 DEFSYMBOL (Qmultiple_value_list_internal); |
| 428 | 7267 |
| 7268 DEFSUBR (For); | |
| 7269 DEFSUBR (Fand); | |
| 7270 DEFSUBR (Fif); | |
| 7271 DEFSUBR_MACRO (Fwhen); | |
| 7272 DEFSUBR_MACRO (Funless); | |
| 7273 DEFSUBR (Fcond); | |
| 7274 DEFSUBR (Fprogn); | |
| 7275 DEFSUBR (Fprog1); | |
| 7276 DEFSUBR (Fprog2); | |
| 7277 DEFSUBR (Fsetq); | |
| 7278 DEFSUBR (Fquote); | |
|
4744
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
7279 DEFSUBR (Fquote_maybe); |
| 428 | 7280 DEFSUBR (Ffunction); |
| 7281 DEFSUBR (Fdefun); | |
| 7282 DEFSUBR (Fdefmacro); | |
| 7283 DEFSUBR (Fdefvar); | |
| 7284 DEFSUBR (Fdefconst); | |
| 7285 DEFSUBR (Flet); | |
| 7286 DEFSUBR (FletX); | |
| 7287 DEFSUBR (Fwhile); | |
| 7288 DEFSUBR (Fmacroexpand_internal); | |
| 7289 DEFSUBR (Fcatch); | |
| 7290 DEFSUBR (Fthrow); | |
| 7291 DEFSUBR (Funwind_protect); | |
| 7292 DEFSUBR (Fcondition_case); | |
| 7293 DEFSUBR (Fcall_with_condition_handler); | |
| 7294 DEFSUBR (Fsignal); | |
| 7295 DEFSUBR (Finteractive_p); | |
| 7296 DEFSUBR (Fcommandp); | |
| 7297 DEFSUBR (Fcommand_execute); | |
| 7298 DEFSUBR (Fautoload); | |
| 7299 DEFSUBR (Feval); | |
| 7300 DEFSUBR (Fapply); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7301 DEFSUBR (Fmultiple_value_call); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7302 DEFSUBR (Fmultiple_value_list_internal); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7303 DEFSUBR (Fmultiple_value_prog1); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7304 DEFSUBR (Fvalues); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7305 DEFSUBR (Fvalues_list); |
| 428 | 7306 DEFSUBR (Ffuncall); |
| 7307 DEFSUBR (Ffunctionp); | |
| 7308 DEFSUBR (Ffunction_min_args); | |
| 7309 DEFSUBR (Ffunction_max_args); | |
| 7310 DEFSUBR (Frun_hooks); | |
| 7311 DEFSUBR (Frun_hook_with_args); | |
| 7312 DEFSUBR (Frun_hook_with_args_until_success); | |
| 7313 DEFSUBR (Frun_hook_with_args_until_failure); | |
| 7314 DEFSUBR (Fbacktrace_debug); | |
| 7315 DEFSUBR (Fbacktrace); | |
| 7316 DEFSUBR (Fbacktrace_frame); | |
| 7317 } | |
| 7318 | |
| 7319 void | |
| 814 | 7320 init_eval_semi_early (void) |
| 428 | 7321 { |
| 7322 specpdl_ptr = specpdl; | |
| 7323 specpdl_depth_counter = 0; | |
| 7324 catchlist = 0; | |
| 7325 Vcondition_handlers = Qnil; | |
| 7326 backtrace_list = 0; | |
| 7327 Vquit_flag = Qnil; | |
| 7328 debug_on_next_call = 0; | |
| 7329 lisp_eval_depth = 0; | |
| 7330 entering_debugger = 0; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7331 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7332 first_desired_multiple_value = 0; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7333 multiple_value_current_limit = 1; |
| 428 | 7334 } |
| 7335 | |
| 7336 void | |
| 7337 reinit_vars_of_eval (void) | |
| 7338 { | |
| 7339 preparing_for_armageddon = 0; | |
| 7340 in_warnings = 0; | |
| 7341 specpdl_size = 50; | |
| 7342 specpdl = xnew_array (struct specbinding, specpdl_size); | |
| 7343 /* XEmacs change: increase these values. */ | |
| 7344 max_specpdl_size = 3000; | |
| 442 | 7345 max_lisp_eval_depth = 1000; |
| 7346 #ifdef DEFEND_AGAINST_THROW_RECURSION | |
| 428 | 7347 throw_level = 0; |
| 7348 #endif | |
| 2367 | 7349 init_eval_semi_early (); |
| 428 | 7350 } |
| 7351 | |
| 7352 void | |
| 7353 vars_of_eval (void) | |
| 7354 { | |
| 7355 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size /* | |
| 7356 Limit on number of Lisp variable bindings & unwind-protects before error. | |
| 7357 */ ); | |
| 7358 | |
| 7359 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth /* | |
| 7360 Limit on depth in `eval', `apply' and `funcall' before error. | |
| 7361 This limit is to catch infinite recursions for you before they cause | |
| 7362 actual stack overflow in C, which would be fatal for Emacs. | |
| 7363 You can safely make it considerably larger than its default value, | |
| 7364 if that proves inconveniently small. | |
| 7365 */ ); | |
| 7366 | |
| 7367 DEFVAR_LISP ("quit-flag", &Vquit_flag /* | |
| 853 | 7368 t causes running Lisp code to abort, unless `inhibit-quit' is non-nil. |
| 7369 `critical' causes running Lisp code to abort regardless of `inhibit-quit'. | |
| 7370 Normally, you do not need to set this value yourself. It is set to | |
| 7371 t each time a Control-G is detected, and to `critical' each time a | |
| 7372 Shift-Control-G is detected. The XEmacs core C code is littered with | |
| 7373 calls to the QUIT; macro, which check the values of `quit-flag' and | |
| 2500 | 7374 `inhibit-quit' and ABORT (or more accurately, call (signal 'quit)) if |
| 853 | 7375 it's correct to do so. |
| 428 | 7376 */ ); |
| 7377 Vquit_flag = Qnil; | |
| 7378 | |
| 7379 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit /* | |
| 7380 Non-nil inhibits C-g quitting from happening immediately. | |
| 7381 Note that `quit-flag' will still be set by typing C-g, | |
| 7382 so a quit will be signalled as soon as `inhibit-quit' is nil. | |
| 7383 To prevent this happening, set `quit-flag' to nil | |
| 853 | 7384 before making `inhibit-quit' nil. |
| 7385 | |
| 7386 The value of `inhibit-quit' is ignored if a critical quit is | |
| 7387 requested by typing control-shift-G in a window-system frame; | |
| 7388 this is explained in more detail in `quit-flag'. | |
| 428 | 7389 */ ); |
| 7390 Vinhibit_quit = Qnil; | |
| 7391 | |
| 7392 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error /* | |
| 7393 *Non-nil means automatically display a backtrace buffer | |
| 7394 after any error that is not handled by a `condition-case'. | |
| 7395 If the value is a list, an error only means to display a backtrace | |
| 7396 if one of its condition symbols appears in the list. | |
| 7397 See also variable `stack-trace-on-signal'. | |
| 7398 */ ); | |
| 7399 Vstack_trace_on_error = Qnil; | |
| 7400 | |
| 7401 DEFVAR_LISP ("stack-trace-on-signal", &Vstack_trace_on_signal /* | |
| 7402 *Non-nil means automatically display a backtrace buffer | |
| 7403 after any error that is signalled, whether or not it is handled by | |
| 7404 a `condition-case'. | |
| 7405 If the value is a list, an error only means to display a backtrace | |
| 7406 if one of its condition symbols appears in the list. | |
| 7407 See also variable `stack-trace-on-error'. | |
| 7408 */ ); | |
| 7409 Vstack_trace_on_signal = Qnil; | |
| 7410 | |
| 7411 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors /* | |
| 7412 *List of errors for which the debugger should not be called. | |
| 7413 Each element may be a condition-name or a regexp that matches error messages. | |
| 7414 If any element applies to a given error, that error skips the debugger | |
| 7415 and just returns to top level. | |
| 7416 This overrides the variable `debug-on-error'. | |
| 7417 It does not apply to errors handled by `condition-case'. | |
| 7418 */ ); | |
| 7419 Vdebug_ignored_errors = Qnil; | |
| 7420 | |
| 7421 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error /* | |
| 7422 *Non-nil means enter debugger if an unhandled error is signalled. | |
| 7423 The debugger will not be entered if the error is handled by | |
| 7424 a `condition-case'. | |
| 7425 If the value is a list, an error only means to enter the debugger | |
| 7426 if one of its condition symbols appears in the list. | |
| 7427 This variable is overridden by `debug-ignored-errors'. | |
| 7428 See also variables `debug-on-quit' and `debug-on-signal'. | |
| 1123 | 7429 |
|
4657
f8d7d8202635
imported patch accept-process-output-docstring
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4642
diff
changeset
|
7430 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
|
7431 (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
|
7432 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
|
7433 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
|
7434 |
| 1123 | 7435 If this variable is set while XEmacs is running noninteractively (using |
| 7436 `-batch'), and XEmacs was configured with `--debug' (#define XEMACS_DEBUG | |
| 7437 in the C code), instead of trying to invoke the Lisp debugger (which | |
| 7438 obviously won't work), XEmacs will break out to a C debugger using | |
| 7439 \(force-debugging-signal t). This is useful because debugging | |
| 7440 noninteractive runs of XEmacs is often very difficult, since they typically | |
| 7441 happen as part of sometimes large and complex make suites (e.g. rebuilding | |
| 2500 | 7442 the XEmacs packages). NOTE: This runs ABORT()!!! (As well as and after |
| 1123 | 7443 executing INT 3 under MS Windows, which should invoke a debugger if it's |
| 7444 active.) This is guaranteed to kill XEmacs! (But in this situation, XEmacs | |
| 7445 is about to die anyway, and if no debugger is present, this will usefully | |
| 7446 dump core.) The most useful way to set this flag when debugging | |
| 7447 noninteractive runs, especially in makefiles, is using the environment | |
| 7448 variable XEMACSDEBUG, like this: | |
| 771 | 7449 |
| 7450 \(using csh) setenv XEMACSDEBUG '(setq debug-on-error t)' | |
| 7451 \(using bash) export XEMACSDEBUG='(setq debug-on-error t)' | |
| 428 | 7452 */ ); |
| 7453 Vdebug_on_error = Qnil; | |
| 7454 | |
| 7455 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal /* | |
| 7456 *Non-nil means enter debugger if an error is signalled. | |
| 7457 The debugger will be entered whether or not the error is handled by | |
| 7458 a `condition-case'. | |
| 7459 If the value is a list, an error only means to enter the debugger | |
| 7460 if one of its condition symbols appears in the list. | |
| 7461 See also variable `debug-on-quit'. | |
| 1123 | 7462 |
| 7463 This will attempt to enter a C debugger when XEmacs is run noninteractively | |
| 7464 and under the same conditions as described in `debug-on-error'. | |
| 428 | 7465 */ ); |
| 7466 Vdebug_on_signal = Qnil; | |
| 7467 | |
| 7468 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit /* | |
| 7469 *Non-nil means enter debugger if quit is signalled (C-G, for example). | |
| 7470 Does not apply if quit is handled by a `condition-case'. Entering the | |
| 7471 debugger can also be achieved at any time (for X11 console) by typing | |
| 7472 control-shift-G to signal a critical quit. | |
| 7473 */ ); | |
| 7474 debug_on_quit = 0; | |
| 7475 | |
| 7476 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call /* | |
| 7477 Non-nil means enter debugger before next `eval', `apply' or `funcall'. | |
| 7478 */ ); | |
| 7479 | |
| 1292 | 7480 DEFVAR_BOOL ("backtrace-with-interal-sections", |
| 7481 &backtrace_with_internal_sections /* | |
| 7482 Non-nil means backtraces will contain additional information indicating | |
| 7483 when particular sections of the C code have been entered, e.g. redisplay(), | |
| 7484 byte-char conversion, internal-external conversion, etc. This can be | |
| 7485 particularly useful when XEmacs crashes, in helping to pinpoint the problem. | |
| 7486 */ ); | |
| 7487 #ifdef ERROR_CHECK_STRUCTURES | |
| 7488 backtrace_with_internal_sections = 1; | |
| 7489 #else | |
| 7490 backtrace_with_internal_sections = 0; | |
| 7491 #endif | |
| 7492 | |
| 428 | 7493 DEFVAR_LISP ("debugger", &Vdebugger /* |
| 7494 Function to call to invoke debugger. | |
| 7495 If due to frame exit, args are `exit' and the value being returned; | |
| 7496 this function's value will be returned instead of that. | |
| 7497 If due to error, args are `error' and a list of the args to `signal'. | |
| 7498 If due to `apply' or `funcall' entry, one arg, `lambda'. | |
| 7499 If due to `eval' entry, one arg, t. | |
| 7500 */ ); | |
| 7501 Vdebugger = Qnil; | |
| 7502 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7503 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
|
7504 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
|
7505 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7506 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
|
7507 macros and special operators. |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7508 */); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7509 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
|
7510 |
| 853 | 7511 staticpro (&Vcatch_everything_tag); |
| 7512 Vcatch_everything_tag = make_opaque (OPAQUE_CLEAR, 0); | |
| 7513 | |
| 428 | 7514 staticpro (&Vpending_warnings); |
| 7515 Vpending_warnings = Qnil; | |
| 1204 | 7516 dump_add_root_lisp_object (&Vpending_warnings_tail); |
| 428 | 7517 Vpending_warnings_tail = Qnil; |
| 7518 | |
| 793 | 7519 DEFVAR_LISP ("log-warning-minimum-level", &Vlog_warning_minimum_level); |
| 7520 Vlog_warning_minimum_level = Qinfo; | |
| 7521 | |
| 428 | 7522 staticpro (&Vautoload_queue); |
| 7523 Vautoload_queue = Qnil; | |
| 7524 | |
| 7525 staticpro (&Vcondition_handlers); | |
| 7526 | |
| 853 | 7527 staticpro (&Vdeletable_permanent_display_objects); |
| 7528 Vdeletable_permanent_display_objects = Qnil; | |
| 7529 | |
| 7530 staticpro (&Vmodifiable_buffers); | |
| 7531 Vmodifiable_buffers = Qnil; | |
| 7532 | |
| 7533 inhibit_flags = 0; | |
| 7534 } |