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