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