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