Mercurial > hg > xemacs-beta
annotate src/eval.c @ 5127:a9c41067dd88 ben-lisp-object
more cleanups, terminology clarification, lots of doc work
-------------------- ChangeLog entries follow: --------------------
man/ChangeLog addition:
2010-03-05 Ben Wing <ben@xemacs.org>
* internals/internals.texi (Introduction to Allocation):
* internals/internals.texi (Integers and Characters):
* internals/internals.texi (Allocation from Frob Blocks):
* internals/internals.texi (lrecords):
* internals/internals.texi (Low-level allocation):
Rewrite section on allocation of Lisp objects to reflect the new
reality. Remove references to nonexistent XSETINT and XSETCHAR.
modules/ChangeLog addition:
2010-03-05 Ben Wing <ben@xemacs.org>
* postgresql/postgresql.c (allocate_pgconn):
* postgresql/postgresql.c (allocate_pgresult):
* postgresql/postgresql.h (struct Lisp_PGconn):
* postgresql/postgresql.h (struct Lisp_PGresult):
* ldap/eldap.c (allocate_ldap):
* ldap/eldap.h (struct Lisp_LDAP):
Same changes as in src/ dir. See large log there in ChangeLog,
but basically:
ALLOC_LISP_OBJECT -> ALLOC_NORMAL_LISP_OBJECT
LISP_OBJECT_HEADER -> NORMAL_LISP_OBJECT_HEADER
../hlo/src/ChangeLog addition:
2010-03-05 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (old_alloc_sized_lcrecord):
* alloc.c (very_old_free_lcrecord):
* alloc.c (copy_lisp_object):
* alloc.c (zero_sized_lisp_object):
* alloc.c (zero_nonsized_lisp_object):
* alloc.c (lisp_object_storage_size):
* alloc.c (free_normal_lisp_object):
* alloc.c (FREE_FIXED_TYPE_WHEN_NOT_IN_GC):
* alloc.c (ALLOC_FROB_BLOCK_LISP_OBJECT):
* alloc.c (Fcons):
* alloc.c (noseeum_cons):
* alloc.c (make_float):
* alloc.c (make_bignum):
* alloc.c (make_bignum_bg):
* alloc.c (make_ratio):
* alloc.c (make_ratio_bg):
* alloc.c (make_ratio_rt):
* alloc.c (make_bigfloat):
* alloc.c (make_bigfloat_bf):
* alloc.c (size_vector):
* alloc.c (make_compiled_function):
* alloc.c (Fmake_symbol):
* alloc.c (allocate_extent):
* alloc.c (allocate_event):
* alloc.c (make_key_data):
* alloc.c (make_button_data):
* alloc.c (make_motion_data):
* alloc.c (make_process_data):
* alloc.c (make_timeout_data):
* alloc.c (make_magic_data):
* alloc.c (make_magic_eval_data):
* alloc.c (make_eval_data):
* alloc.c (make_misc_user_data):
* alloc.c (Fmake_marker):
* alloc.c (noseeum_make_marker):
* alloc.c (size_string_direct_data):
* alloc.c (make_uninit_string):
* alloc.c (make_string_nocopy):
* alloc.c (mark_lcrecord_list):
* alloc.c (alloc_managed_lcrecord):
* alloc.c (free_managed_lcrecord):
* alloc.c (sweep_lcrecords_1):
* alloc.c (malloced_storage_size):
* buffer.c (allocate_buffer):
* buffer.c (compute_buffer_usage):
* buffer.c (DEFVAR_BUFFER_LOCAL_1):
* buffer.c (nuke_all_buffer_slots):
* buffer.c (common_init_complex_vars_of_buffer):
* buffer.h (struct buffer_text):
* buffer.h (struct buffer):
* bytecode.c:
* bytecode.c (make_compiled_function_args):
* bytecode.c (size_compiled_function_args):
* bytecode.h (struct compiled_function_args):
* casetab.c (allocate_case_table):
* casetab.h (struct Lisp_Case_Table):
* charset.h (struct Lisp_Charset):
* chartab.c (fill_char_table):
* chartab.c (Fmake_char_table):
* chartab.c (make_char_table_entry):
* chartab.c (copy_char_table_entry):
* chartab.c (Fcopy_char_table):
* chartab.c (put_char_table):
* chartab.h (struct Lisp_Char_Table_Entry):
* chartab.h (struct Lisp_Char_Table):
* console-gtk-impl.h (struct gtk_device):
* console-gtk-impl.h (struct gtk_frame):
* console-impl.h (struct console):
* console-msw-impl.h (struct Lisp_Devmode):
* console-msw-impl.h (struct mswindows_device):
* console-msw-impl.h (struct msprinter_device):
* console-msw-impl.h (struct mswindows_frame):
* console-msw-impl.h (struct mswindows_dialog_id):
* console-stream-impl.h (struct stream_console):
* console-stream.c (stream_init_console):
* console-tty-impl.h (struct tty_console):
* console-tty-impl.h (struct tty_device):
* console-tty.c (allocate_tty_console_struct):
* console-x-impl.h (struct x_device):
* console-x-impl.h (struct x_frame):
* console.c (allocate_console):
* console.c (nuke_all_console_slots):
* console.c (DEFVAR_CONSOLE_LOCAL_1):
* console.c (common_init_complex_vars_of_console):
* data.c (make_weak_list):
* data.c (make_weak_box):
* data.c (make_ephemeron):
* database.c:
* database.c (struct Lisp_Database):
* database.c (allocate_database):
* database.c (finalize_database):
* device-gtk.c (allocate_gtk_device_struct):
* device-impl.h (struct device):
* device-msw.c:
* device-msw.c (mswindows_init_device):
* device-msw.c (msprinter_init_device):
* device-msw.c (finalize_devmode):
* device-msw.c (allocate_devmode):
* device-tty.c (allocate_tty_device_struct):
* device-x.c (allocate_x_device_struct):
* device.c:
* device.c (nuke_all_device_slots):
* device.c (allocate_device):
* dialog-msw.c (handle_question_dialog_box):
* elhash.c:
* elhash.c (struct Lisp_Hash_Table):
* elhash.c (finalize_hash_table):
* elhash.c (make_general_lisp_hash_table):
* elhash.c (Fcopy_hash_table):
* elhash.h (htentry):
* emacs.c (main_1):
* eval.c:
* eval.c (size_multiple_value):
* event-stream.c (finalize_command_builder):
* event-stream.c (allocate_command_builder):
* event-stream.c (free_command_builder):
* event-stream.c (event_stream_generate_wakeup):
* event-stream.c (event_stream_resignal_wakeup):
* event-stream.c (event_stream_disable_wakeup):
* event-stream.c (event_stream_wakeup_pending_p):
* events.h (struct Lisp_Timeout):
* events.h (struct command_builder):
* extents-impl.h:
* extents-impl.h (struct extent_auxiliary):
* extents-impl.h (struct extent_info):
* extents-impl.h (set_extent_no_chase_aux_field):
* extents-impl.h (set_extent_no_chase_normal_field):
* extents.c:
* extents.c (gap_array_marker):
* extents.c (gap_array):
* extents.c (extent_list_marker):
* extents.c (extent_list):
* extents.c (stack_of_extents):
* extents.c (gap_array_make_marker):
* extents.c (extent_list_make_marker):
* extents.c (allocate_extent_list):
* extents.c (SLOT):
* extents.c (mark_extent_auxiliary):
* extents.c (allocate_extent_auxiliary):
* extents.c (attach_extent_auxiliary):
* extents.c (size_gap_array):
* extents.c (finalize_extent_info):
* extents.c (allocate_extent_info):
* extents.c (uninit_buffer_extents):
* extents.c (allocate_soe):
* extents.c (copy_extent):
* extents.c (vars_of_extents):
* extents.h:
* faces.c (allocate_face):
* faces.h (struct Lisp_Face):
* faces.h (struct face_cachel):
* file-coding.c:
* file-coding.c (finalize_coding_system):
* file-coding.c (sizeof_coding_system):
* file-coding.c (Fcopy_coding_system):
* file-coding.h (struct Lisp_Coding_System):
* file-coding.h (MARKED_SLOT):
* fns.c (size_bit_vector):
* font-mgr.c:
* font-mgr.c (finalize_fc_pattern):
* font-mgr.c (print_fc_pattern):
* font-mgr.c (Ffc_pattern_p):
* font-mgr.c (Ffc_pattern_create):
* font-mgr.c (Ffc_name_parse):
* font-mgr.c (Ffc_name_unparse):
* font-mgr.c (Ffc_pattern_duplicate):
* font-mgr.c (Ffc_pattern_add):
* font-mgr.c (Ffc_pattern_del):
* font-mgr.c (Ffc_pattern_get):
* font-mgr.c (fc_config_create_using):
* font-mgr.c (fc_strlist_to_lisp_using):
* font-mgr.c (fontset_to_list):
* font-mgr.c (Ffc_config_p):
* font-mgr.c (Ffc_config_up_to_date):
* font-mgr.c (Ffc_config_build_fonts):
* font-mgr.c (Ffc_config_get_cache):
* font-mgr.c (Ffc_config_get_fonts):
* font-mgr.c (Ffc_config_set_current):
* font-mgr.c (Ffc_config_get_blanks):
* font-mgr.c (Ffc_config_get_rescan_interval):
* font-mgr.c (Ffc_config_set_rescan_interval):
* font-mgr.c (Ffc_config_app_font_add_file):
* font-mgr.c (Ffc_config_app_font_add_dir):
* font-mgr.c (Ffc_config_app_font_clear):
* font-mgr.c (size):
* font-mgr.c (Ffc_config_substitute):
* font-mgr.c (Ffc_font_render_prepare):
* font-mgr.c (Ffc_font_match):
* font-mgr.c (Ffc_font_sort):
* font-mgr.c (finalize_fc_config):
* font-mgr.c (print_fc_config):
* font-mgr.h:
* font-mgr.h (struct fc_pattern):
* font-mgr.h (XFC_PATTERN):
* font-mgr.h (struct fc_config):
* font-mgr.h (XFC_CONFIG):
* frame-gtk.c (allocate_gtk_frame_struct):
* frame-impl.h (struct frame):
* frame-msw.c (mswindows_init_frame_1):
* frame-x.c (allocate_x_frame_struct):
* frame.c (nuke_all_frame_slots):
* frame.c (allocate_frame_core):
* gc.c:
* gc.c (GC_CHECK_NOT_FREE):
* glyphs.c (finalize_image_instance):
* glyphs.c (allocate_image_instance):
* glyphs.c (Fcolorize_image_instance):
* glyphs.c (allocate_glyph):
* glyphs.c (unmap_subwindow_instance_cache_mapper):
* glyphs.c (register_ignored_expose):
* glyphs.h (struct Lisp_Image_Instance):
* glyphs.h (struct Lisp_Glyph):
* glyphs.h (struct glyph_cachel):
* glyphs.h (struct expose_ignore):
* gui.c (allocate_gui_item):
* gui.h (struct Lisp_Gui_Item):
* keymap.c (struct Lisp_Keymap):
* keymap.c (make_keymap):
* lisp.h:
* lisp.h (struct Lisp_String_Direct_Data):
* lisp.h (struct Lisp_String_Indirect_Data):
* lisp.h (struct Lisp_Vector):
* lisp.h (struct Lisp_Bit_Vector):
* lisp.h (DECLARE_INLINE_LISP_BIT_VECTOR):
* lisp.h (struct weak_box):
* lisp.h (struct ephemeron):
* lisp.h (struct weak_list):
* lrecord.h:
* lrecord.h (struct lrecord_implementation):
* lrecord.h (MC_ALLOC_CALL_FINALIZER):
* lrecord.h (struct lcrecord_list):
* lstream.c (finalize_lstream):
* lstream.c (sizeof_lstream):
* lstream.c (Lstream_new):
* lstream.c (Lstream_delete):
* lstream.h (struct lstream):
* marker.c:
* marker.c (finalize_marker):
* marker.c (compute_buffer_marker_usage):
* mule-charset.c:
* mule-charset.c (make_charset):
* mule-charset.c (compute_charset_usage):
* objects-impl.h (struct Lisp_Color_Instance):
* objects-impl.h (struct Lisp_Font_Instance):
* objects-tty-impl.h (struct tty_color_instance_data):
* objects-tty-impl.h (struct tty_font_instance_data):
* objects-tty.c (tty_initialize_color_instance):
* objects-tty.c (tty_initialize_font_instance):
* objects.c (finalize_color_instance):
* objects.c (Fmake_color_instance):
* objects.c (finalize_font_instance):
* objects.c (Fmake_font_instance):
* objects.c (reinit_vars_of_objects):
* opaque.c:
* opaque.c (sizeof_opaque):
* opaque.c (make_opaque_ptr):
* opaque.c (free_opaque_ptr):
* opaque.h:
* opaque.h (Lisp_Opaque):
* opaque.h (Lisp_Opaque_Ptr):
* print.c (printing_unreadable_lcrecord):
* print.c (external_object_printer):
* print.c (debug_p4):
* process.c (finalize_process):
* process.c (make_process_internal):
* procimpl.h (struct Lisp_Process):
* rangetab.c (Fmake_range_table):
* rangetab.c (Fcopy_range_table):
* rangetab.h (struct Lisp_Range_Table):
* scrollbar.c:
* scrollbar.c (create_scrollbar_instance):
* scrollbar.c (compute_scrollbar_instance_usage):
* scrollbar.h (struct scrollbar_instance):
* specifier.c (finalize_specifier):
* specifier.c (sizeof_specifier):
* specifier.c (set_specifier_caching):
* specifier.h (struct Lisp_Specifier):
* specifier.h (struct specifier_caching):
* symeval.h:
* symeval.h (SYMBOL_VALUE_MAGIC_P):
* symeval.h (DEFVAR_SYMVAL_FWD):
* symsinit.h:
* syntax.c (init_buffer_syntax_cache):
* syntax.h (struct syntax_cache):
* toolbar.c:
* toolbar.c (allocate_toolbar_button):
* toolbar.c (update_toolbar_button):
* toolbar.h (struct toolbar_button):
* tooltalk.c (struct Lisp_Tooltalk_Message):
* tooltalk.c (make_tooltalk_message):
* tooltalk.c (struct Lisp_Tooltalk_Pattern):
* tooltalk.c (make_tooltalk_pattern):
* ui-gtk.c:
* ui-gtk.c (allocate_ffi_data):
* ui-gtk.c (emacs_gtk_object_finalizer):
* ui-gtk.c (allocate_emacs_gtk_object_data):
* ui-gtk.c (allocate_emacs_gtk_boxed_data):
* ui-gtk.h:
* window-impl.h (struct window):
* window-impl.h (struct window_mirror):
* window.c (finalize_window):
* window.c (allocate_window):
* window.c (new_window_mirror):
* window.c (mark_window_as_deleted):
* window.c (make_dummy_parent):
* window.c (compute_window_mirror_usage):
* window.c (compute_window_usage):
Overall point of this change and previous ones in this repository:
(1) Introduce new, clearer terminology: everything other than int
or char is a "record" object, which comes in two types: "normal
objects" and "frob-block objects". Fix up all places that
referred to frob-block objects as "simple", "basic", etc.
(2) Provide an advertised interface for doing operations on Lisp
objects, including creating new types, that is clean and
consistent in its naming, uses the above-referenced terms and
avoids referencing "lrecords", "old lcrecords", etc., which should
hide under the surface.
(3) Make the size_in_bytes and finalizer methods take a
Lisp_Object rather than a void * for consistency with other methods.
(4) Separate finalizer method into finalizer and disksaver, so
that normal finalize methods don't have to worry about disksaving.
Other specifics:
(1) Renaming:
LISP_OBJECT_HEADER -> NORMAL_LISP_OBJECT_HEADER
ALLOC_LISP_OBJECT -> ALLOC_NORMAL_LISP_OBJECT
implementation->basic_p -> implementation->frob_block_p
ALLOCATE_FIXED_TYPE_AND_SET_IMPL -> ALLOC_FROB_BLOCK_LISP_OBJECT
*FCCONFIG*, wrap_fcconfig -> *FC_CONFIG*, wrap_fc_config
*FCPATTERN*, wrap_fcpattern -> *FC_PATTERN*, wrap_fc_pattern
(the last two changes make the naming of these macros consistent
with the naming of all other macros, since the objects are named
fc-config and fc-pattern with a hyphen)
(2) Lots of documentation fixes in lrecord.h.
(3) Eliminate macros for copying, freeing, zeroing objects, getting
their storage size. Instead, new functions:
zero_sized_lisp_object()
zero_nonsized_lisp_object()
lisp_object_storage_size()
free_normal_lisp_object()
(copy_lisp_object() already exists)
LISP_OBJECT_FROB_BLOCK_P() (actually a macro)
Eliminated:
free_lrecord()
zero_lrecord()
copy_lrecord()
copy_sized_lrecord()
old_copy_lcrecord()
old_copy_sized_lcrecord()
old_zero_lcrecord()
old_zero_sized_lcrecord()
LISP_OBJECT_STORAGE_SIZE()
COPY_SIZED_LISP_OBJECT()
COPY_SIZED_LCRECORD()
COPY_LISP_OBJECT()
ZERO_LISP_OBJECT()
FREE_LISP_OBJECT()
(4) Catch the remaining places where lrecord stuff was used directly
and use the advertised interface, e.g. alloc_sized_lrecord() ->
ALLOC_SIZED_LISP_OBJECT().
(5) Make certain statically-declared pseudo-objects
(buffer_local_flags, console_local_flags) have their lheader
initialized correctly, so things like copy_lisp_object() can work
on them. Make extent_auxiliary_defaults a proper heap object
Vextent_auxiliary_defaults, and make extent auxiliaries dumpable
so that this object can be dumped. allocate_extent_auxiliary()
now just creates the object, and attach_extent_auxiliary()
creates an extent auxiliary and attaches to an extent, like the
old allocate_extent_auxiliary().
(6) Create EXTENT_AUXILIARY_SLOTS macro, similar to the foo-slots.h
files but in a macro instead of a file. The purpose is to avoid
duplication when iterating over all the slots in an extent auxiliary.
Use it.
(7) In lstream.c, don't zero out object after allocation because
allocation routines take care of this.
(8) In marker.c, fix a mistake in computing marker overhead.
(9) In print.c, clean up printing_unreadable_lcrecord(),
external_object_printer() to avoid lots of ifdef NEW_GC's.
(10) Separate toolbar-button allocation into a separate
allocate_toolbar_button() function for use in the example code
in lrecord.h.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Fri, 05 Mar 2010 04:08:17 -0600 |
| parents | 2a462149bd6a |
| children | 7be849cb8828 |
| rev | line source |
|---|---|
| 428 | 1 /* Evaluator for XEmacs Lisp interpreter. |
| 2 Copyright (C) 1985-1987, 1992-1994 Free Software Foundation, Inc. | |
| 3 Copyright (C) 1995 Sun Microsystems, Inc. | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
4 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2010 Ben Wing. |
| 428 | 5 |
| 6 This file is part of XEmacs. | |
| 7 | |
| 8 XEmacs is free software; you can redistribute it and/or modify it | |
| 9 under the terms of the GNU General Public License as published by the | |
| 10 Free Software Foundation; either version 2, or (at your option) any | |
| 11 later version. | |
| 12 | |
| 13 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 16 for more details. | |
| 17 | |
| 18 You should have received a copy of the GNU General Public License | |
| 19 along with XEmacs; see the file COPYING. If not, write to | |
| 20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 21 Boston, MA 02111-1307, USA. */ | |
| 22 | |
| 23 /* Synched up with: FSF 19.30 (except for Fsignal), Mule 2.0. */ | |
| 24 | |
| 853 | 25 /* Authorship: |
| 26 | |
| 27 Based on code from pre-release FSF 19, c. 1991. | |
| 28 Some work by Richard Mlynarik long ago (c. 1993?) -- | |
| 29 added call-with-condition-handler; synch. up to released FSF 19.7 | |
| 30 for lemacs 19.8. some signal changes. | |
| 31 Various work by Ben Wing, 1995-1996: | |
| 32 added all stuff dealing with trapping errors, suspended-errors, etc. | |
| 33 added most Fsignal front ends. | |
| 34 added warning code. | |
| 35 reworked the Fsignal code and synched the rest up to FSF 19.30. | |
| 36 Some changes by Martin Buchholz c. 1999? | |
| 37 e.g. PRIMITIVE_FUNCALL macros. | |
| 38 New call_trapping_problems code and large comments below | |
| 39 by Ben Wing, Mar-Apr 2000. | |
| 40 */ | |
| 41 | |
| 42 /* This file has been Mule-ized. */ | |
| 43 | |
| 44 /* What is in this file? | |
| 45 | |
| 46 This file contains the engine for the ELisp interpreter in XEmacs. | |
| 47 The engine does the actual work of implementing function calls, | |
| 48 form evaluation, non-local exits (catch, throw, signal, | |
| 49 condition-case, call-with-condition-handler), unwind-protects, | |
| 50 dynamic bindings, let constructs, backtraces, etc. You might say | |
| 51 that this module is the very heart of XEmacs, and everything else | |
| 52 in XEmacs is merely an auxiliary module implementing some specific | |
| 53 functionality that may be called from the heart at an appropriate | |
| 54 time. | |
| 55 | |
| 56 The only exception is the alloc.c module, which implements the | |
| 57 framework upon which this module (eval.c) works. alloc.c works | |
| 58 with creating the actual Lisp objects themselves and garbage | |
| 1960 | 59 collecting them as necessary, presenting a nice, high-level |
| 853 | 60 interface for object creation, deletion, access, and modification. |
| 61 | |
| 62 The only other exception that could be cited is the event-handling | |
| 63 module in event-stream.c. From its perspective, it is also the | |
| 64 heart of XEmacs, and controls exactly what gets done at what time. | |
| 65 From its perspective, eval.c is merely one of the auxiliary modules | |
| 66 out there that can be invoked by event-stream.c. | |
| 67 | |
| 68 Although the event-stream-centric view is a convenient fiction that | |
| 69 makes sense particularly from the user's perspective and from the | |
| 70 perspective of time, the engine-centric view is actually closest to | |
| 71 the truth, because anywhere within the event-stream module, you are | |
| 72 still somewhere in a Lisp backtrace, and event-loops are begun by | |
| 73 functions such as `command-loop-1', a Lisp function. | |
| 74 | |
| 75 As the Lisp engine is doing its thing, it maintains the state of | |
| 1960 | 76 the engine primarily in five list-like items, which are: |
| 853 | 77 |
| 78 -- the backtrace list | |
| 79 -- the catchtag list | |
| 80 -- the condition-handler list | |
| 81 -- the specbind list | |
| 82 -- the GCPRO list. | |
| 83 | |
| 84 These are described in detail in the next comment. | |
| 85 | |
| 86 --ben | |
| 87 */ | |
| 88 | |
| 89 /* Note that there are five separate lists used to maintain state in | |
| 90 the evaluator. All of them conceptually are stacks (last-in, | |
| 91 first-out). All non-local exits happen ultimately through the | |
| 92 catch/throw mechanism, which uses one of the five lists (the | |
| 93 catchtag list) and records the current state of the others in each | |
| 94 frame of the list (some other information is recorded and restored | |
| 95 as well, such as the current eval depth), so that all the state of | |
| 96 the evaluator is restored properly when a non-local exit occurs. | |
| 97 (Note that the current state of the condition-handler list is not | |
| 98 recorded in the catchtag list. Instead, when a condition-case or | |
| 99 call-with-condition-handler is set up, it installs an | |
| 100 unwind-protect on the specbind list to restore the appropriate | |
| 101 setting for the condition-handler list. During the course of | |
| 102 handling the non-local exit, all entries on the specbind list that | |
| 103 are past the location stored in the catch frame are "unwound" | |
| 104 (i.e. variable bindings are restored and unwind-protects are | |
| 105 executed), so the condition-handler list gets reset properly. | |
| 106 | |
| 107 The five lists are | |
| 108 | |
| 109 1. The backtrace list, which is chained through `struct backtrace's | |
| 110 declared in the stack frames of various primitives, and keeps | |
| 111 track of all Lisp function call entries and exits. | |
| 112 2. The catchtag list, which is chained through `struct catchtag's | |
| 113 declared in the stack frames of internal_catch and condition_case_1, | |
| 114 and keeps track of information needed to reset the internal state | |
| 115 of the evaluator to the state that was current when the catch or | |
| 116 condition-case were established, in the event of a non-local exit. | |
| 117 3. The condition-handler list, which is a simple Lisp list with new | |
| 118 entries consed onto the front of the list. It records condition-cases | |
| 119 and call-with-condition-handlers established either from C or from | |
| 120 Lisp. Unlike with the other lists (but similar to everything else | |
| 121 of a similar nature in the rest of the C and Lisp code), it takes care | |
| 122 of restoring itself appropriately in the event of a non-local exit | |
| 123 through the use of the unwind-protect mechanism. | |
| 124 4. The specbind list, which is a contiguous array of `struct specbinding's, | |
| 125 expanded as necessary using realloc(). It holds dynamic variable | |
| 126 bindings (the only kind we currently have in ELisp) and unwind-protects. | |
| 127 5. The GCPRO list, which is chained through `struct gcpro's declared in | |
| 128 the stack frames of any functions that need to GC-protect Lisp_Objects | |
| 129 declared on the stack. This is one of the most fragile areas of the | |
| 130 entire scheme -- you must not forget to UNGCPRO at the end of your | |
| 131 function, you must make sure you GCPRO in many circumstances you don't | |
| 132 think you have to, etc. See the internals manual for more information | |
| 133 about this. | |
| 134 | |
| 135 --ben | |
| 136 */ | |
| 137 | |
| 428 | 138 #include <config.h> |
| 139 #include "lisp.h" | |
| 140 | |
| 141 #include "commands.h" | |
| 142 #include "backtrace.h" | |
| 143 #include "bytecode.h" | |
| 144 #include "buffer.h" | |
| 872 | 145 #include "console-impl.h" |
| 853 | 146 #include "device.h" |
| 147 #include "frame.h" | |
| 148 #include "lstream.h" | |
| 428 | 149 #include "opaque.h" |
| 1292 | 150 #include "profile.h" |
| 853 | 151 #include "window.h" |
| 428 | 152 |
| 153 struct backtrace *backtrace_list; | |
| 154 | |
| 155 /* Macros for calling subrs with an argument list whose length is only | |
| 156 known at runtime. See EXFUN and DEFUN for similar hackery. */ | |
| 157 | |
| 158 #define AV_0(av) | |
| 159 #define AV_1(av) av[0] | |
| 160 #define AV_2(av) AV_1(av), av[1] | |
| 161 #define AV_3(av) AV_2(av), av[2] | |
| 162 #define AV_4(av) AV_3(av), av[3] | |
| 163 #define AV_5(av) AV_4(av), av[4] | |
| 164 #define AV_6(av) AV_5(av), av[5] | |
| 165 #define AV_7(av) AV_6(av), av[6] | |
| 166 #define AV_8(av) AV_7(av), av[7] | |
| 167 | |
| 168 #define PRIMITIVE_FUNCALL_1(fn, av, ac) \ | |
| 444 | 169 (((Lisp_Object (*)(EXFUN_##ac)) (fn)) (AV_##ac (av))) |
| 428 | 170 |
| 171 /* If subrs take more than 8 arguments, more cases need to be added | |
| 172 to this switch. (But wait - don't do it - if you really need | |
| 173 a SUBR with more than 8 arguments, use max_args == MANY. | |
| 853 | 174 Or better, considering using a property list as one of your args. |
| 428 | 175 See the DEFUN macro in lisp.h) */ |
| 176 #define PRIMITIVE_FUNCALL(rv, fn, av, ac) do { \ | |
| 177 void (*PF_fn)(void) = (void (*)(void)) fn; \ | |
| 178 Lisp_Object *PF_av = (av); \ | |
| 179 switch (ac) \ | |
| 180 { \ | |
| 436 | 181 default:rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 0); break; \ |
| 428 | 182 case 1: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 1); break; \ |
| 183 case 2: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 2); break; \ | |
| 184 case 3: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 3); break; \ | |
| 185 case 4: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 4); break; \ | |
| 186 case 5: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 5); break; \ | |
| 187 case 6: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 6); break; \ | |
| 188 case 7: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 7); break; \ | |
| 189 case 8: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 8); break; \ | |
| 190 } \ | |
| 191 } while (0) | |
| 192 | |
| 193 #define FUNCALL_SUBR(rv, subr, av, ac) \ | |
| 194 PRIMITIVE_FUNCALL (rv, subr_function (subr), av, ac); | |
| 195 | |
| 196 | |
| 197 /* This is the list of current catches (and also condition-cases). | |
| 853 | 198 This is a stack: the most recent catch is at the head of the list. |
| 199 The list is threaded through the stack frames of the C functions | |
| 200 that set up the catches; this is similar to the way the GCPRO list | |
| 201 is handled, but different from the condition-handler list (which is | |
| 202 a simple Lisp list) and the specbind stack, which is a contiguous | |
| 203 array of `struct specbinding's, grown (using realloc()) as | |
| 204 necessary. (Note that all four of these lists behave as a stacks.) | |
| 205 | |
| 3025 | 206 Catches are created by declaring a `struct catchtag' locally, |
| 853 | 207 filling the .TAG field in with the tag, and doing a setjmp() on |
| 208 .JMP. Fthrow() will store the value passed to it in .VAL and | |
| 209 longjmp() back to .JMP, back to the function that established the | |
| 210 catch. This will always be either internal_catch() (catches | |
| 211 established internally or through `catch') or condition_case_1 | |
| 212 (condition-cases established internally or through | |
| 213 `condition-case'). | |
| 428 | 214 |
| 215 The catchtag also records the current position in the | |
| 216 call stack (stored in BACKTRACE_LIST), the current position | |
| 217 in the specpdl stack (used for variable bindings and | |
| 218 unwind-protects), the value of LISP_EVAL_DEPTH, and the | |
| 219 current position in the GCPRO stack. All of these are | |
| 220 restored by Fthrow(). | |
| 853 | 221 */ |
| 428 | 222 |
| 223 struct catchtag *catchlist; | |
| 224 | |
| 853 | 225 /* A special tag that can be used internally from C code to catch |
| 226 every attempt to throw past this level. */ | |
| 227 Lisp_Object Vcatch_everything_tag; | |
| 228 | |
| 428 | 229 Lisp_Object Qautoload, Qmacro, Qexit; |
| 230 Lisp_Object Qinteractive, Qcommandp, Qdefun, Qprogn, Qvalues; | |
| 231 Lisp_Object Vquit_flag, Vinhibit_quit; | |
| 232 Lisp_Object Qand_rest, Qand_optional; | |
| 233 Lisp_Object Qdebug_on_error, Qstack_trace_on_error; | |
| 234 Lisp_Object Qdebug_on_signal, Qstack_trace_on_signal; | |
| 235 Lisp_Object Qdebugger; | |
| 236 Lisp_Object Qinhibit_quit; | |
| 887 | 237 Lisp_Object Qfinalize_list; |
| 428 | 238 Lisp_Object Qrun_hooks; |
| 239 Lisp_Object Qsetq; | |
| 240 Lisp_Object Qdisplay_warning; | |
| 241 Lisp_Object Vpending_warnings, Vpending_warnings_tail; | |
| 242 Lisp_Object Qif; | |
| 243 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
244 Lisp_Object Qthrow; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
245 Lisp_Object Qobsolete_throw; |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
246 Lisp_Object Qmultiple_value_list_internal; |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
247 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
248 static int first_desired_multiple_value; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
249 /* Used outside this file, somewhat uncleanly, in the IGNORE_MULTIPLE_VALUES |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
250 macro: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
251 int multiple_value_current_limit; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
252 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
253 Fixnum Vmultiple_values_limit; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
254 |
| 853 | 255 /* Flags specifying which operations are currently inhibited. */ |
| 256 int inhibit_flags; | |
| 257 | |
| 258 /* Buffers, frames, windows, devices, and consoles created since most | |
| 259 recent active | |
| 260 call_trapping_problems (INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION). | |
| 261 */ | |
| 262 Lisp_Object Vdeletable_permanent_display_objects; | |
| 263 | |
| 264 /* Buffers created since most recent active | |
| 265 call_trapping_problems (INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION). */ | |
| 266 Lisp_Object Vmodifiable_buffers; | |
| 793 | 267 |
| 268 /* Minimum level at which warnings are logged. Below this, they're ignored | |
| 269 entirely -- not even generated. */ | |
| 270 Lisp_Object Vlog_warning_minimum_level; | |
| 271 | |
| 428 | 272 /* Non-nil means record all fset's and provide's, to be undone |
| 273 if the file being autoloaded is not fully loaded. | |
| 274 They are recorded by being consed onto the front of Vautoload_queue: | |
| 275 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */ | |
| 276 Lisp_Object Vautoload_queue; | |
| 277 | |
| 278 /* Current number of specbindings allocated in specpdl. */ | |
| 279 int specpdl_size; | |
| 280 | |
| 281 /* Pointer to beginning of specpdl. */ | |
| 282 struct specbinding *specpdl; | |
| 283 | |
| 284 /* Pointer to first unused element in specpdl. */ | |
| 285 struct specbinding *specpdl_ptr; | |
| 286 | |
| 287 /* specpdl_ptr - specpdl */ | |
| 288 int specpdl_depth_counter; | |
| 289 | |
| 290 /* Maximum size allowed for specpdl allocation */ | |
| 458 | 291 Fixnum max_specpdl_size; |
| 428 | 292 |
| 293 /* Depth in Lisp evaluations and function calls. */ | |
| 1292 | 294 int lisp_eval_depth; |
| 428 | 295 |
| 296 /* Maximum allowed depth in Lisp evaluations and function calls. */ | |
| 458 | 297 Fixnum max_lisp_eval_depth; |
| 428 | 298 |
| 299 /* Nonzero means enter debugger before next function call */ | |
| 300 static int debug_on_next_call; | |
| 301 | |
| 1292 | 302 int backtrace_with_internal_sections; |
| 303 | |
| 428 | 304 /* List of conditions (non-nil atom means all) which cause a backtrace |
| 305 if an error is handled by the command loop's error handler. */ | |
| 306 Lisp_Object Vstack_trace_on_error; | |
| 307 | |
| 308 /* List of conditions (non-nil atom means all) which enter the debugger | |
| 309 if an error is handled by the command loop's error handler. */ | |
| 310 Lisp_Object Vdebug_on_error; | |
| 311 | |
| 312 /* List of conditions and regexps specifying error messages which | |
| 313 do not enter the debugger even if Vdebug_on_error says they should. */ | |
| 314 Lisp_Object Vdebug_ignored_errors; | |
| 315 | |
| 316 /* List of conditions (non-nil atom means all) which cause a backtrace | |
| 317 if any error is signalled. */ | |
| 318 Lisp_Object Vstack_trace_on_signal; | |
| 319 | |
| 320 /* List of conditions (non-nil atom means all) which enter the debugger | |
| 321 if any error is signalled. */ | |
| 322 Lisp_Object Vdebug_on_signal; | |
| 323 | |
| 324 /* Nonzero means enter debugger if a quit signal | |
| 325 is handled by the command loop's error handler. | |
| 326 | |
| 327 From lisp, this is a boolean variable and may have the values 0 and 1. | |
| 328 But, eval.c temporarily uses the second bit of this variable to indicate | |
| 329 that a critical_quit is in progress. The second bit is reset immediately | |
| 330 after it is processed in signal_call_debugger(). */ | |
| 331 int debug_on_quit; | |
| 332 | |
| 333 #if 0 /* FSFmacs */ | |
| 334 /* entering_debugger is basically equivalent */ | |
| 335 /* The value of num_nonmacro_input_chars as of the last time we | |
| 336 started to enter the debugger. If we decide to enter the debugger | |
| 337 again when this is still equal to num_nonmacro_input_chars, then we | |
| 338 know that the debugger itself has an error, and we should just | |
| 339 signal the error instead of entering an infinite loop of debugger | |
| 340 invocations. */ | |
| 341 int when_entered_debugger; | |
| 342 #endif | |
| 343 | |
| 344 /* Nonzero means we are trying to enter the debugger. | |
| 345 This is to prevent recursive attempts. | |
| 346 Cleared by the debugger calling Fbacktrace */ | |
| 347 static int entering_debugger; | |
| 348 | |
| 349 /* Function to call to invoke the debugger */ | |
| 350 Lisp_Object Vdebugger; | |
| 351 | |
| 853 | 352 /* List of condition handlers currently in effect. |
| 353 The elements of this lists were at one point in the past | |
| 354 threaded through the stack frames of Fcondition_case and | |
| 355 related functions, but now are stored separately in a normal | |
| 356 stack. When an error is signaled (by calling Fsignal, below), | |
| 357 this list is searched for an element that applies. | |
| 428 | 358 |
| 359 Each element of this list is one of the following: | |
| 360 | |
| 853 | 361 -- A list of a handler function and possibly args to pass to the |
| 362 function. This is a handler established with the Lisp primitive | |
| 363 `call-with-condition-handler' or related C function | |
| 364 call_with_condition_handler(): | |
| 365 | |
| 366 If the handler function is an opaque ptr object, it is a handler | |
| 367 that was established in C using call_with_condition_handler(), | |
| 368 and the contents of the object are a function pointer which takes | |
| 369 three arguments, the signal name and signal data (same arguments | |
| 370 passed to `signal') and a third Lisp_Object argument, specified | |
| 371 in the call to call_with_condition_handler() and stored as the | |
| 372 second element of the list containing the handler functionl. | |
| 373 | |
| 374 If the handler function is a regular Lisp_Object, it is a handler | |
| 375 that was established using `call-with-condition-handler'. | |
| 376 Currently there are no more arguments in the list containing the | |
| 377 handler function, and only one argument is passed to the handler | |
| 378 function: a cons of the signal name and signal data arguments | |
| 379 passed to `signal'. | |
| 380 | |
| 381 -- A list whose car is Qunbound and whose cdr is Qt. This is a | |
| 382 special condition-case handler established by C code with | |
| 383 condition_case_1(). All errors are trapped; the debugger is not | |
| 384 invoked even if `debug-on-error' was set. | |
| 385 | |
| 386 -- A list whose car is Qunbound and whose cdr is Qerror. This is a | |
| 387 special condition-case handler established by C code with | |
| 388 condition_case_1(). It is like Qt except that the debugger is | |
| 389 invoked normally if it is called for. | |
| 390 | |
| 391 -- A list whose car is Qunbound and whose cdr is a list of lists | |
| 392 (CONDITION-NAME BODY ...) exactly as in `condition-case'. This is | |
| 393 a normal `condition-case' handler. | |
| 394 | |
| 395 Note that in all cases *except* the first, there is a corresponding | |
| 396 catch, whose TAG is the value of Vcondition_handlers just after the | |
| 397 handler data just described is pushed onto it. The reason is that | |
| 398 `condition-case' handlers need to throw back to the place where the | |
| 399 handler was installed before invoking it, while | |
| 400 `call-with-condition-handler' handlers are invoked in the | |
| 401 environment that `signal' was invoked in. */ | |
| 402 | |
| 403 | |
| 428 | 404 static Lisp_Object Vcondition_handlers; |
| 405 | |
| 853 | 406 /* I think we should keep this enabled all the time, not just when |
| 407 error checking is enabled, because if one of these puppies pops up, | |
| 408 it will trash the stack if not caught, making it that much harder to | |
| 409 debug. It doesn't cause speed loss. */ | |
| 442 | 410 #define DEFEND_AGAINST_THROW_RECURSION |
| 411 | |
| 412 #ifdef DEFEND_AGAINST_THROW_RECURSION | |
| 428 | 413 /* Used for error catching purposes by throw_or_bomb_out */ |
| 414 static int throw_level; | |
| 442 | 415 #endif |
| 416 | |
| 1123 | 417 static int warning_will_be_discarded (Lisp_Object level); |
| 2532 | 418 static Lisp_Object maybe_get_trapping_problems_backtrace (void); |
| 1123 | 419 |
| 428 | 420 |
| 421 /************************************************************************/ | |
| 422 /* The subr object type */ | |
| 423 /************************************************************************/ | |
| 424 | |
| 425 static void | |
| 2286 | 426 print_subr (Lisp_Object obj, Lisp_Object printcharfun, int UNUSED (escapeflag)) |
| 428 | 427 { |
| 428 Lisp_Subr *subr = XSUBR (obj); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
429 const Ascbyte *header = |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
430 (subr->max_args == UNEVALLED) ? "#<special-operator " : "#<subr "; |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
431 const Ascbyte *name = subr_name (subr); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
432 const Ascbyte *trailer = subr->prompt ? " (interactive)>" : ">"; |
| 428 | 433 |
| 434 if (print_readably) | |
| 563 | 435 printing_unreadable_object ("%s%s%s", header, name, trailer); |
| 428 | 436 |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
437 write_ascstring (printcharfun, header); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
438 write_ascstring (printcharfun, name); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
439 write_ascstring (printcharfun, trailer); |
| 428 | 440 } |
| 441 | |
| 1204 | 442 static const struct memory_description subr_description[] = { |
| 2551 | 443 { XD_DOC_STRING, offsetof (Lisp_Subr, doc), 0, { 0 }, XD_FLAG_NO_KKCC }, |
| 428 | 444 { XD_END } |
| 445 }; | |
| 446 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
447 DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("subr", subr, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
448 0, print_subr, 0, 0, 0, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
449 subr_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
450 Lisp_Subr); |
| 428 | 451 |
| 452 /************************************************************************/ | |
| 453 /* Entering the debugger */ | |
| 454 /************************************************************************/ | |
| 455 | |
| 853 | 456 static Lisp_Object |
| 457 current_warning_level (void) | |
| 458 { | |
| 459 if (inhibit_flags & ISSUE_WARNINGS_AT_DEBUG_LEVEL) | |
| 460 return Qdebug; | |
| 461 else | |
| 462 return Qwarning; | |
| 463 } | |
| 464 | |
| 428 | 465 /* Actually call the debugger. ARG is a list of args that will be |
| 466 passed to the debugger function, as follows; | |
| 467 | |
| 468 If due to frame exit, args are `exit' and the value being returned; | |
| 469 this function's value will be returned instead of that. | |
| 470 If due to error, args are `error' and a list of the args to `signal'. | |
| 471 If due to `apply' or `funcall' entry, one arg, `lambda'. | |
| 472 If due to `eval' entry, one arg, t. | |
| 473 | |
| 474 */ | |
| 475 | |
| 476 static Lisp_Object | |
| 477 call_debugger_259 (Lisp_Object arg) | |
| 478 { | |
| 479 return apply1 (Vdebugger, arg); | |
| 480 } | |
| 481 | |
| 482 /* Call the debugger, doing some encapsulation. We make sure we have | |
| 483 some room on the eval and specpdl stacks, and bind entering_debugger | |
| 484 to 1 during this call. This is used to trap errors that may occur | |
| 485 when entering the debugger (e.g. the value of `debugger' is invalid), | |
| 486 so that the debugger will not be recursively entered if debug-on-error | |
| 487 is set. (Otherwise, XEmacs would infinitely recurse, attempting to | |
| 488 enter the debugger.) entering_debugger gets reset to 0 as soon | |
| 489 as a backtrace is displayed, so that further errors can indeed be | |
| 490 handled normally. | |
| 491 | |
| 3025 | 492 We also establish a catch for `debugger'. If the debugger function |
| 428 | 493 throws to this instead of returning a value, it means that the user |
| 494 pressed 'c' (pretend like the debugger was never entered). The | |
| 495 function then returns Qunbound. (If the user pressed 'r', for | |
| 496 return a value, then the debugger function returns normally with | |
| 497 this value.) | |
| 498 | |
| 499 The difference between 'c' and 'r' is as follows: | |
| 500 | |
| 501 debug-on-call: | |
| 502 No difference. The call proceeds as normal. | |
| 503 debug-on-exit: | |
| 504 With 'r', the specified value is returned as the function's | |
| 505 return value. With 'c', the value that would normally be | |
| 506 returned is returned. | |
| 507 signal: | |
| 508 With 'r', the specified value is returned as the return | |
| 509 value of `signal'. (This is the only time that `signal' | |
| 510 can return, instead of making a non-local exit.) With `c', | |
| 511 `signal' will continue looking for handlers as if the | |
| 512 debugger was never entered, and will probably end up | |
| 513 throwing to a handler or to top-level. | |
| 514 */ | |
| 515 | |
| 516 static Lisp_Object | |
| 517 call_debugger (Lisp_Object arg) | |
| 518 { | |
| 519 int threw; | |
| 520 Lisp_Object val; | |
| 521 int speccount; | |
| 522 | |
| 853 | 523 debug_on_next_call = 0; |
| 524 | |
| 525 if (inhibit_flags & INHIBIT_ENTERING_DEBUGGER) | |
| 526 { | |
| 527 if (!(inhibit_flags & INHIBIT_WARNING_ISSUE)) | |
| 528 warn_when_safe | |
| 529 (Qdebugger, current_warning_level (), | |
| 530 "Unable to enter debugger within critical section"); | |
| 531 return Qunbound; | |
| 532 } | |
| 533 | |
| 428 | 534 if (lisp_eval_depth + 20 > max_lisp_eval_depth) |
| 535 max_lisp_eval_depth = lisp_eval_depth + 20; | |
| 536 if (specpdl_size + 40 > max_specpdl_size) | |
| 537 max_specpdl_size = specpdl_size + 40; | |
| 853 | 538 |
| 539 speccount = internal_bind_int (&entering_debugger, 1); | |
| 2532 | 540 val = internal_catch (Qdebugger, call_debugger_259, arg, &threw, 0, 0); |
| 428 | 541 |
| 771 | 542 return unbind_to_1 (speccount, ((threw) |
| 428 | 543 ? Qunbound /* Not returning a value */ |
| 544 : val)); | |
| 545 } | |
| 546 | |
| 547 /* Called when debug-on-exit behavior is called for. Enter the debugger | |
| 548 with the appropriate args for this. VAL is the exit value that is | |
| 549 about to be returned. */ | |
| 550 | |
| 551 static Lisp_Object | |
| 552 do_debug_on_exit (Lisp_Object val) | |
| 553 { | |
| 554 /* This is falsified by call_debugger */ | |
| 555 Lisp_Object v = call_debugger (list2 (Qexit, val)); | |
| 556 | |
| 557 return !UNBOUNDP (v) ? v : val; | |
| 558 } | |
| 559 | |
| 560 /* Called when debug-on-call behavior is called for. Enter the debugger | |
| 561 with the appropriate args for this. VAL is either t for a call | |
| 3025 | 562 through `eval' or `lambda' for a call through `funcall'. |
| 428 | 563 |
| 564 #### The differentiation here between EVAL and FUNCALL is bogus. | |
| 565 FUNCALL can be defined as | |
| 566 | |
| 567 (defmacro func (fun &rest args) | |
| 568 (cons (eval fun) args)) | |
| 569 | |
| 570 and should be treated as such. | |
| 571 */ | |
| 572 | |
| 573 static void | |
| 574 do_debug_on_call (Lisp_Object code) | |
| 575 { | |
| 576 debug_on_next_call = 0; | |
| 577 backtrace_list->debug_on_exit = 1; | |
| 578 call_debugger (list1 (code)); | |
| 579 } | |
| 580 | |
| 581 /* LIST is the value of one of the variables `debug-on-error', | |
| 582 `debug-on-signal', `stack-trace-on-error', or `stack-trace-on-signal', | |
| 583 and CONDITIONS is the list of error conditions associated with | |
| 584 the error being signalled. This returns non-nil if LIST | |
| 585 matches CONDITIONS. (A nil value for LIST does not match | |
| 586 CONDITIONS. A non-list value for LIST does match CONDITIONS. | |
| 587 A list matches CONDITIONS when one of the symbols in LIST is the | |
| 588 same as one of the symbols in CONDITIONS.) */ | |
| 589 | |
| 590 static int | |
| 591 wants_debugger (Lisp_Object list, Lisp_Object conditions) | |
| 592 { | |
| 593 if (NILP (list)) | |
| 594 return 0; | |
| 595 if (! CONSP (list)) | |
| 596 return 1; | |
| 597 | |
| 598 while (CONSP (conditions)) | |
| 599 { | |
| 2552 | 600 Lisp_Object curr, tail; |
| 601 curr = XCAR (conditions); | |
| 428 | 602 for (tail = list; CONSP (tail); tail = XCDR (tail)) |
| 2552 | 603 if (EQ (XCAR (tail), curr)) |
| 428 | 604 return 1; |
| 605 conditions = XCDR (conditions); | |
| 606 } | |
| 607 return 0; | |
| 608 } | |
| 609 | |
| 610 | |
| 611 /* Return 1 if an error with condition-symbols CONDITIONS, | |
| 612 and described by SIGNAL-DATA, should skip the debugger | |
|
4624
9dd42cb187ed
Fix typo in comment on skip_debugger.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4535
diff
changeset
|
613 according to debug-ignored-errors. */ |
| 428 | 614 |
| 615 static int | |
| 616 skip_debugger (Lisp_Object conditions, Lisp_Object data) | |
| 617 { | |
| 618 /* This function can GC */ | |
| 619 Lisp_Object tail; | |
| 620 int first_string = 1; | |
| 621 Lisp_Object error_message = Qnil; | |
| 622 | |
| 623 for (tail = Vdebug_ignored_errors; CONSP (tail); tail = XCDR (tail)) | |
| 624 { | |
| 625 if (STRINGP (XCAR (tail))) | |
| 626 { | |
| 627 if (first_string) | |
| 628 { | |
| 629 error_message = Ferror_message_string (data); | |
| 630 first_string = 0; | |
| 631 } | |
| 632 if (fast_lisp_string_match (XCAR (tail), error_message) >= 0) | |
| 633 return 1; | |
| 634 } | |
| 635 else | |
| 636 { | |
| 637 Lisp_Object contail; | |
| 638 | |
| 639 for (contail = conditions; CONSP (contail); contail = XCDR (contail)) | |
| 640 if (EQ (XCAR (tail), XCAR (contail))) | |
| 641 return 1; | |
| 642 } | |
| 643 } | |
| 644 | |
| 645 return 0; | |
| 646 } | |
| 647 | |
| 648 /* Actually generate a backtrace on STREAM. */ | |
| 649 | |
| 650 static Lisp_Object | |
| 651 backtrace_259 (Lisp_Object stream) | |
| 652 { | |
| 653 return Fbacktrace (stream, Qt); | |
| 654 } | |
| 655 | |
| 1130 | 656 #ifdef DEBUG_XEMACS |
| 657 | |
| 658 static void | |
| 659 trace_out_and_die (Lisp_Object err) | |
| 660 { | |
| 661 Fdisplay_error (err, Qt); | |
| 662 backtrace_259 (Qnil); | |
| 663 stderr_out ("XEmacs exiting to debugger.\n"); | |
| 664 Fforce_debugging_signal (Qt); | |
| 665 /* Unlikely to be reached */ | |
| 666 } | |
| 667 | |
| 668 #endif | |
| 669 | |
| 428 | 670 /* An error was signaled. Maybe call the debugger, if the `debug-on-error' |
| 671 etc. variables call for this. CONDITIONS is the list of conditions | |
| 672 associated with the error being signalled. SIG is the actual error | |
| 673 being signalled, and DATA is the associated data (these are exactly | |
| 674 the same as the arguments to `signal'). ACTIVE_HANDLERS is the | |
| 675 list of error handlers that are to be put in place while the debugger | |
| 676 is called. This is generally the remaining handlers that are | |
| 677 outside of the innermost handler trapping this error. This way, | |
| 678 if the same error occurs inside of the debugger, you usually don't get | |
| 679 the debugger entered recursively. | |
| 680 | |
| 681 This function returns Qunbound if it didn't call the debugger or if | |
| 682 the user asked (through 'c') that XEmacs should pretend like the | |
| 683 debugger was never entered. Otherwise, it returns the value | |
| 684 that the user specified with `r'. (Note that much of the time, | |
| 685 the user will abort with C-], and we will never have a chance to | |
| 686 return anything at all.) | |
| 687 | |
| 688 SIGNAL_VARS_ONLY means we should only look at debug-on-signal | |
| 689 and stack-trace-on-signal to control whether we do anything. | |
| 690 This is so that debug-on-error doesn't make handled errors | |
| 691 cause the debugger to get invoked. | |
| 692 | |
| 693 STACK_TRACE_DISPLAYED and DEBUGGER_ENTERED are used so that | |
| 694 those functions aren't done more than once in a single `signal' | |
| 695 session. */ | |
| 696 | |
| 697 static Lisp_Object | |
| 698 signal_call_debugger (Lisp_Object conditions, | |
| 699 Lisp_Object sig, Lisp_Object data, | |
| 700 Lisp_Object active_handlers, | |
| 701 int signal_vars_only, | |
| 702 int *stack_trace_displayed, | |
| 703 int *debugger_entered) | |
| 704 { | |
| 853 | 705 #ifdef PIGS_FLY_AND_ALL_C_CODE_CAN_HANDLE_GC_OCCURRING_ALMOST_ANYWHERE |
| 428 | 706 /* This function can GC */ |
| 853 | 707 #else /* reality check */ |
| 708 /* This function cannot GC because it inhibits GC during its operation */ | |
| 709 #endif | |
| 710 | |
| 428 | 711 Lisp_Object val = Qunbound; |
| 712 Lisp_Object all_handlers = Vcondition_handlers; | |
| 713 Lisp_Object temp_data = Qnil; | |
| 853 | 714 int outer_speccount = specpdl_depth(); |
| 715 int speccount; | |
| 716 | |
| 717 #ifdef PIGS_FLY_AND_ALL_C_CODE_CAN_HANDLE_GC_OCCURRING_ALMOST_ANYWHERE | |
| 428 | 718 struct gcpro gcpro1, gcpro2; |
| 719 GCPRO2 (all_handlers, temp_data); | |
| 853 | 720 #else |
| 721 begin_gc_forbidden (); | |
| 722 #endif | |
| 723 | |
| 724 speccount = specpdl_depth(); | |
| 428 | 725 |
| 726 Vcondition_handlers = active_handlers; | |
| 727 | |
| 728 temp_data = Fcons (sig, data); /* needed for skip_debugger */ | |
| 729 | |
| 730 if (!entering_debugger && !*stack_trace_displayed && !signal_vars_only | |
| 731 && wants_debugger (Vstack_trace_on_error, conditions) | |
| 732 && !skip_debugger (conditions, temp_data)) | |
| 733 { | |
| 734 specbind (Qdebug_on_error, Qnil); | |
| 735 specbind (Qstack_trace_on_error, Qnil); | |
| 736 specbind (Qdebug_on_signal, Qnil); | |
| 737 specbind (Qstack_trace_on_signal, Qnil); | |
| 738 | |
| 442 | 739 if (!noninteractive) |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
740 internal_with_output_to_temp_buffer (build_ascstring ("*Backtrace*"), |
| 442 | 741 backtrace_259, |
| 742 Qnil, | |
| 743 Qnil); | |
| 744 else /* in batch mode, we want this going to stderr. */ | |
| 745 backtrace_259 (Qnil); | |
| 771 | 746 unbind_to (speccount); |
| 428 | 747 *stack_trace_displayed = 1; |
| 748 } | |
| 749 | |
| 750 if (!entering_debugger && !*debugger_entered && !signal_vars_only | |
| 751 && (EQ (sig, Qquit) | |
| 752 ? debug_on_quit | |
| 753 : wants_debugger (Vdebug_on_error, conditions)) | |
| 754 && !skip_debugger (conditions, temp_data)) | |
| 755 { | |
| 756 debug_on_quit &= ~2; /* reset critical bit */ | |
| 1123 | 757 |
| 428 | 758 specbind (Qdebug_on_error, Qnil); |
| 759 specbind (Qstack_trace_on_error, Qnil); | |
| 760 specbind (Qdebug_on_signal, Qnil); | |
| 761 specbind (Qstack_trace_on_signal, Qnil); | |
| 762 | |
| 1130 | 763 #ifdef DEBUG_XEMACS |
| 764 if (noninteractive) | |
| 765 trace_out_and_die (Fcons (sig, data)); | |
| 766 #endif | |
| 767 | |
| 428 | 768 val = call_debugger (list2 (Qerror, (Fcons (sig, data)))); |
| 853 | 769 unbind_to (speccount); |
| 428 | 770 *debugger_entered = 1; |
| 771 } | |
| 772 | |
| 773 if (!entering_debugger && !*stack_trace_displayed | |
| 774 && wants_debugger (Vstack_trace_on_signal, conditions)) | |
| 775 { | |
| 776 specbind (Qdebug_on_error, Qnil); | |
| 777 specbind (Qstack_trace_on_error, Qnil); | |
| 778 specbind (Qdebug_on_signal, Qnil); | |
| 779 specbind (Qstack_trace_on_signal, Qnil); | |
| 780 | |
| 442 | 781 if (!noninteractive) |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
782 internal_with_output_to_temp_buffer (build_ascstring ("*Backtrace*"), |
| 442 | 783 backtrace_259, |
| 784 Qnil, | |
| 785 Qnil); | |
| 786 else /* in batch mode, we want this going to stderr. */ | |
| 787 backtrace_259 (Qnil); | |
| 771 | 788 unbind_to (speccount); |
| 428 | 789 *stack_trace_displayed = 1; |
| 790 } | |
| 791 | |
| 792 if (!entering_debugger && !*debugger_entered | |
| 793 && (EQ (sig, Qquit) | |
| 794 ? debug_on_quit | |
| 795 : wants_debugger (Vdebug_on_signal, conditions))) | |
| 796 { | |
| 797 debug_on_quit &= ~2; /* reset critical bit */ | |
| 1123 | 798 |
| 428 | 799 specbind (Qdebug_on_error, Qnil); |
| 800 specbind (Qstack_trace_on_error, Qnil); | |
| 801 specbind (Qdebug_on_signal, Qnil); | |
| 802 specbind (Qstack_trace_on_signal, Qnil); | |
| 803 | |
| 1130 | 804 #ifdef DEBUG_XEMACS |
| 805 if (noninteractive) | |
| 806 trace_out_and_die (Fcons (sig, data)); | |
| 807 #endif | |
| 808 | |
| 428 | 809 val = call_debugger (list2 (Qerror, (Fcons (sig, data)))); |
| 810 *debugger_entered = 1; | |
| 811 } | |
| 812 | |
| 853 | 813 #ifdef PIGS_FLY_AND_ALL_C_CODE_CAN_HANDLE_GC_OCCURRING_ALMOST_ANYWHERE |
| 428 | 814 UNGCPRO; |
| 853 | 815 #endif |
| 428 | 816 Vcondition_handlers = all_handlers; |
| 853 | 817 return unbind_to_1 (outer_speccount, val); |
| 428 | 818 } |
| 819 | |
| 820 | |
| 821 /************************************************************************/ | |
| 822 /* The basic special forms */ | |
| 823 /************************************************************************/ | |
| 824 | |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
825 /* Except for Fprogn(), the basic special operators below are only called |
| 428 | 826 from interpreted code. The byte compiler turns them into bytecodes. */ |
| 827 | |
| 828 DEFUN ("or", For, 0, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
829 Eval ARGS until one of them yields non-nil, then return that value. |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
830 The remaining ARGS are not evalled at all. |
| 428 | 831 If all args return nil, return nil. |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
832 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
833 Any multiple values from the last form, and only from the last form, are |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
834 passed back. See `values' and `multiple-value-bind'. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
835 |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
836 arguments: (&rest ARGS) |
| 428 | 837 */ |
| 838 (args)) | |
| 839 { | |
| 840 /* This function can GC */ | |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
841 Lisp_Object val = Qnil; |
| 428 | 842 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
843 LIST_LOOP_3 (arg, args, tail) |
| 428 | 844 { |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
845 if (!NILP (IGNORE_MULTIPLE_VALUES (val = Feval (arg)))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
846 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
847 if (NILP (XCDR (tail))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
848 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
849 /* Pass back multiple values if this is the last one: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
850 return val; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
851 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
852 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
853 return IGNORE_MULTIPLE_VALUES (val); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
854 } |
| 428 | 855 } |
| 856 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
857 return val; |
| 428 | 858 } |
| 859 | |
| 860 DEFUN ("and", Fand, 0, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
861 Eval ARGS until one of them yields nil, then return nil. |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
862 The remaining ARGS are not evalled at all. |
| 428 | 863 If no arg yields nil, return the last arg's value. |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
864 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
865 Any multiple values from the last form, and only from the last form, are |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
866 passed back. See `values' and `multiple-value-bind'. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
867 |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
868 arguments: (&rest ARGS) |
| 428 | 869 */ |
| 870 (args)) | |
| 871 { | |
| 872 /* This function can GC */ | |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
873 Lisp_Object val = Qt; |
| 428 | 874 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
875 LIST_LOOP_3 (arg, args, tail) |
| 428 | 876 { |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
877 if (NILP (IGNORE_MULTIPLE_VALUES (val = Feval (arg)))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
878 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
879 if (NILP (XCDR (tail))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
880 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
881 /* Pass back any multiple values for the last form: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
882 return val; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
883 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
884 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
885 return Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
886 } |
| 428 | 887 } |
| 888 | |
| 889 return val; | |
| 890 } | |
| 891 | |
| 892 DEFUN ("if", Fif, 2, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
893 If COND yields non-nil, do THEN, else do ELSE. |
| 428 | 894 Returns the value of THEN or the value of the last of the ELSE's. |
| 895 THEN must be one expression, but ELSE... can be zero or more expressions. | |
| 896 If COND yields nil, and there are no ELSE's, the value is nil. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
897 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
898 arguments: (COND THEN &rest ELSE) |
| 428 | 899 */ |
| 900 (args)) | |
| 901 { | |
| 902 /* This function can GC */ | |
| 903 Lisp_Object condition = XCAR (args); | |
| 904 Lisp_Object then_form = XCAR (XCDR (args)); | |
| 905 Lisp_Object else_forms = XCDR (XCDR (args)); | |
| 906 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
907 if (!NILP (IGNORE_MULTIPLE_VALUES (Feval (condition)))) |
| 428 | 908 return Feval (then_form); |
| 909 else | |
| 910 return Fprogn (else_forms); | |
| 911 } | |
| 912 | |
| 913 /* Macros `when' and `unless' are trivially defined in Lisp, | |
| 914 but it helps for bootstrapping to have them ALWAYS defined. */ | |
| 915 | |
| 916 DEFUN ("when", Fwhen, 1, MANY, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
917 If COND yields non-nil, do BODY, else return nil. |
| 428 | 918 BODY can be zero or more expressions. If BODY is nil, return nil. |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
919 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
920 arguments: (COND &rest BODY) |
| 428 | 921 */ |
| 922 (int nargs, Lisp_Object *args)) | |
| 923 { | |
| 924 Lisp_Object cond = args[0]; | |
| 925 Lisp_Object body; | |
| 853 | 926 |
| 428 | 927 switch (nargs) |
| 928 { | |
| 929 case 1: body = Qnil; break; | |
| 930 case 2: body = args[1]; break; | |
| 931 default: body = Fcons (Qprogn, Flist (nargs-1, args+1)); break; | |
| 932 } | |
| 933 | |
| 934 return list3 (Qif, cond, body); | |
| 935 } | |
| 936 | |
| 937 DEFUN ("unless", Funless, 1, MANY, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
938 If COND yields nil, do BODY, else return nil. |
| 428 | 939 BODY can be zero or more expressions. If BODY is nil, return nil. |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
940 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
941 arguments: (COND &rest BODY) |
| 428 | 942 */ |
| 943 (int nargs, Lisp_Object *args)) | |
| 944 { | |
| 945 Lisp_Object cond = args[0]; | |
| 946 Lisp_Object body = Flist (nargs-1, args+1); | |
| 947 return Fcons (Qif, Fcons (cond, Fcons (Qnil, body))); | |
| 948 } | |
| 949 | |
| 950 DEFUN ("cond", Fcond, 0, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
951 Try each clause until one succeeds. |
| 428 | 952 Each clause looks like (CONDITION BODY...). CONDITION is evaluated |
| 953 and, if the value is non-nil, this clause succeeds: | |
| 954 then the expressions in BODY are evaluated and the last one's | |
| 955 value is the value of the cond-form. | |
| 956 If no clause succeeds, cond returns nil. | |
| 957 If a clause has one element, as in (CONDITION), | |
| 958 CONDITION's value if non-nil is returned from the cond-form. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
959 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
960 arguments: (&rest CLAUSES) |
| 428 | 961 */ |
| 962 (args)) | |
| 963 { | |
| 964 /* This function can GC */ | |
| 442 | 965 REGISTER Lisp_Object val; |
| 428 | 966 |
| 967 LIST_LOOP_2 (clause, args) | |
| 968 { | |
| 969 CHECK_CONS (clause); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
970 if (!NILP (val = IGNORE_MULTIPLE_VALUES (Feval (XCAR (clause))))) |
| 428 | 971 { |
| 972 if (!NILP (clause = XCDR (clause))) | |
| 973 { | |
| 974 CHECK_TRUE_LIST (clause); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
975 /* Pass back any multiple values here: */ |
| 428 | 976 val = Fprogn (clause); |
| 977 } | |
| 978 return val; | |
| 979 } | |
| 980 } | |
| 981 | |
| 982 return Qnil; | |
| 983 } | |
| 984 | |
| 985 DEFUN ("progn", Fprogn, 0, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
986 Eval BODY forms sequentially and return value of last one. |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
987 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
988 arguments: (&rest BODY) |
| 428 | 989 */ |
| 990 (args)) | |
| 991 { | |
| 992 /* This function can GC */ | |
| 993 /* Caller must provide a true list in ARGS */ | |
| 442 | 994 REGISTER Lisp_Object val = Qnil; |
| 428 | 995 struct gcpro gcpro1; |
| 996 | |
| 997 GCPRO1 (args); | |
| 998 | |
| 999 { | |
| 1000 LIST_LOOP_2 (form, args) | |
| 1001 val = Feval (form); | |
| 1002 } | |
| 1003 | |
| 1004 UNGCPRO; | |
| 1005 return val; | |
| 1006 } | |
| 1007 | |
| 1008 /* Fprog1() is the canonical example of a function that must GCPRO a | |
| 1009 Lisp_Object across calls to Feval(). */ | |
| 1010 | |
| 1011 DEFUN ("prog1", Fprog1, 1, UNEVALLED, 0, /* | |
| 1012 Similar to `progn', but the value of the first form is returned. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1013 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1014 All the arguments are evaluated sequentially. The value of FIRST is saved |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1015 during evaluation of the remaining args, whose values are discarded. |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1016 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1017 arguments: (FIRST &rest BODY) |
| 428 | 1018 */ |
| 1019 (args)) | |
| 1020 { | |
| 1849 | 1021 Lisp_Object val; |
| 428 | 1022 struct gcpro gcpro1; |
| 1023 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1024 val = IGNORE_MULTIPLE_VALUES (Feval (Fcar (args))); |
| 428 | 1025 |
| 1026 GCPRO1 (val); | |
| 1027 | |
| 1028 { | |
| 1029 LIST_LOOP_2 (form, XCDR (args)) | |
| 1030 Feval (form); | |
| 1031 } | |
| 1032 | |
| 1033 UNGCPRO; | |
| 1034 return val; | |
| 1035 } | |
| 1036 | |
| 1037 DEFUN ("prog2", Fprog2, 2, UNEVALLED, 0, /* | |
| 1038 Similar to `progn', but the value of the second form is returned. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1039 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1040 All the arguments are evaluated sequentially. The value of SECOND is saved |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1041 during evaluation of the remaining args, whose values are discarded. |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1042 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1043 arguments: (FIRST SECOND &rest BODY) |
| 428 | 1044 */ |
| 1045 (args)) | |
| 1046 { | |
| 1047 /* This function can GC */ | |
| 1849 | 1048 Lisp_Object val; |
| 428 | 1049 struct gcpro gcpro1; |
| 1050 | |
| 1051 Feval (XCAR (args)); | |
| 1052 args = XCDR (args); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1053 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1054 val = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1055 |
| 428 | 1056 args = XCDR (args); |
| 1057 | |
| 1058 GCPRO1 (val); | |
| 1059 | |
| 442 | 1060 { |
| 1061 LIST_LOOP_2 (form, args) | |
| 1062 Feval (form); | |
| 1063 } | |
| 428 | 1064 |
| 1065 UNGCPRO; | |
| 1066 return val; | |
| 1067 } | |
| 1068 | |
| 1069 DEFUN ("let*", FletX, 1, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1070 Bind variables according to VARLIST then eval BODY. |
| 428 | 1071 The value of the last form in BODY is returned. |
| 1072 Each element of VARLIST is a symbol (which is bound to nil) | |
| 1073 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM). | |
| 1074 Each VALUEFORM can refer to the symbols already bound by this VARLIST. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1075 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1076 arguments: (VARLIST &rest BODY) |
| 428 | 1077 */ |
| 1078 (args)) | |
| 1079 { | |
| 1080 /* This function can GC */ | |
| 1081 Lisp_Object varlist = XCAR (args); | |
| 1082 Lisp_Object body = XCDR (args); | |
| 1083 int speccount = specpdl_depth(); | |
| 1084 | |
| 1085 EXTERNAL_LIST_LOOP_3 (var, varlist, tail) | |
| 1086 { | |
| 1087 Lisp_Object symbol, value, tem; | |
| 1088 if (SYMBOLP (var)) | |
| 1089 symbol = var, value = Qnil; | |
| 1090 else | |
| 1091 { | |
| 1092 CHECK_CONS (var); | |
| 1093 symbol = XCAR (var); | |
| 1094 tem = XCDR (var); | |
| 1095 if (NILP (tem)) | |
| 1096 value = Qnil; | |
| 1097 else | |
| 1098 { | |
| 1099 CHECK_CONS (tem); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1100 value = IGNORE_MULTIPLE_VALUES (Feval (XCAR (tem))); |
| 428 | 1101 if (!NILP (XCDR (tem))) |
| 563 | 1102 sferror |
| 428 | 1103 ("`let' bindings can have only one value-form", var); |
| 1104 } | |
| 1105 } | |
| 1106 specbind (symbol, value); | |
| 1107 } | |
| 771 | 1108 return unbind_to_1 (speccount, Fprogn (body)); |
| 428 | 1109 } |
| 1110 | |
| 1111 DEFUN ("let", Flet, 1, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1112 Bind variables according to VARLIST then eval BODY. |
| 428 | 1113 The value of the last form in BODY is returned. |
| 1114 Each element of VARLIST is a symbol (which is bound to nil) | |
| 1115 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM). | |
| 1116 All the VALUEFORMs are evalled before any symbols are bound. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1117 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1118 arguments: (VARLIST &rest BODY) |
| 428 | 1119 */ |
| 1120 (args)) | |
| 1121 { | |
| 1122 /* This function can GC */ | |
| 1123 Lisp_Object varlist = XCAR (args); | |
| 1124 Lisp_Object body = XCDR (args); | |
| 1125 int speccount = specpdl_depth(); | |
| 1126 Lisp_Object *temps; | |
| 1127 int idx; | |
| 1128 struct gcpro gcpro1; | |
| 1129 | |
| 1130 /* Make space to hold the values to give the bound variables. */ | |
| 1131 { | |
| 1132 int varcount; | |
| 1133 GET_EXTERNAL_LIST_LENGTH (varlist, varcount); | |
| 1134 temps = alloca_array (Lisp_Object, varcount); | |
| 1135 } | |
| 1136 | |
| 1137 /* Compute the values and store them in `temps' */ | |
| 1138 GCPRO1 (*temps); | |
| 1139 gcpro1.nvars = 0; | |
| 1140 | |
| 1141 idx = 0; | |
| 442 | 1142 { |
| 1143 LIST_LOOP_2 (var, varlist) | |
| 1144 { | |
| 1145 Lisp_Object *value = &temps[idx++]; | |
| 1146 if (SYMBOLP (var)) | |
| 1147 *value = Qnil; | |
| 1148 else | |
| 1149 { | |
| 1150 Lisp_Object tem; | |
| 1151 CHECK_CONS (var); | |
| 1152 tem = XCDR (var); | |
| 1153 if (NILP (tem)) | |
| 1154 *value = Qnil; | |
| 1155 else | |
| 1156 { | |
| 1157 CHECK_CONS (tem); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1158 *value = IGNORE_MULTIPLE_VALUES (Feval (XCAR (tem))); |
| 442 | 1159 gcpro1.nvars = idx; |
| 1160 | |
| 1161 if (!NILP (XCDR (tem))) | |
| 563 | 1162 sferror |
| 442 | 1163 ("`let' bindings can have only one value-form", var); |
| 1164 } | |
| 1165 } | |
| 1166 } | |
| 1167 } | |
| 428 | 1168 |
| 1169 idx = 0; | |
| 442 | 1170 { |
| 1171 LIST_LOOP_2 (var, varlist) | |
| 1172 { | |
| 1173 specbind (SYMBOLP (var) ? var : XCAR (var), temps[idx++]); | |
| 1174 } | |
| 1175 } | |
| 428 | 1176 |
| 1177 UNGCPRO; | |
| 1178 | |
| 771 | 1179 return unbind_to_1 (speccount, Fprogn (body)); |
| 428 | 1180 } |
| 1181 | |
| 1182 DEFUN ("while", Fwhile, 1, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1183 If TEST yields non-nil, eval BODY... and repeat. |
| 428 | 1184 The order of execution is thus TEST, BODY, TEST, BODY and so on |
| 1185 until TEST returns nil. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1186 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1187 arguments: (TEST &rest BODY) |
| 428 | 1188 */ |
| 1189 (args)) | |
| 1190 { | |
| 1191 /* This function can GC */ | |
| 1192 Lisp_Object test = XCAR (args); | |
| 1193 Lisp_Object body = XCDR (args); | |
| 1194 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1195 while (!NILP (IGNORE_MULTIPLE_VALUES (Feval (test)))) |
| 428 | 1196 { |
| 1197 QUIT; | |
| 1198 Fprogn (body); | |
| 1199 } | |
| 1200 | |
| 1201 return Qnil; | |
| 1202 } | |
| 1203 | |
| 1204 DEFUN ("setq", Fsetq, 0, UNEVALLED, 0, /* | |
| 1205 \(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL. | |
| 1206 The symbols SYM are variables; they are literal (not evaluated). | |
| 1207 The values VAL are expressions; they are evaluated. | |
| 1208 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'. | |
| 1209 The second VAL is not computed until after the first SYM is set, and so on; | |
| 1210 each VAL can use the new value of variables set earlier in the `setq'. | |
| 1211 The return value of the `setq' form is the value of the last VAL. | |
| 1212 */ | |
| 1213 (args)) | |
| 1214 { | |
| 1215 /* This function can GC */ | |
| 1216 int nargs; | |
| 2421 | 1217 Lisp_Object retval = Qnil; |
| 428 | 1218 |
| 1219 GET_LIST_LENGTH (args, nargs); | |
| 1220 | |
| 1221 if (nargs & 1) /* Odd number of arguments? */ | |
| 1222 Fsignal (Qwrong_number_of_arguments, list2 (Qsetq, make_int (nargs))); | |
| 1223 | |
| 2421 | 1224 GC_PROPERTY_LIST_LOOP_3 (symbol, val, args) |
| 428 | 1225 { |
| 1226 val = Feval (val); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1227 val = IGNORE_MULTIPLE_VALUES (val); |
| 428 | 1228 Fset (symbol, val); |
| 2421 | 1229 retval = val; |
| 428 | 1230 } |
| 1231 | |
| 2421 | 1232 END_GC_PROPERTY_LIST_LOOP (symbol); |
| 1233 | |
| 1234 return retval; | |
| 428 | 1235 } |
| 1236 | |
| 1237 DEFUN ("quote", Fquote, 1, UNEVALLED, 0, /* | |
| 1238 Return the argument, without evaluating it. `(quote x)' yields `x'. | |
| 3794 | 1239 |
| 3842 | 1240 `quote' differs from `function' in that it is a hint that an expression is |
| 1241 data, not a function. In particular, under some circumstances the byte | |
| 1242 compiler will compile an expression quoted with `function', but it will | |
| 1243 never do so for an expression quoted with `quote'. These issues are most | |
| 1244 important for lambda expressions (see `lambda'). | |
| 1245 | |
| 1246 There is an alternative, more readable, reader syntax for `quote': a Lisp | |
| 1247 object preceded by `''. Thus, `'x' is equivalent to `(quote x)', in all | |
| 1248 contexts. A print function may use either. Internally the expression is | |
| 1249 represented as `(quote x)'). | |
| 428 | 1250 */ |
| 1251 (args)) | |
| 1252 { | |
| 1253 return XCAR (args); | |
| 1254 } | |
| 1255 | |
|
4744
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1256 /* Originally, this was just a function -- but `custom' used a garden- |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1257 variety version, so why not make it a subr? */ |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1258 DEFUN ("quote-maybe", Fquote_maybe, 1, 1, 0, /* |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1259 Quote EXPR if it is not self quoting. |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1260 |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1261 In contrast with `quote', this is a function, not a special form; its |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1262 argument is evaluated before `quote-maybe' is called. It returns either |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1263 EXPR (if it is self-quoting) or a list `(quote EXPR)' if it is not |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1264 self-quoting. Lists starting with the symbol `lambda' are regarded as |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1265 self-quoting. |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1266 */ |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1267 (expr)) |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1268 { |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1269 if ((XTYPE (expr)) == Lisp_Type_Record) |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1270 { |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1271 switch (XRECORD_LHEADER (expr)->type) |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1272 { |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1273 case lrecord_type_symbol: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1274 if (NILP (expr) || (EQ (expr, Qt)) || SYMBOL_IS_KEYWORD (expr)) |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1275 { |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1276 return expr; |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1277 } |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1278 break; |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1279 case lrecord_type_cons: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1280 if (EQ (XCAR (expr), Qlambda)) |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1281 { |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1282 return expr; |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1283 } |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1284 break; |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1285 |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1286 case lrecord_type_vector: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1287 case lrecord_type_string: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1288 case lrecord_type_compiled_function: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1289 case lrecord_type_bit_vector: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1290 case lrecord_type_float: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1291 case lrecord_type_hash_table: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1292 case lrecord_type_char_table: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1293 case lrecord_type_range_table: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1294 case lrecord_type_bignum: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1295 case lrecord_type_ratio: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1296 case lrecord_type_bigfloat: |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1297 return expr; |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1298 } |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1299 return list2 (Qquote, expr); |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1300 } |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1301 |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1302 /* Fixnums and characters are self-quoting: */ |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1303 return expr; |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1304 } |
|
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1305 |
| 428 | 1306 DEFUN ("function", Ffunction, 1, UNEVALLED, 0, /* |
| 3842 | 1307 Return the argument, without evaluating it. `(function x)' yields `x'. |
| 1308 | |
| 1309 `function' differs from `quote' in that it is a hint that an expression is | |
| 1310 a function, not data. In particular, under some circumstances the byte | |
| 1311 compiler will compile an expression quoted with `function', but it will | |
| 1312 never do so for an expression quoted with `quote'. However, the byte | |
| 1313 compiler will not compile an expression buried in a data structure such as | |
| 1314 a vector or a list which is not syntactically a function. These issues are | |
| 1315 most important for lambda expressions (see `lambda'). | |
| 1316 | |
| 1317 There is an alternative, more readable, reader syntax for `function': a Lisp | |
| 1318 object preceded by `#''. Thus, #'x is equivalent to (function x), in all | |
| 1319 contexts. A print function may use either. Internally the expression is | |
| 1320 represented as `(function x)'). | |
| 428 | 1321 */ |
| 1322 (args)) | |
| 1323 { | |
| 1324 return XCAR (args); | |
| 1325 } | |
| 1326 | |
| 1327 | |
| 1328 /************************************************************************/ | |
| 1329 /* Defining functions/variables */ | |
| 1330 /************************************************************************/ | |
| 1331 static Lisp_Object | |
| 1332 define_function (Lisp_Object name, Lisp_Object defn) | |
| 1333 { | |
| 1334 Ffset (name, defn); | |
|
4535
69a1eda3da06
Distinguish vars and functions in #'symbol-file, #'describe-{function,variable}
Aidan Kehoe <kehoea@parhasard.net>
parents:
4502
diff
changeset
|
1335 LOADHIST_ATTACH (Fcons (Qdefun, name)); |
| 428 | 1336 return name; |
| 1337 } | |
| 1338 | |
| 1339 DEFUN ("defun", Fdefun, 2, UNEVALLED, 0, /* | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1340 Define NAME as a function. |
| 428 | 1341 The definition is (lambda ARGLIST [DOCSTRING] BODY...). |
| 1342 See also the function `interactive'. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1343 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1344 arguments: (NAME ARGLIST &optional DOCSTRING &rest BODY) |
| 428 | 1345 */ |
| 1346 (args)) | |
| 1347 { | |
| 1348 /* This function can GC */ | |
| 1349 return define_function (XCAR (args), | |
| 1350 Fcons (Qlambda, XCDR (args))); | |
| 1351 } | |
| 1352 | |
| 1353 DEFUN ("defmacro", Fdefmacro, 2, UNEVALLED, 0, /* | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1354 Define NAME as a macro. |
| 428 | 1355 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...). |
| 1356 When the macro is called, as in (NAME ARGS...), | |
| 1357 the function (lambda ARGLIST BODY...) is applied to | |
| 1358 the list ARGS... as it appears in the expression, | |
| 1359 and the result should be a form to be evaluated instead of the original. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1360 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1361 arguments: (NAME ARGLIST &optional DOCSTRING &rest BODY) |
| 428 | 1362 */ |
| 1363 (args)) | |
| 1364 { | |
| 1365 /* This function can GC */ | |
| 1366 return define_function (XCAR (args), | |
| 1367 Fcons (Qmacro, Fcons (Qlambda, XCDR (args)))); | |
| 1368 } | |
| 1369 | |
| 1370 DEFUN ("defvar", Fdefvar, 1, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1371 Define SYMBOL as a variable. |
| 428 | 1372 You are not required to define a variable in order to use it, |
| 1373 but the definition can supply documentation and an initial value | |
| 1374 in a way that tags can recognize. | |
| 1375 | |
| 1376 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is | |
| 1377 void. (However, when you evaluate a defvar interactively, it acts like a | |
| 1378 defconst: SYMBOL's value is always set regardless of whether it's currently | |
| 1379 void.) | |
| 1380 If SYMBOL is buffer-local, its default value is what is set; | |
| 1381 buffer-local values are not affected. | |
| 1382 INITVALUE and DOCSTRING are optional. | |
| 1383 If DOCSTRING starts with *, this variable is identified as a user option. | |
| 442 | 1384 This means that M-x set-variable recognizes it. |
| 428 | 1385 If INITVALUE is missing, SYMBOL's value is not set. |
| 1386 | |
| 1387 In lisp-interaction-mode defvar is treated as defconst. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1388 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1389 arguments: (SYMBOL &optional INITVALUE DOCSTRING) |
| 428 | 1390 */ |
| 1391 (args)) | |
| 1392 { | |
| 1393 /* This function can GC */ | |
| 1394 Lisp_Object sym = XCAR (args); | |
| 1395 | |
| 1396 if (!NILP (args = XCDR (args))) | |
| 1397 { | |
| 1398 Lisp_Object val = XCAR (args); | |
| 1399 | |
| 1400 if (NILP (Fdefault_boundp (sym))) | |
| 1401 { | |
| 1402 struct gcpro gcpro1; | |
| 1403 GCPRO1 (val); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1404 val = IGNORE_MULTIPLE_VALUES (Feval (val)); |
| 428 | 1405 Fset_default (sym, val); |
| 1406 UNGCPRO; | |
| 1407 } | |
| 1408 | |
| 1409 if (!NILP (args = XCDR (args))) | |
| 1410 { | |
| 1411 Lisp_Object doc = XCAR (args); | |
| 1412 Fput (sym, Qvariable_documentation, doc); | |
| 1413 if (!NILP (args = XCDR (args))) | |
| 563 | 1414 signal_error (Qwrong_number_of_arguments, "too many arguments", Qunbound); |
| 428 | 1415 } |
| 1416 } | |
| 1417 | |
| 1418 #ifdef I18N3 | |
| 1419 if (!NILP (Vfile_domain)) | |
| 1420 Fput (sym, Qvariable_domain, Vfile_domain); | |
| 1421 #endif | |
| 1422 | |
| 1423 LOADHIST_ATTACH (sym); | |
| 1424 return sym; | |
| 1425 } | |
| 1426 | |
| 1427 DEFUN ("defconst", Fdefconst, 2, UNEVALLED, 0, /* | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1428 Define SYMBOL as a constant variable. |
| 428 | 1429 The intent is that programs do not change this value, but users may. |
| 1430 Always sets the value of SYMBOL to the result of evalling INITVALUE. | |
| 1431 If SYMBOL is buffer-local, its default value is what is set; | |
| 1432 buffer-local values are not affected. | |
| 1433 DOCSTRING is optional. | |
| 1434 If DOCSTRING starts with *, this variable is identified as a user option. | |
| 442 | 1435 This means that M-x set-variable recognizes it. |
| 428 | 1436 |
| 1437 Note: do not use `defconst' for user options in libraries that are not | |
| 1438 normally loaded, since it is useful for users to be able to specify | |
| 1439 their own values for such variables before loading the library. | |
| 1440 Since `defconst' unconditionally assigns the variable, | |
| 1441 it would override the user's choice. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1442 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
1443 arguments: (SYMBOL &optional INITVALUE DOCSTRING) |
| 428 | 1444 */ |
| 1445 (args)) | |
| 1446 { | |
| 1447 /* This function can GC */ | |
| 1448 Lisp_Object sym = XCAR (args); | |
| 1449 Lisp_Object val = Feval (XCAR (args = XCDR (args))); | |
| 1450 struct gcpro gcpro1; | |
| 1451 | |
| 1452 GCPRO1 (val); | |
| 1453 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1454 val = IGNORE_MULTIPLE_VALUES (val); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1455 |
| 428 | 1456 Fset_default (sym, val); |
| 1457 | |
| 1458 UNGCPRO; | |
| 1459 | |
| 1460 if (!NILP (args = XCDR (args))) | |
| 1461 { | |
| 1462 Lisp_Object doc = XCAR (args); | |
| 1463 Fput (sym, Qvariable_documentation, doc); | |
| 1464 if (!NILP (args = XCDR (args))) | |
| 563 | 1465 signal_error (Qwrong_number_of_arguments, "too many arguments", Qunbound); |
| 428 | 1466 } |
| 1467 | |
| 1468 #ifdef I18N3 | |
| 1469 if (!NILP (Vfile_domain)) | |
| 1470 Fput (sym, Qvariable_domain, Vfile_domain); | |
| 1471 #endif | |
| 1472 | |
| 1473 LOADHIST_ATTACH (sym); | |
| 1474 return sym; | |
| 1475 } | |
| 1476 | |
|
4502
8748a3f7ceb4
Handle varalias chains, custom variables in #'user-variable-p.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4162
diff
changeset
|
1477 /* XEmacs: user-variable-p is in symbols.c, since it needs to mess around |
|
8748a3f7ceb4
Handle varalias chains, custom variables in #'user-variable-p.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4162
diff
changeset
|
1478 with the symbol variable aliases. */ |
| 428 | 1479 |
| 1480 DEFUN ("macroexpand-internal", Fmacroexpand_internal, 1, 2, 0, /* | |
| 1481 Return result of expanding macros at top level of FORM. | |
| 1482 If FORM is not a macro call, it is returned unchanged. | |
| 1483 Otherwise, the macro is expanded and the expansion is considered | |
| 1484 in place of FORM. When a non-macro-call results, it is returned. | |
| 1485 | |
| 442 | 1486 The second optional arg ENVIRONMENT specifies an environment of macro |
| 428 | 1487 definitions to shadow the loaded ones for use in file byte-compilation. |
| 1488 */ | |
| 442 | 1489 (form, environment)) |
| 428 | 1490 { |
| 1491 /* This function can GC */ | |
| 1492 /* With cleanups from Hallvard Furuseth. */ | |
| 1493 REGISTER Lisp_Object expander, sym, def, tem; | |
| 1494 | |
| 1495 while (1) | |
| 1496 { | |
| 1497 /* Come back here each time we expand a macro call, | |
| 1498 in case it expands into another macro call. */ | |
| 1499 if (!CONSP (form)) | |
| 1500 break; | |
| 1501 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */ | |
| 1502 def = sym = XCAR (form); | |
| 1503 tem = Qnil; | |
| 1504 /* Trace symbols aliases to other symbols | |
| 1505 until we get a symbol that is not an alias. */ | |
| 1506 while (SYMBOLP (def)) | |
| 1507 { | |
| 1508 QUIT; | |
| 1509 sym = def; | |
| 442 | 1510 tem = Fassq (sym, environment); |
| 428 | 1511 if (NILP (tem)) |
| 1512 { | |
| 1513 def = XSYMBOL (sym)->function; | |
| 1514 if (!UNBOUNDP (def)) | |
| 1515 continue; | |
| 1516 } | |
| 1517 break; | |
| 1518 } | |
| 442 | 1519 /* Right now TEM is the result from SYM in ENVIRONMENT, |
| 428 | 1520 and if TEM is nil then DEF is SYM's function definition. */ |
| 1521 if (NILP (tem)) | |
| 1522 { | |
| 442 | 1523 /* SYM is not mentioned in ENVIRONMENT. |
| 428 | 1524 Look at its function definition. */ |
| 1525 if (UNBOUNDP (def) | |
| 1526 || !CONSP (def)) | |
| 1527 /* Not defined or definition not suitable */ | |
| 1528 break; | |
| 1529 if (EQ (XCAR (def), Qautoload)) | |
| 1530 { | |
| 1531 /* Autoloading function: will it be a macro when loaded? */ | |
| 1532 tem = Felt (def, make_int (4)); | |
| 1533 if (EQ (tem, Qt) || EQ (tem, Qmacro)) | |
| 1534 { | |
| 1535 /* Yes, load it and try again. */ | |
| 970 | 1536 /* do_autoload GCPROs both arguments */ |
| 428 | 1537 do_autoload (def, sym); |
| 1538 continue; | |
| 1539 } | |
| 1540 else | |
| 1541 break; | |
| 1542 } | |
| 1543 else if (!EQ (XCAR (def), Qmacro)) | |
| 1544 break; | |
| 1545 else expander = XCDR (def); | |
| 1546 } | |
| 1547 else | |
| 1548 { | |
| 1549 expander = XCDR (tem); | |
| 1550 if (NILP (expander)) | |
| 1551 break; | |
| 1552 } | |
| 1553 form = apply1 (expander, XCDR (form)); | |
| 1554 } | |
| 1555 return form; | |
| 1556 } | |
| 1557 | |
| 1558 | |
| 1559 /************************************************************************/ | |
| 1560 /* Non-local exits */ | |
| 1561 /************************************************************************/ | |
| 1562 | |
| 1318 | 1563 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS |
| 1564 | |
| 1565 int | |
| 1566 proper_redisplay_wrapping_in_place (void) | |
| 1567 { | |
| 1568 return !in_display | |
| 1569 || ((get_inhibit_flags () & INTERNAL_INHIBIT_ERRORS) | |
| 1570 && (get_inhibit_flags () & INTERNAL_INHIBIT_THROWS)); | |
| 1571 } | |
| 1572 | |
| 1573 static void | |
| 1574 check_proper_critical_section_nonlocal_exit_protection (void) | |
| 1575 { | |
| 1576 assert_with_message | |
| 1577 (proper_redisplay_wrapping_in_place (), | |
| 1578 "Attempted non-local exit from within redisplay without being properly wrapped"); | |
| 1579 } | |
| 1580 | |
| 1581 static void | |
| 1582 check_proper_critical_section_lisp_protection (void) | |
| 1583 { | |
| 1584 assert_with_message | |
| 1585 (proper_redisplay_wrapping_in_place (), | |
| 1586 "Attempt to call Lisp code from within redisplay without being properly wrapped"); | |
| 1587 } | |
| 1588 | |
| 1589 #endif /* ERROR_CHECK_TRAPPING_PROBLEMS */ | |
| 1590 | |
| 428 | 1591 DEFUN ("catch", Fcatch, 1, UNEVALLED, 0, /* |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1592 Eval BODY allowing nonlocal exits using `throw'. |
| 428 | 1593 TAG is evalled to get the tag to use. Then the BODY is executed. |
| 3577 | 1594 Within BODY, (throw TAG VAL) with same (`eq') tag exits BODY and this `catch'. |
| 428 | 1595 If no throw happens, `catch' returns the value of the last BODY form. |
| 1596 If a throw happens, it specifies the value to return from `catch'. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1597 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1598 arguments: (TAG &rest BODY) |
| 428 | 1599 */ |
| 1600 (args)) | |
| 1601 { | |
| 1602 /* This function can GC */ | |
| 1603 Lisp_Object tag = Feval (XCAR (args)); | |
| 1604 Lisp_Object body = XCDR (args); | |
| 2532 | 1605 return internal_catch (tag, Fprogn, body, 0, 0, 0); |
| 428 | 1606 } |
| 1607 | |
| 1608 /* Set up a catch, then call C function FUNC on argument ARG. | |
| 1609 FUNC should return a Lisp_Object. | |
| 1610 This is how catches are done from within C code. */ | |
| 1611 | |
| 1612 Lisp_Object | |
| 1613 internal_catch (Lisp_Object tag, | |
| 1614 Lisp_Object (*func) (Lisp_Object arg), | |
| 1615 Lisp_Object arg, | |
| 853 | 1616 int * volatile threw, |
| 2532 | 1617 Lisp_Object * volatile thrown_tag, |
| 1618 Lisp_Object * volatile backtrace_before_throw) | |
| 428 | 1619 { |
| 1620 /* This structure is made part of the chain `catchlist'. */ | |
| 1621 struct catchtag c; | |
| 1622 | |
| 1623 /* Fill in the components of c, and put it on the list. */ | |
| 1624 c.next = catchlist; | |
| 1625 c.tag = tag; | |
| 853 | 1626 c.actual_tag = Qnil; |
| 2532 | 1627 c.backtrace = Qnil; |
| 428 | 1628 c.val = Qnil; |
| 1629 c.backlist = backtrace_list; | |
| 1630 #if 0 /* FSFmacs */ | |
| 1631 /* #### */ | |
| 1632 c.handlerlist = handlerlist; | |
| 1633 #endif | |
| 1634 c.lisp_eval_depth = lisp_eval_depth; | |
| 1635 c.pdlcount = specpdl_depth(); | |
| 1636 #if 0 /* FSFmacs */ | |
| 1637 c.poll_suppress_count = async_timer_suppress_count; | |
| 1638 #endif | |
| 1639 c.gcpro = gcprolist; | |
| 1640 catchlist = &c; | |
| 1641 | |
| 1642 /* Call FUNC. */ | |
| 1643 if (SETJMP (c.jmp)) | |
| 1644 { | |
| 1645 /* Throw works by a longjmp that comes right here. */ | |
| 1646 if (threw) *threw = 1; | |
| 853 | 1647 if (thrown_tag) *thrown_tag = c.actual_tag; |
| 2532 | 1648 if (backtrace_before_throw) *backtrace_before_throw = c.backtrace; |
| 428 | 1649 return c.val; |
| 1650 } | |
| 1651 c.val = (*func) (arg); | |
| 1652 if (threw) *threw = 0; | |
| 853 | 1653 if (thrown_tag) *thrown_tag = Qnil; |
| 428 | 1654 catchlist = c.next; |
| 853 | 1655 check_catchlist_sanity (); |
| 428 | 1656 return c.val; |
| 1657 } | |
| 1658 | |
| 1659 | |
| 1660 /* Unwind the specbind, catch, and handler stacks back to CATCH, and | |
| 1661 jump to that CATCH, returning VALUE as the value of that catch. | |
| 1662 | |
| 2297 | 1663 This is the guts of Fthrow and Fsignal; they differ only in the |
| 1664 way they choose the catch tag to throw to. A catch tag for a | |
| 428 | 1665 condition-case form has a TAG of Qnil. |
| 1666 | |
| 1667 Before each catch is discarded, unbind all special bindings and | |
| 1668 execute all unwind-protect clauses made above that catch. Unwind | |
| 1669 the handler stack as we go, so that the proper handlers are in | |
| 1670 effect for each unwind-protect clause we run. At the end, restore | |
| 1671 some static info saved in CATCH, and longjmp to the location | |
| 1672 specified in the | |
| 1673 | |
| 1674 This is used for correct unwinding in Fthrow and Fsignal. */ | |
| 1675 | |
| 2268 | 1676 static DECLARE_DOESNT_RETURN (unwind_to_catch (struct catchtag *, Lisp_Object, |
| 1677 Lisp_Object)); | |
| 1678 | |
| 1679 static DOESNT_RETURN | |
| 853 | 1680 unwind_to_catch (struct catchtag *c, Lisp_Object val, Lisp_Object tag) |
| 428 | 1681 { |
| 1682 REGISTER int last_time; | |
| 1683 | |
| 1684 /* Unwind the specbind, catch, and handler stacks back to CATCH | |
| 1685 Before each catch is discarded, unbind all special bindings | |
| 1686 and execute all unwind-protect clauses made above that catch. | |
| 1687 At the end, restore some static info saved in CATCH, | |
| 1688 and longjmp to the location specified. | |
| 1689 */ | |
| 1690 | |
| 1691 /* Save the value somewhere it will be GC'ed. | |
| 1692 (Can't overwrite tag slot because an unwind-protect may | |
| 1693 want to throw to this same tag, which isn't yet invalid.) */ | |
| 1694 c->val = val; | |
| 853 | 1695 c->actual_tag = tag; |
| 428 | 1696 |
| 1697 #if 0 /* FSFmacs */ | |
| 1698 /* Restore the polling-suppression count. */ | |
| 1699 set_poll_suppress_count (catch->poll_suppress_count); | |
| 1700 #endif | |
| 1701 | |
| 617 | 1702 #if 1 |
| 428 | 1703 do |
| 1704 { | |
| 1705 last_time = catchlist == c; | |
| 1706 | |
| 1707 /* Unwind the specpdl stack, and then restore the proper set of | |
| 1708 handlers. */ | |
| 771 | 1709 unbind_to (catchlist->pdlcount); |
| 428 | 1710 catchlist = catchlist->next; |
| 853 | 1711 check_catchlist_sanity (); |
| 428 | 1712 } |
| 1713 while (! last_time); | |
| 617 | 1714 #else |
| 1715 /* Former XEmacs code. This is definitely not as correct because | |
| 1716 there may be a number of catches we're unwinding, and a number | |
| 1717 of unwind-protects in the process. By not undoing the catches till | |
| 1718 the end, there may be invalid catches still current. (This would | |
| 1719 be a particular problem with code like this: | |
| 1720 | |
| 1721 (catch 'foo | |
| 1722 (call-some-code-which-does... | |
| 1723 (catch 'bar | |
| 1724 (unwind-protect | |
| 1725 (call-some-code-which-does... | |
| 1726 (catch 'bar | |
| 1727 (call-some-code-which-does... | |
| 1728 (throw 'foo nil)))) | |
| 1729 (throw 'bar nil))))) | |
| 1730 | |
| 1731 This would try to throw to the inner (catch 'bar)! | |
| 1732 | |
| 1733 --ben | |
| 1734 */ | |
| 428 | 1735 /* Unwind the specpdl stack */ |
| 771 | 1736 unbind_to (c->pdlcount); |
| 428 | 1737 catchlist = c->next; |
| 853 | 1738 check_catchlist_sanity (); |
| 617 | 1739 #endif /* Former code */ |
| 428 | 1740 |
| 1204 | 1741 UNWIND_GCPRO_TO (c->gcpro); |
| 1292 | 1742 if (profiling_active) |
| 1743 { | |
| 1744 while (backtrace_list != c->backlist) | |
| 1745 { | |
| 1746 profile_record_unwind (backtrace_list); | |
| 1747 backtrace_list = backtrace_list->next; | |
| 1748 } | |
| 1749 } | |
| 1750 else | |
| 1751 backtrace_list = c->backlist; | |
| 428 | 1752 lisp_eval_depth = c->lisp_eval_depth; |
| 1753 | |
| 442 | 1754 #ifdef DEFEND_AGAINST_THROW_RECURSION |
| 428 | 1755 throw_level = 0; |
| 1756 #endif | |
| 1757 LONGJMP (c->jmp, 1); | |
| 1758 } | |
| 1759 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1760 DECLARE_DOESNT_RETURN (throw_or_bomb_out (Lisp_Object, Lisp_Object, int, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1761 Lisp_Object, Lisp_Object)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1762 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1763 DOESNT_RETURN |
| 428 | 1764 throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p, |
| 1765 Lisp_Object sig, Lisp_Object data) | |
| 1766 { | |
| 442 | 1767 #ifdef DEFEND_AGAINST_THROW_RECURSION |
| 428 | 1768 /* die if we recurse more than is reasonable */ |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
5016
diff
changeset
|
1769 assert (++throw_level <= 20); |
| 428 | 1770 #endif |
| 1771 | |
| 1318 | 1772 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS |
| 1123 | 1773 check_proper_critical_section_nonlocal_exit_protection (); |
| 1318 | 1774 #endif |
| 1123 | 1775 |
| 428 | 1776 /* If bomb_out_p is t, this is being called from Fsignal as a |
| 1777 "last resort" when there is no handler for this error and | |
| 1778 the debugger couldn't be invoked, so we are throwing to | |
| 3025 | 1779 `top-level'. If this tag doesn't exist (happens during the |
| 428 | 1780 initialization stages) we would get in an infinite recursive |
| 1781 Fsignal/Fthrow loop, so instead we bomb out to the | |
| 1782 really-early-error-handler. | |
| 1783 | |
| 1784 Note that in fact the only time that the "last resort" | |
| 3025 | 1785 occurs is when there's no catch for `top-level' -- the |
| 1786 `top-level' catch and the catch-all error handler are | |
| 428 | 1787 established at the same time, in initial_command_loop/ |
| 1788 top_level_1. | |
| 1789 | |
| 853 | 1790 [[#### Fix this horrifitude!]] |
| 1791 | |
| 1792 I don't think this is horrifitude, just defensive programming. --ben | |
| 428 | 1793 */ |
| 1794 | |
| 1795 while (1) | |
| 1796 { | |
| 1797 REGISTER struct catchtag *c; | |
| 1798 | |
| 1799 #if 0 /* FSFmacs */ | |
| 1800 if (!NILP (tag)) /* #### */ | |
| 1801 #endif | |
| 1802 for (c = catchlist; c; c = c->next) | |
| 1803 { | |
| 2532 | 1804 if (EQ (c->tag, Vcatch_everything_tag)) |
| 1805 c->backtrace = maybe_get_trapping_problems_backtrace (); | |
| 853 | 1806 if (EQ (c->tag, tag) || EQ (c->tag, Vcatch_everything_tag)) |
| 1807 unwind_to_catch (c, val, tag); | |
| 428 | 1808 } |
| 1809 if (!bomb_out_p) | |
| 1810 tag = Fsignal (Qno_catch, list2 (tag, val)); | |
| 1811 else | |
| 1812 call1 (Qreally_early_error_handler, Fcons (sig, data)); | |
| 1813 } | |
| 1814 } | |
| 1815 | |
| 1816 /* See above, where CATCHLIST is defined, for a description of how | |
| 1817 Fthrow() works. | |
| 1818 | |
| 1819 Fthrow() is also called by Fsignal(), to do a non-local jump | |
| 1820 back to the appropriate condition-case handler after (maybe) | |
| 1821 the debugger is entered. In that case, TAG is the value | |
| 1822 of Vcondition_handlers that was in place just after the | |
| 1823 condition-case handler was set up. The car of this will be | |
| 1824 some data referring to the handler: Its car will be Qunbound | |
| 1825 (thus, this tag can never be generated by Lisp code), and | |
| 1826 its CDR will be the HANDLERS argument to condition_case_1() | |
| 1827 (either Qerror, Qt, or a list of handlers as in `condition-case'). | |
| 1828 This works fine because Fthrow() does not care what TAG was | |
| 1829 passed to it: it just looks up the catch list for something | |
| 1830 that is EQ() to TAG. When it finds it, it will longjmp() | |
| 1831 back to the place that established the catch (in this case, | |
| 1832 condition_case_1). See below for more info. | |
| 1833 */ | |
| 1834 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1835 DEFUN_NORETURN ("throw", Fthrow, 2, UNEVALLED, 0, /* |
| 444 | 1836 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
|
1837 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1838 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
|
1839 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
|
1840 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1841 arguments: (TAG VALUE) |
| 428 | 1842 */ |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1843 (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1844 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1845 int nargs; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1846 Lisp_Object tag, value; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1847 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1848 GET_LIST_LENGTH (args, nargs); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1849 if (nargs != 2) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1850 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1851 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
|
1852 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1853 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1854 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
|
1855 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1856 value = Feval (XCAR (XCDR (args))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
1857 |
| 444 | 1858 throw_or_bomb_out (tag, value, 0, Qnil, Qnil); /* Doesn't return */ |
| 2268 | 1859 RETURN_NOT_REACHED (Qnil); |
| 428 | 1860 } |
| 1861 | |
| 1862 DEFUN ("unwind-protect", Funwind_protect, 1, UNEVALLED, 0, /* | |
| 1863 Do BODYFORM, protecting with UNWINDFORMS. | |
| 1864 If BODYFORM completes normally, its value is returned | |
| 1865 after executing the UNWINDFORMS. | |
| 1866 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
|
1867 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
1868 arguments: (BODYFORM &rest UNWINDFORMS) |
| 428 | 1869 */ |
| 1870 (args)) | |
| 1871 { | |
| 1872 /* This function can GC */ | |
| 1873 int speccount = specpdl_depth(); | |
| 1874 | |
| 1875 record_unwind_protect (Fprogn, XCDR (args)); | |
| 771 | 1876 return unbind_to_1 (speccount, Feval (XCAR (args))); |
| 428 | 1877 } |
| 1878 | |
| 1879 | |
| 1880 /************************************************************************/ | |
| 1292 | 1881 /* Trapping errors */ |
| 428 | 1882 /************************************************************************/ |
| 1883 | |
| 1884 static Lisp_Object | |
| 1885 condition_bind_unwind (Lisp_Object loser) | |
| 1886 { | |
| 617 | 1887 /* There is no problem freeing stuff here like there is in |
| 1888 condition_case_unwind(), because there are no outside pointers | |
| 1889 (like the tag below in the catchlist) pointing to the objects. */ | |
| 853 | 1890 |
| 428 | 1891 /* ((handler-fun . handler-args) ... other handlers) */ |
| 1892 Lisp_Object tem = XCAR (loser); | |
| 853 | 1893 int first = 1; |
| 428 | 1894 |
| 1895 while (CONSP (tem)) | |
| 1896 { | |
| 853 | 1897 Lisp_Object victim = tem; |
| 1898 if (first && OPAQUE_PTRP (XCAR (victim))) | |
| 1899 free_opaque_ptr (XCAR (victim)); | |
| 1900 first = 0; | |
| 1901 tem = XCDR (victim); | |
| 428 | 1902 free_cons (victim); |
| 1903 } | |
| 1904 | |
| 1905 if (EQ (loser, Vcondition_handlers)) /* may have been rebound to some tail */ | |
| 853 | 1906 Vcondition_handlers = XCDR (loser); |
| 1907 | |
| 1908 free_cons (loser); | |
| 428 | 1909 return Qnil; |
| 1910 } | |
| 1911 | |
| 1912 static Lisp_Object | |
| 1913 condition_case_unwind (Lisp_Object loser) | |
| 1914 { | |
| 1915 /* ((<unbound> . clauses) ... other handlers */ | |
| 617 | 1916 /* NO! Doing this now leaves the tag deleted in a still-active |
| 1917 catch. With the recent changes to unwind_to_catch(), the | |
| 1918 evil situation might not happen any more; it certainly could | |
| 1919 happen before because it did. But it's very precarious to rely | |
| 1920 on something like this. #### Instead we should rewrite, adopting | |
| 1921 the FSF's mechanism with a struct handler instead of | |
| 1922 Vcondition_handlers; then we have NO Lisp-object structures used | |
| 1923 to hold all of the values, and there's no possibility either of | |
| 1924 crashes from freeing objects too quickly, or objects not getting | |
| 1925 freed and hanging around till the next GC. | |
| 1926 | |
| 1927 In practice, the extra consing here should not matter because | |
| 1928 it only happens when we throw past the condition-case, which almost | |
| 1929 always is the result of an error. Most of the time, there will be | |
| 1930 no error, and we will free the objects below in the main function. | |
| 1931 | |
| 1932 --ben | |
| 1933 | |
| 1934 DO NOT DO: free_cons (XCAR (loser)); | |
| 1935 */ | |
| 1936 | |
| 428 | 1937 if (EQ (loser, Vcondition_handlers)) /* may have been rebound to some tail */ |
| 617 | 1938 Vcondition_handlers = XCDR (loser); |
| 1939 | |
| 1940 /* DO NOT DO: free_cons (loser); */ | |
| 428 | 1941 return Qnil; |
| 1942 } | |
| 1943 | |
| 1944 /* Split out from condition_case_3 so that primitive C callers | |
| 1945 don't have to cons up a lisp handler form to be evaluated. */ | |
| 1946 | |
| 1947 /* Call a function BFUN of one argument BARG, trapping errors as | |
| 1948 specified by HANDLERS. If no error occurs that is indicated by | |
| 1949 HANDLERS as something to be caught, the return value of this | |
| 1950 function is the return value from BFUN. If such an error does | |
| 1951 occur, HFUN is called, and its return value becomes the | |
| 1952 return value of condition_case_1(). The second argument passed | |
| 1953 to HFUN will always be HARG. The first argument depends on | |
| 1954 HANDLERS: | |
| 1955 | |
| 1956 If HANDLERS is Qt, all errors (this includes QUIT, but not | |
| 1957 non-local exits with `throw') cause HFUN to be invoked, and VAL | |
| 1958 (the first argument to HFUN) is a cons (SIG . DATA) of the | |
| 1959 arguments passed to `signal'. The debugger is not invoked even if | |
| 1960 `debug-on-error' was set. | |
| 1961 | |
| 1962 A HANDLERS value of Qerror is the same as Qt except that the | |
| 1963 debugger is invoked if `debug-on-error' was set. | |
| 1964 | |
| 1965 Otherwise, HANDLERS should be a list of lists (CONDITION-NAME BODY ...) | |
| 1966 exactly as in `condition-case', and errors will be trapped | |
| 1967 as indicated in HANDLERS. VAL (the first argument to HFUN) will | |
| 1968 be a cons whose car is the cons (SIG . DATA) and whose CDR is the | |
| 1969 list (BODY ...) from the appropriate slot in HANDLERS. | |
| 1970 | |
| 1971 This function pushes HANDLERS onto the front of Vcondition_handlers | |
| 1972 (actually with a Qunbound marker as well -- see Fthrow() above | |
| 1973 for why), establishes a catch whose tag is this new value of | |
| 1974 Vcondition_handlers, and calls BFUN. When Fsignal() is called, | |
| 1975 it calls Fthrow(), setting TAG to this same new value of | |
| 1976 Vcondition_handlers and setting VAL to the same thing that will | |
| 1977 be passed to HFUN, as above. Fthrow() longjmp()s back to the | |
| 1978 jump point we just established, and we in turn just call the | |
| 1979 HFUN and return its value. | |
| 1980 | |
| 1981 For a real condition-case, HFUN will always be | |
| 1982 run_condition_case_handlers() and HARG is the argument VAR | |
| 1983 to condition-case. That function just binds VAR to the cons | |
| 1984 (SIG . DATA) that is the CAR of VAL, and calls the handler | |
| 1985 (BODY ...) that is the CDR of VAL. Note that before calling | |
| 1986 Fthrow(), Fsignal() restored Vcondition_handlers to the value | |
| 1987 it had *before* condition_case_1() was called. This maintains | |
| 1988 consistency (so that the state of things at exit of | |
| 1989 condition_case_1() is the same as at entry), and implies | |
| 1990 that the handler can signal the same error again (possibly | |
| 1991 after processing of its own), without getting in an infinite | |
| 1992 loop. */ | |
| 1993 | |
| 1994 Lisp_Object | |
| 1995 condition_case_1 (Lisp_Object handlers, | |
| 1996 Lisp_Object (*bfun) (Lisp_Object barg), | |
| 1997 Lisp_Object barg, | |
| 1998 Lisp_Object (*hfun) (Lisp_Object val, Lisp_Object harg), | |
| 1999 Lisp_Object harg) | |
| 2000 { | |
| 2001 int speccount = specpdl_depth(); | |
| 2002 struct catchtag c; | |
| 617 | 2003 struct gcpro gcpro1, gcpro2, gcpro3; |
| 428 | 2004 |
| 2005 #if 0 /* FSFmacs */ | |
| 2006 c.tag = Qnil; | |
| 2007 #else | |
| 2008 /* Do consing now so out-of-memory error happens up front */ | |
| 2009 /* (unbound . stuff) is a special condition-case kludge marker | |
| 2010 which is known specially by Fsignal. | |
| 617 | 2011 [[ This is an abomination, but to fix it would require either |
| 428 | 2012 making condition_case cons (a union of the conditions of the clauses) |
| 617 | 2013 or changing the byte-compiler output (no thanks).]] |
| 2014 | |
| 2015 The above comment is clearly wrong. FSF does not do it this way | |
| 2016 and did not change the byte-compiler output. Instead they use a | |
| 2017 `struct handler' to hold the various values (in place of our | |
| 2018 Vcondition_handlers) and chain them together, with pointers from | |
| 2019 the `struct catchtag' to the `struct handler'. We should perhaps | |
| 2020 consider moving to something similar, but not before I merge my | |
| 2021 stderr-proc workspace, which contains changes to these | |
| 2022 functions. --ben */ | |
| 428 | 2023 c.tag = noseeum_cons (noseeum_cons (Qunbound, handlers), |
| 2024 Vcondition_handlers); | |
| 2025 #endif | |
| 2026 c.val = Qnil; | |
| 853 | 2027 c.actual_tag = Qnil; |
| 2532 | 2028 c.backtrace = Qnil; |
| 428 | 2029 c.backlist = backtrace_list; |
| 2030 #if 0 /* FSFmacs */ | |
| 2031 /* #### */ | |
| 2032 c.handlerlist = handlerlist; | |
| 2033 #endif | |
| 2034 c.lisp_eval_depth = lisp_eval_depth; | |
| 2035 c.pdlcount = specpdl_depth(); | |
| 2036 #if 0 /* FSFmacs */ | |
| 2037 c.poll_suppress_count = async_timer_suppress_count; | |
| 2038 #endif | |
| 2039 c.gcpro = gcprolist; | |
| 2040 /* #### FSFmacs does the following statement *after* the setjmp(). */ | |
| 2041 c.next = catchlist; | |
| 2042 | |
| 2043 if (SETJMP (c.jmp)) | |
| 2044 { | |
| 2045 /* throw does ungcpro, etc */ | |
| 2046 return (*hfun) (c.val, harg); | |
| 2047 } | |
| 2048 | |
| 2049 record_unwind_protect (condition_case_unwind, c.tag); | |
| 2050 | |
| 2051 catchlist = &c; | |
| 2052 #if 0 /* FSFmacs */ | |
| 2053 h.handler = handlers; | |
| 2054 h.var = Qnil; | |
| 2055 h.next = handlerlist; | |
| 2056 h.tag = &c; | |
| 2057 handlerlist = &h; | |
| 2058 #else | |
| 2059 Vcondition_handlers = c.tag; | |
| 2060 #endif | |
| 2061 GCPRO1 (harg); /* Somebody has to gc-protect */ | |
| 2062 c.val = ((*bfun) (barg)); | |
| 2063 UNGCPRO; | |
| 617 | 2064 |
| 2065 /* Once we change `catchlist' below, the stuff in c will not be GCPRO'd. */ | |
| 2066 GCPRO3 (harg, c.val, c.tag); | |
| 2067 | |
| 428 | 2068 catchlist = c.next; |
| 853 | 2069 check_catchlist_sanity (); |
| 617 | 2070 /* Note: The unbind also resets Vcondition_handlers. Maybe we should |
| 2071 delete this here. */ | |
| 428 | 2072 Vcondition_handlers = XCDR (c.tag); |
| 771 | 2073 unbind_to (speccount); |
| 617 | 2074 |
| 2075 UNGCPRO; | |
| 2076 /* free the conses *after* the unbind, because the unbind will run | |
| 2077 condition_case_unwind above. */ | |
| 853 | 2078 free_cons (XCAR (c.tag)); |
| 2079 free_cons (c.tag); | |
| 617 | 2080 return c.val; |
| 428 | 2081 } |
| 2082 | |
| 2083 static Lisp_Object | |
| 2084 run_condition_case_handlers (Lisp_Object val, Lisp_Object var) | |
| 2085 { | |
| 2086 /* This function can GC */ | |
| 2087 #if 0 /* FSFmacs */ | |
| 2088 if (!NILP (h.var)) | |
| 2089 specbind (h.var, c.val); | |
| 2090 val = Fprogn (Fcdr (h.chosen_clause)); | |
| 2091 | |
| 2092 /* Note that this just undoes the binding of h.var; whoever | |
| 2093 longjmp()ed to us unwound the stack to c.pdlcount before | |
| 2094 throwing. */ | |
| 771 | 2095 unbind_to (c.pdlcount); |
| 428 | 2096 return val; |
| 2097 #else | |
| 2098 int speccount; | |
| 2099 | |
| 2100 CHECK_TRUE_LIST (val); | |
| 2101 if (NILP (var)) | |
| 2102 return Fprogn (Fcdr (val)); /* tail call */ | |
| 2103 | |
| 2104 speccount = specpdl_depth(); | |
| 2105 specbind (var, Fcar (val)); | |
| 2106 val = Fprogn (Fcdr (val)); | |
| 771 | 2107 return unbind_to_1 (speccount, val); |
| 428 | 2108 #endif |
| 2109 } | |
| 2110 | |
| 2111 /* Here for bytecode to call non-consfully. This is exactly like | |
| 2112 condition-case except that it takes three arguments rather | |
| 2113 than a single list of arguments. */ | |
| 2114 Lisp_Object | |
| 2115 condition_case_3 (Lisp_Object bodyform, Lisp_Object var, Lisp_Object handlers) | |
| 2116 { | |
| 2117 /* This function can GC */ | |
| 2118 EXTERNAL_LIST_LOOP_2 (handler, handlers) | |
| 2119 { | |
| 2120 if (NILP (handler)) | |
| 2121 ; | |
| 2122 else if (CONSP (handler)) | |
| 2123 { | |
| 2124 Lisp_Object conditions = XCAR (handler); | |
| 2125 /* CONDITIONS must a condition name or a list of condition names */ | |
| 2126 if (SYMBOLP (conditions)) | |
| 2127 ; | |
| 2128 else | |
| 2129 { | |
| 2130 EXTERNAL_LIST_LOOP_2 (condition, conditions) | |
| 2131 if (!SYMBOLP (condition)) | |
| 2132 goto invalid_condition_handler; | |
| 2133 } | |
| 2134 } | |
| 2135 else | |
| 2136 { | |
| 2137 invalid_condition_handler: | |
| 563 | 2138 sferror ("Invalid condition handler", handler); |
| 428 | 2139 } |
| 2140 } | |
| 2141 | |
| 2142 CHECK_SYMBOL (var); | |
| 2143 | |
| 2144 return condition_case_1 (handlers, | |
| 2145 Feval, bodyform, | |
| 2146 run_condition_case_handlers, | |
| 2147 var); | |
| 2148 } | |
| 2149 | |
| 2150 DEFUN ("condition-case", Fcondition_case, 2, UNEVALLED, 0, /* | |
| 2151 Regain control when an error is signalled. | |
| 2152 Usage looks like (condition-case VAR BODYFORM HANDLERS...). | |
| 2153 Executes BODYFORM and returns its value if no error happens. | |
| 2154 Each element of HANDLERS looks like (CONDITION-NAME BODY...) | |
| 2155 where the BODY is made of Lisp expressions. | |
| 2156 | |
| 771 | 2157 A typical usage of `condition-case' looks like this: |
| 2158 | |
| 2159 (condition-case nil | |
| 2160 ;; you need a progn here if you want more than one statement ... | |
| 2161 (progn | |
| 2162 (do-something) | |
| 2163 (do-something-else)) | |
| 2164 (error | |
| 2165 (issue-warning-or) | |
| 2166 ;; but strangely, you don't need one here. | |
| 2167 (return-a-value-etc) | |
| 2168 )) | |
| 2169 | |
| 428 | 2170 A handler is applicable to an error if CONDITION-NAME is one of the |
| 2171 error's condition names. If an error happens, the first applicable | |
| 2172 handler is run. As a special case, a CONDITION-NAME of t matches | |
| 2173 all errors, even those without the `error' condition name on them | |
| 2174 \(e.g. `quit'). | |
| 2175 | |
| 2176 The car of a handler may be a list of condition names | |
| 2177 instead of a single condition name. | |
| 2178 | |
| 2179 When a handler handles an error, | |
| 2180 control returns to the condition-case and the handler BODY... is executed | |
| 2181 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA). | |
| 2182 VAR may be nil; then you do not get access to the signal information. | |
| 2183 | |
| 2184 The value of the last BODY form is returned from the condition-case. | |
| 2185 See also the function `signal' for more info. | |
| 2186 | |
| 2187 Note that at the time the condition handler is invoked, the Lisp stack | |
| 2188 and the current catches, condition-cases, and bindings have all been | |
| 2189 popped back to the state they were in just before the call to | |
| 2190 `condition-case'. This means that resignalling the error from | |
| 2191 within the handler will not result in an infinite loop. | |
| 2192 | |
| 2193 If you want to establish an error handler that is called with the | |
| 2194 Lisp stack, bindings, etc. as they were when `signal' was called, | |
| 2195 rather than when the handler was set, use `call-with-condition-handler'. | |
| 2196 */ | |
| 2197 (args)) | |
| 2198 { | |
| 2199 /* This function can GC */ | |
| 2200 Lisp_Object var = XCAR (args); | |
| 2201 Lisp_Object bodyform = XCAR (XCDR (args)); | |
| 2202 Lisp_Object handlers = XCDR (XCDR (args)); | |
| 2203 return condition_case_3 (bodyform, var, handlers); | |
| 2204 } | |
| 2205 | |
| 2206 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
|
2207 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
|
2208 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
2209 This function is similar to `condition-case', but HANDLER is invoked |
| 428 | 2210 with the same environment (Lisp stack, bindings, catches, condition-cases) |
| 2211 that was current when `signal' was called, rather than when the handler | |
| 2212 was established. | |
| 2213 | |
| 2214 HANDLER should be a function of one argument, which is a cons of the args | |
| 2215 \(SIG . DATA) that were passed to `signal'. It is invoked whenever | |
| 2216 `signal' is called (this differs from `condition-case', which allows | |
| 2217 you to specify which errors are trapped). If the handler function | |
| 2218 returns, `signal' continues as if the handler were never invoked. | |
| 2219 \(It continues to look for handlers established earlier than this one, | |
| 2220 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
|
2221 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
2222 arguments: (HANDLER FUNCTION &rest ARGS) |
| 428 | 2223 */ |
| 2224 (int nargs, Lisp_Object *args)) /* Note! Args side-effected! */ | |
| 2225 { | |
| 2226 /* This function can GC */ | |
| 2227 int speccount = specpdl_depth(); | |
| 2228 Lisp_Object tem; | |
| 2229 | |
| 853 | 2230 tem = Ffunction_max_args (args[0]); |
| 2231 if (! (XINT (Ffunction_min_args (args[0])) <= 1 | |
| 2232 && (NILP (tem) || 1 <= XINT (tem)))) | |
| 2233 invalid_argument ("Must be function of one argument", args[0]); | |
| 2234 | |
| 2235 /* (handler-fun . handler-args) but currently there are no handler-args */ | |
| 428 | 2236 tem = noseeum_cons (list1 (args[0]), Vcondition_handlers); |
| 2237 record_unwind_protect (condition_bind_unwind, tem); | |
| 2238 Vcondition_handlers = tem; | |
| 2239 | |
| 2240 /* Caller should have GC-protected args */ | |
| 771 | 2241 return unbind_to_1 (speccount, Ffuncall (nargs - 1, args + 1)); |
| 428 | 2242 } |
| 2243 | |
| 853 | 2244 /* This is the C version of the above function. It calls FUN, passing it |
| 2245 ARG, first setting up HANDLER to catch signals in the environment in | |
| 2246 which they were signalled. (HANDLER is only invoked if there was no | |
| 2247 handler (either from condition-case or call-with-condition-handler) set | |
| 2248 later on that handled the signal; therefore, this is a real error. | |
| 2249 | |
| 2250 HANDLER is invoked with three arguments: the ERROR-SYMBOL and DATA as | |
| 2251 passed to `signal', and HANDLER_ARG. Originally I made HANDLER_ARG and | |
| 2252 ARG be void * to facilitate passing structures, but I changed to | |
| 2253 Lisp_Objects because all the other C interfaces to catch/condition-case/etc. | |
| 2254 take Lisp_Objects, and it is easy enough to use make_opaque_ptr() et al. | |
| 2255 to convert between Lisp_Objects and structure pointers. */ | |
| 2256 | |
| 2257 Lisp_Object | |
| 2258 call_with_condition_handler (Lisp_Object (*handler) (Lisp_Object, Lisp_Object, | |
| 2259 Lisp_Object), | |
| 2260 Lisp_Object handler_arg, | |
| 2261 Lisp_Object (*fun) (Lisp_Object), | |
| 2262 Lisp_Object arg) | |
| 2263 { | |
| 2264 /* This function can GC */ | |
| 1111 | 2265 int speccount = specpdl_depth (); |
| 853 | 2266 Lisp_Object tem; |
| 2267 | |
| 2268 /* ((handler-fun . (handler-arg . nil)) ... ) */ | |
| 1111 | 2269 tem = noseeum_cons (noseeum_cons (make_opaque_ptr ((void *) handler), |
| 853 | 2270 noseeum_cons (handler_arg, Qnil)), |
| 2271 Vcondition_handlers); | |
| 2272 record_unwind_protect (condition_bind_unwind, tem); | |
| 2273 Vcondition_handlers = tem; | |
| 2274 | |
| 2275 return unbind_to_1 (speccount, (*fun) (arg)); | |
| 2276 } | |
| 2277 | |
| 428 | 2278 static int |
| 2279 condition_type_p (Lisp_Object type, Lisp_Object conditions) | |
| 2280 { | |
| 2281 if (EQ (type, Qt)) | |
| 2282 /* (condition-case c # (t c)) catches -all- signals | |
| 2283 * Use with caution! */ | |
| 2284 return 1; | |
| 2285 | |
| 2286 if (SYMBOLP (type)) | |
| 2287 return !NILP (Fmemq (type, conditions)); | |
| 2288 | |
| 2289 for (; CONSP (type); type = XCDR (type)) | |
| 2290 if (!NILP (Fmemq (XCAR (type), conditions))) | |
| 2291 return 1; | |
| 2292 | |
| 2293 return 0; | |
| 2294 } | |
| 2295 | |
| 2296 static Lisp_Object | |
| 2297 return_from_signal (Lisp_Object value) | |
| 2298 { | |
| 2299 #if 1 | |
| 2300 /* Most callers are not prepared to handle gc if this | |
| 2301 returns. So, since this feature is not very useful, | |
| 2302 take it out. */ | |
| 2303 /* Have called debugger; return value to signaller */ | |
| 2304 return value; | |
| 2305 #else /* But the reality is that that stinks, because: */ | |
| 2306 /* GACK!!! Really want some way for debug-on-quit errors | |
| 2307 to be continuable!! */ | |
| 563 | 2308 signal_error (Qunimplemented, |
| 2309 "Returning a value from an error is no longer supported", | |
| 2310 Qunbound); | |
| 428 | 2311 #endif |
| 2312 } | |
| 2313 | |
| 2314 | |
| 2315 /************************************************************************/ | |
| 2316 /* the workhorse error-signaling function */ | |
| 2317 /************************************************************************/ | |
| 2318 | |
| 853 | 2319 /* This exists only for debugging purposes, as a place to put a breakpoint |
| 2320 that won't get signalled for errors occurring when | |
| 2321 call_with_suspended_errors() was invoked. */ | |
| 2322 | |
| 872 | 2323 /* Don't make static or it might be compiled away */ |
| 2324 void signal_1 (void); | |
| 2325 | |
| 2326 void | |
| 853 | 2327 signal_1 (void) |
| 2328 { | |
| 2329 } | |
| 2330 | |
| 428 | 2331 /* #### This function has not been synched with FSF. It diverges |
| 2332 significantly. */ | |
| 2333 | |
| 853 | 2334 /* The simplest external error function: it would be called |
| 2335 signal_continuable_error() in the terminology below, but it's | |
| 2336 Lisp-callable. */ | |
| 2337 | |
| 2338 DEFUN ("signal", Fsignal, 2, 2, 0, /* | |
| 2339 Signal a continuable error. Args are ERROR-SYMBOL, and associated DATA. | |
| 2340 An error symbol is a symbol defined using `define-error'. | |
| 2341 DATA should be a list. Its elements are printed as part of the error message. | |
| 2342 If the signal is handled, DATA is made available to the handler. | |
| 2343 See also the function `signal-error', and the functions to handle errors: | |
| 2344 `condition-case' and `call-with-condition-handler'. | |
| 2345 | |
| 2346 Note that this function can return, if the debugger is invoked and the | |
| 2347 user invokes the "return from signal" option. | |
| 2348 */ | |
| 2349 (error_symbol, data)) | |
| 428 | 2350 { |
| 2351 /* This function can GC */ | |
| 853 | 2352 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; |
| 2353 Lisp_Object conditions = Qnil; | |
| 2354 Lisp_Object handlers = Qnil; | |
| 428 | 2355 /* signal_call_debugger() could get called more than once |
| 2356 (once when a call-with-condition-handler is about to | |
| 2357 be dealt with, and another when a condition-case handler | |
| 2358 is about to be invoked). So make sure the debugger and/or | |
| 2359 stack trace aren't done more than once. */ | |
| 2360 int stack_trace_displayed = 0; | |
| 2361 int debugger_entered = 0; | |
| 853 | 2362 |
| 2363 /* Fsignal() is one of these functions that's called all the time | |
| 2364 with newly-created Lisp objects. We allow this; but we must GC- | |
| 2365 protect the objects because all sorts of weird stuff could | |
| 2366 happen. */ | |
| 2367 | |
| 2368 GCPRO4 (conditions, handlers, error_symbol, data); | |
| 2369 | |
| 2370 if (!(inhibit_flags & CALL_WITH_SUSPENDED_ERRORS)) | |
| 2371 signal_1 (); | |
| 428 | 2372 |
| 2373 if (!initialized) | |
| 2374 { | |
| 2375 /* who knows how much has been initialized? Safest bet is | |
| 2376 just to bomb out immediately. */ | |
| 771 | 2377 stderr_out ("Error before initialization is complete!\n"); |
| 2500 | 2378 ABORT (); |
| 428 | 2379 } |
| 2380 | |
| 3092 | 2381 #ifndef NEW_GC |
| 1123 | 2382 assert (!gc_in_progress); |
| 3092 | 2383 #endif /* not NEW_GC */ |
| 1123 | 2384 |
| 2385 /* We abort if in_display and we are not protected, as garbage | |
| 2386 collections and non-local exits will invariably be fatal, but in | |
| 2387 messy, difficult-to-debug ways. See enter_redisplay_critical_section(). | |
| 2388 */ | |
| 2389 | |
| 1318 | 2390 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS |
| 1123 | 2391 check_proper_critical_section_nonlocal_exit_protection (); |
| 1318 | 2392 #endif |
| 428 | 2393 |
| 853 | 2394 conditions = Fget (error_symbol, Qerror_conditions, Qnil); |
| 428 | 2395 |
| 2396 for (handlers = Vcondition_handlers; | |
| 2397 CONSP (handlers); | |
| 2398 handlers = XCDR (handlers)) | |
| 2399 { | |
| 2400 Lisp_Object handler_fun = XCAR (XCAR (handlers)); | |
| 2401 Lisp_Object handler_data = XCDR (XCAR (handlers)); | |
| 2402 Lisp_Object outer_handlers = XCDR (handlers); | |
| 2403 | |
| 2404 if (!UNBOUNDP (handler_fun)) | |
| 2405 { | |
| 2406 /* call-with-condition-handler */ | |
| 2407 Lisp_Object tem; | |
| 2408 Lisp_Object all_handlers = Vcondition_handlers; | |
| 2409 struct gcpro ngcpro1; | |
| 2410 NGCPRO1 (all_handlers); | |
| 2411 Vcondition_handlers = outer_handlers; | |
| 2412 | |
| 853 | 2413 tem = signal_call_debugger (conditions, error_symbol, data, |
| 428 | 2414 outer_handlers, 1, |
| 2415 &stack_trace_displayed, | |
| 2416 &debugger_entered); | |
| 2417 if (!UNBOUNDP (tem)) | |
| 2418 RETURN_NUNGCPRO (return_from_signal (tem)); | |
| 2419 | |
| 853 | 2420 if (OPAQUE_PTRP (handler_fun)) |
| 2421 { | |
| 2422 if (NILP (handler_data)) | |
| 2423 { | |
| 2424 Lisp_Object (*hfun) (Lisp_Object, Lisp_Object) = | |
| 2425 (Lisp_Object (*) (Lisp_Object, Lisp_Object)) | |
| 2426 (get_opaque_ptr (handler_fun)); | |
| 2427 | |
| 2428 tem = (*hfun) (error_symbol, data); | |
| 2429 } | |
| 2430 else | |
| 2431 { | |
| 2432 Lisp_Object (*hfun) (Lisp_Object, Lisp_Object, Lisp_Object) = | |
| 2433 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object)) | |
| 2434 (get_opaque_ptr (handler_fun)); | |
| 2435 | |
| 2436 assert (NILP (XCDR (handler_data))); | |
| 2437 tem = (*hfun) (error_symbol, data, XCAR (handler_data)); | |
| 2438 } | |
| 2439 } | |
| 2440 else | |
| 2441 { | |
| 2442 tem = Fcons (error_symbol, data); | |
| 2443 if (NILP (handler_data)) | |
| 2444 tem = call1 (handler_fun, tem); | |
| 2445 else | |
| 2446 { | |
| 2447 /* (This code won't be used (for now?).) */ | |
| 2448 struct gcpro nngcpro1; | |
| 2449 Lisp_Object args[3]; | |
| 2450 NNGCPRO1 (args[0]); | |
| 2451 nngcpro1.nvars = 3; | |
| 2452 args[0] = handler_fun; | |
| 2453 args[1] = tem; | |
| 2454 args[2] = handler_data; | |
| 2455 nngcpro1.var = args; | |
| 2456 tem = Fapply (3, args); | |
| 2457 NNUNGCPRO; | |
| 2458 } | |
| 2459 } | |
| 428 | 2460 NUNGCPRO; |
| 2461 #if 0 | |
| 2462 if (!EQ (tem, Qsignal)) | |
| 2463 return return_from_signal (tem); | |
| 2464 #endif | |
| 2465 /* If handler didn't throw, try another handler */ | |
| 2466 Vcondition_handlers = all_handlers; | |
| 2467 } | |
| 2468 | |
| 2469 /* It's a condition-case handler */ | |
| 2470 | |
| 2471 /* t is used by handlers for all conditions, set up by C code. | |
| 2472 * debugger is not called even if debug_on_error */ | |
| 2473 else if (EQ (handler_data, Qt)) | |
| 2474 { | |
| 2475 UNGCPRO; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
2476 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
|
2477 0, Qnil, Qnil); |
| 428 | 2478 } |
| 2479 /* `error' is used similarly to the way `t' is used, but in | |
| 2480 addition it invokes the debugger if debug_on_error. | |
| 2481 This is normally used for the outer command-loop error | |
| 2482 handler. */ | |
| 2483 else if (EQ (handler_data, Qerror)) | |
| 2484 { | |
| 853 | 2485 Lisp_Object tem = signal_call_debugger (conditions, error_symbol, |
| 2486 data, | |
| 428 | 2487 outer_handlers, 0, |
| 2488 &stack_trace_displayed, | |
| 2489 &debugger_entered); | |
| 2490 | |
| 2491 UNGCPRO; | |
| 2492 if (!UNBOUNDP (tem)) | |
| 2493 return return_from_signal (tem); | |
| 2494 | |
| 853 | 2495 tem = Fcons (error_symbol, data); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
2496 throw_or_bomb_out (handlers, tem, 0, Qnil, Qnil); |
| 428 | 2497 } |
| 2498 else | |
| 2499 { | |
| 2500 /* handler established by real (Lisp) condition-case */ | |
| 2501 Lisp_Object h; | |
| 2502 | |
| 2503 for (h = handler_data; CONSP (h); h = Fcdr (h)) | |
| 2504 { | |
| 2505 Lisp_Object clause = Fcar (h); | |
| 2506 Lisp_Object tem = Fcar (clause); | |
| 2507 | |
| 2508 if (condition_type_p (tem, conditions)) | |
| 2509 { | |
| 853 | 2510 tem = signal_call_debugger (conditions, error_symbol, data, |
| 428 | 2511 outer_handlers, 1, |
| 2512 &stack_trace_displayed, | |
| 2513 &debugger_entered); | |
| 2514 UNGCPRO; | |
| 2515 if (!UNBOUNDP (tem)) | |
| 2516 return return_from_signal (tem); | |
| 2517 | |
| 2518 /* Doesn't return */ | |
| 853 | 2519 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
|
2520 throw_or_bomb_out (handlers, tem, 0, Qnil, Qnil); |
| 428 | 2521 } |
| 2522 } | |
| 2523 } | |
| 2524 } | |
| 2525 | |
| 2526 /* If no handler is present now, try to run the debugger, | |
| 2527 and if that fails, throw to top level. | |
| 2528 | |
| 2529 #### The only time that no handler is present is during | |
| 2530 temacs or perhaps very early in XEmacs. In both cases, | |
| 3025 | 2531 there is no `top-level' catch. (That's why the |
| 428 | 2532 "bomb-out" hack was added.) |
| 2533 | |
| 853 | 2534 [[#### Fix this horrifitude!]] |
| 2535 | |
| 2536 I don't think this is horrifitude, but just defensive coding. --ben */ | |
| 2537 | |
| 2538 signal_call_debugger (conditions, error_symbol, data, Qnil, 0, | |
| 428 | 2539 &stack_trace_displayed, |
| 2540 &debugger_entered); | |
| 2541 UNGCPRO; | |
| 853 | 2542 throw_or_bomb_out (Qtop_level, Qt, 1, error_symbol, |
| 2543 data); /* Doesn't return */ | |
| 2268 | 2544 RETURN_NOT_REACHED (Qnil); |
| 428 | 2545 } |
| 2546 | |
| 2547 /****************** Error functions class 1 ******************/ | |
| 2548 | |
| 2549 /* Class 1: General functions that signal an error. | |
| 2550 These functions take an error type and a list of associated error | |
| 2551 data. */ | |
| 2552 | |
| 853 | 2553 /* No signal_continuable_error_1(); it's called Fsignal(). */ |
| 428 | 2554 |
| 2555 /* Signal a non-continuable error. */ | |
| 2556 | |
| 2557 DOESNT_RETURN | |
| 563 | 2558 signal_error_1 (Lisp_Object sig, Lisp_Object data) |
| 428 | 2559 { |
| 2560 for (;;) | |
| 2561 Fsignal (sig, data); | |
| 2562 } | |
| 853 | 2563 |
| 2564 #ifdef ERROR_CHECK_CATCH | |
| 2565 | |
| 2566 void | |
| 2567 check_catchlist_sanity (void) | |
| 2568 { | |
| 2569 #if 0 | |
| 2570 /* vou me tomar no cu! i just masked andy's missing-unbind | |
| 2571 bug! */ | |
| 442 | 2572 struct catchtag *c; |
| 2573 int found_error_tag = 0; | |
| 2574 | |
| 2575 for (c = catchlist; c; c = c->next) | |
| 2576 { | |
| 2577 if (EQ (c->tag, Qunbound_suspended_errors_tag)) | |
| 2578 { | |
| 2579 found_error_tag = 1; | |
| 2580 break; | |
| 2581 } | |
| 2582 } | |
| 2583 | |
| 2584 assert (found_error_tag || NILP (Vcurrent_error_state)); | |
| 853 | 2585 #endif /* vou me tomar no cul */ |
| 2586 } | |
| 2587 | |
| 2588 void | |
| 2589 check_specbind_stack_sanity (void) | |
| 2590 { | |
| 2591 } | |
| 2592 | |
| 2593 #endif /* ERROR_CHECK_CATCH */ | |
| 428 | 2594 |
| 2595 /* Signal a non-continuable error or display a warning or do nothing, | |
| 2596 according to ERRB. CLASS is the class of warning and should | |
| 2597 refer to what sort of operation is being done (e.g. Qtoolbar, | |
| 2598 Qresource, etc.). */ | |
| 2599 | |
| 2600 void | |
| 1204 | 2601 maybe_signal_error_1 (Lisp_Object sig, Lisp_Object data, Lisp_Object class_, |
| 578 | 2602 Error_Behavior errb) |
| 428 | 2603 { |
| 2604 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2605 return; | |
| 793 | 2606 else if (ERRB_EQ (errb, ERROR_ME_DEBUG_WARN)) |
| 1204 | 2607 warn_when_safe_lispobj (class_, Qdebug, Fcons (sig, data)); |
| 428 | 2608 else if (ERRB_EQ (errb, ERROR_ME_WARN)) |
| 1204 | 2609 warn_when_safe_lispobj (class_, Qwarning, Fcons (sig, data)); |
| 428 | 2610 else |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2611 signal_error_1 (sig, data); |
| 428 | 2612 } |
| 2613 | |
| 2614 /* Signal a continuable error or display a warning or do nothing, | |
| 2615 according to ERRB. */ | |
| 2616 | |
| 2617 Lisp_Object | |
| 563 | 2618 maybe_signal_continuable_error_1 (Lisp_Object sig, Lisp_Object data, |
| 1204 | 2619 Lisp_Object class_, Error_Behavior errb) |
| 428 | 2620 { |
| 2621 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2622 return Qnil; | |
| 793 | 2623 else if (ERRB_EQ (errb, ERROR_ME_DEBUG_WARN)) |
| 2624 { | |
| 1204 | 2625 warn_when_safe_lispobj (class_, Qdebug, Fcons (sig, data)); |
| 793 | 2626 return Qnil; |
| 2627 } | |
| 428 | 2628 else if (ERRB_EQ (errb, ERROR_ME_WARN)) |
| 2629 { | |
| 1204 | 2630 warn_when_safe_lispobj (class_, Qwarning, Fcons (sig, data)); |
| 428 | 2631 return Qnil; |
| 2632 } | |
| 2633 else | |
| 2634 return Fsignal (sig, data); | |
| 2635 } | |
| 2636 | |
| 2637 | |
| 2638 /****************** Error functions class 2 ******************/ | |
| 2639 | |
| 563 | 2640 /* Class 2: Signal an error with a string and an associated object. |
| 2641 Normally these functions are used to attach one associated object, | |
| 2642 but to attach no objects, specify Qunbound for FROB, and for more | |
| 2643 than one object, make a list of the objects with Qunbound as the | |
| 2644 first element. (If you have specifically two objects to attach, | |
| 2645 consider using the function in class 3 below.) These functions | |
| 2646 signal an error of a specified type, whose data is one or more | |
| 2647 objects (usually two), a string the related Lisp object(s) | |
| 2648 specified as FROB. */ | |
| 2649 | |
| 2650 /* Out of REASON and FROB, return a list of elements suitable for passing | |
| 2651 to signal_error_1(). */ | |
| 2652 | |
| 2653 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2654 build_error_data (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 2655 { |
| 2656 if (EQ (frob, Qunbound)) | |
| 2657 frob = Qnil; | |
| 2658 else if (CONSP (frob) && EQ (XCAR (frob), Qunbound)) | |
| 2659 frob = XCDR (frob); | |
| 2660 else | |
| 2661 frob = list1 (frob); | |
| 2662 if (!reason) | |
| 2663 return frob; | |
| 2664 else | |
| 771 | 2665 return Fcons (build_msg_string (reason), frob); |
| 563 | 2666 } |
| 2667 | |
| 2668 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2669 signal_error (Lisp_Object type, const Ascbyte *reason, Lisp_Object frob) |
| 563 | 2670 { |
| 2671 signal_error_1 (type, build_error_data (reason, frob)); | |
| 2672 } | |
| 2673 | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2674 /* NOTE NOTE NOTE: If you feel you need signal_ierror() or something |
|
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2675 similar when reason is a non-ASCII message, you're probably doing |
|
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2676 something wrong. When you have an error message from an external |
|
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2677 source, you should put the error message as the first item in FROB and |
|
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2678 put a string in REASON indicating what you were doing when the error |
|
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2679 message occurred. Use signal_error_2() for such a case. */ |
|
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2680 |
| 563 | 2681 void |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2682 maybe_signal_error (Lisp_Object type, const Ascbyte *reason, |
| 1204 | 2683 Lisp_Object frob, Lisp_Object class_, |
| 578 | 2684 Error_Behavior errb) |
| 563 | 2685 { |
| 2686 /* Optimization: */ | |
| 2687 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2688 return; | |
| 1204 | 2689 maybe_signal_error_1 (type, build_error_data (reason, frob), class_, errb); |
| 563 | 2690 } |
| 2691 | |
| 2692 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2693 signal_continuable_error (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2694 Lisp_Object frob) |
| 2695 { | |
| 2696 return Fsignal (type, build_error_data (reason, frob)); | |
| 2697 } | |
| 2698 | |
| 2699 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2700 maybe_signal_continuable_error (Lisp_Object type, const Ascbyte *reason, |
| 1204 | 2701 Lisp_Object frob, Lisp_Object class_, |
| 578 | 2702 Error_Behavior errb) |
| 563 | 2703 { |
| 2704 /* Optimization: */ | |
| 2705 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2706 return Qnil; | |
| 2707 return maybe_signal_continuable_error_1 (type, | |
| 2708 build_error_data (reason, frob), | |
| 1204 | 2709 class_, errb); |
| 563 | 2710 } |
| 2711 | |
| 2712 | |
| 2713 /****************** Error functions class 3 ******************/ | |
| 2714 | |
| 2715 /* Class 3: Signal an error with a string and two associated objects. | |
| 2716 These functions signal an error of a specified type, whose data | |
| 2717 is three objects, a string and two related Lisp objects. | |
| 2718 (The equivalent could be accomplished using the class 2 functions, | |
| 2719 but these are more convenient in this particular case.) */ | |
| 2720 | |
| 2721 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2722 signal_error_2 (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2723 Lisp_Object frob0, Lisp_Object frob1) |
| 2724 { | |
| 771 | 2725 signal_error_1 (type, list3 (build_msg_string (reason), frob0, |
| 563 | 2726 frob1)); |
| 2727 } | |
| 2728 | |
| 2729 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2730 maybe_signal_error_2 (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2731 Lisp_Object frob0, Lisp_Object frob1, |
| 1204 | 2732 Lisp_Object class_, Error_Behavior errb) |
| 563 | 2733 { |
| 2734 /* Optimization: */ | |
| 2735 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2736 return; | |
| 771 | 2737 maybe_signal_error_1 (type, list3 (build_msg_string (reason), frob0, |
| 1204 | 2738 frob1), class_, errb); |
| 563 | 2739 } |
| 2740 | |
| 2741 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2742 signal_continuable_error_2 (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2743 Lisp_Object frob0, Lisp_Object frob1) |
| 2744 { | |
| 771 | 2745 return Fsignal (type, list3 (build_msg_string (reason), frob0, |
| 563 | 2746 frob1)); |
| 2747 } | |
| 2748 | |
| 2749 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2750 maybe_signal_continuable_error_2 (Lisp_Object type, const Ascbyte *reason, |
| 563 | 2751 Lisp_Object frob0, Lisp_Object frob1, |
| 1204 | 2752 Lisp_Object class_, Error_Behavior errb) |
| 563 | 2753 { |
| 2754 /* Optimization: */ | |
| 2755 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2756 return Qnil; | |
| 2757 return maybe_signal_continuable_error_1 | |
| 771 | 2758 (type, list3 (build_msg_string (reason), frob0, frob1), |
| 1204 | 2759 class_, errb); |
| 563 | 2760 } |
| 2761 | |
| 2762 | |
| 2763 /****************** Error functions class 4 ******************/ | |
| 2764 | |
| 2765 /* Class 4: Printf-like functions that signal an error. | |
| 442 | 2766 These functions signal an error of a specified type, whose data |
| 428 | 2767 is a single string, created using the arguments. */ |
| 2768 | |
| 2769 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2770 signal_ferror (Lisp_Object type, const Ascbyte *fmt, ...) |
| 442 | 2771 { |
| 2772 Lisp_Object obj; | |
| 2773 va_list args; | |
| 2774 | |
| 2775 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2776 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 442 | 2777 va_end (args); |
| 2778 | |
| 2779 /* Fsignal GC-protects its args */ | |
| 563 | 2780 signal_error (type, 0, obj); |
| 442 | 2781 } |
| 2782 | |
| 2783 void | |
| 1204 | 2784 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
|
2785 const Ascbyte *fmt, ...) |
| 442 | 2786 { |
| 2787 Lisp_Object obj; | |
| 2788 va_list args; | |
| 2789 | |
| 2790 /* Optimization: */ | |
| 2791 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2792 return; | |
| 2793 | |
| 2794 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2795 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 442 | 2796 va_end (args); |
| 2797 | |
| 2798 /* Fsignal GC-protects its args */ | |
| 1204 | 2799 maybe_signal_error (type, 0, obj, class_, errb); |
| 442 | 2800 } |
| 2801 | |
| 2802 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2803 signal_continuable_ferror (Lisp_Object type, const Ascbyte *fmt, ...) |
| 428 | 2804 { |
| 2805 Lisp_Object obj; | |
| 2806 va_list args; | |
| 2807 | |
| 2808 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2809 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 442 | 2810 va_end (args); |
| 2811 | |
| 2812 /* Fsignal GC-protects its args */ | |
| 2813 return Fsignal (type, list1 (obj)); | |
| 2814 } | |
| 2815 | |
| 2816 Lisp_Object | |
| 1204 | 2817 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
|
2818 Error_Behavior errb, const Ascbyte *fmt, ...) |
| 442 | 2819 { |
| 2820 Lisp_Object obj; | |
| 2821 va_list args; | |
| 2822 | |
| 2823 /* Optimization: */ | |
| 2824 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2825 return Qnil; | |
| 2826 | |
| 2827 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2828 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 442 | 2829 va_end (args); |
| 2830 | |
| 2831 /* Fsignal GC-protects its args */ | |
| 1204 | 2832 return maybe_signal_continuable_error (type, 0, obj, class_, errb); |
| 442 | 2833 } |
| 2834 | |
| 2835 | |
| 2836 /****************** Error functions class 5 ******************/ | |
| 2837 | |
| 563 | 2838 /* Class 5: Printf-like functions that signal an error. |
| 442 | 2839 These functions signal an error of a specified type, whose data |
| 563 | 2840 is a one or more objects, a string (created using the arguments) |
| 2841 and additional Lisp objects specified in FROB. (The syntax of FROB | |
| 2842 is the same as for class 2.) | |
| 2843 | |
| 2844 There is no need for a class 6 because you can always attach 2 | |
| 2845 objects using class 5 (for FROB, specify a list with three | |
| 2846 elements, the first of which is Qunbound), and these functions are | |
| 2847 not commonly used. | |
| 2848 */ | |
| 442 | 2849 |
| 2850 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2851 signal_ferror_with_frob (Lisp_Object type, Lisp_Object frob, const Ascbyte *fmt, |
| 563 | 2852 ...) |
| 442 | 2853 { |
| 2854 Lisp_Object obj; | |
| 2855 va_list args; | |
| 2856 | |
| 2857 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2858 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 442 | 2859 va_end (args); |
| 2860 | |
| 2861 /* Fsignal GC-protects its args */ | |
| 563 | 2862 signal_error_1 (type, Fcons (obj, build_error_data (0, frob))); |
| 442 | 2863 } |
| 2864 | |
| 2865 void | |
| 563 | 2866 maybe_signal_ferror_with_frob (Lisp_Object type, Lisp_Object frob, |
| 1204 | 2867 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
|
2868 const Ascbyte *fmt, ...) |
| 442 | 2869 { |
| 2870 Lisp_Object obj; | |
| 2871 va_list args; | |
| 2872 | |
| 2873 /* Optimization: */ | |
| 2874 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2875 return; | |
| 2876 | |
| 2877 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2878 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 428 | 2879 va_end (args); |
| 2880 | |
| 2881 /* Fsignal GC-protects its args */ | |
| 1204 | 2882 maybe_signal_error_1 (type, Fcons (obj, build_error_data (0, frob)), class_, |
| 563 | 2883 errb); |
| 428 | 2884 } |
| 2885 | |
| 2886 Lisp_Object | |
| 563 | 2887 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
|
2888 const Ascbyte *fmt, ...) |
| 428 | 2889 { |
| 2890 Lisp_Object obj; | |
| 2891 va_list args; | |
| 2892 | |
| 2893 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2894 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 428 | 2895 va_end (args); |
| 2896 | |
| 2897 /* Fsignal GC-protects its args */ | |
| 563 | 2898 return Fsignal (type, Fcons (obj, build_error_data (0, frob))); |
| 428 | 2899 } |
| 2900 | |
| 2901 Lisp_Object | |
| 563 | 2902 maybe_signal_continuable_ferror_with_frob (Lisp_Object type, Lisp_Object frob, |
| 1204 | 2903 Lisp_Object class_, |
| 578 | 2904 Error_Behavior errb, |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2905 const Ascbyte *fmt, ...) |
| 428 | 2906 { |
| 2907 Lisp_Object obj; | |
| 2908 va_list args; | |
| 2909 | |
| 2910 /* Optimization: */ | |
| 2911 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2912 return Qnil; | |
| 2913 | |
| 2914 va_start (args, fmt); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2915 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 428 | 2916 va_end (args); |
| 2917 | |
| 2918 /* Fsignal GC-protects its args */ | |
| 563 | 2919 return maybe_signal_continuable_error_1 (type, |
| 2920 Fcons (obj, | |
| 2921 build_error_data (0, frob)), | |
| 1204 | 2922 class_, errb); |
| 428 | 2923 } |
| 2924 | |
| 2925 | |
| 2926 /* This is what the QUIT macro calls to signal a quit */ | |
| 2927 void | |
| 2928 signal_quit (void) | |
| 2929 { | |
| 853 | 2930 /* This function cannot GC. GC is prohibited because most callers do |
| 2931 not expect GC occurring in QUIT. Remove this if/when that gets fixed. | |
| 2932 --ben */ | |
| 2933 | |
| 2934 int count; | |
| 2935 | |
| 428 | 2936 if (EQ (Vquit_flag, Qcritical)) |
| 2937 debug_on_quit |= 2; /* set critical bit. */ | |
| 2938 Vquit_flag = Qnil; | |
| 853 | 2939 count = begin_gc_forbidden (); |
| 428 | 2940 /* note that this is continuable. */ |
| 2941 Fsignal (Qquit, Qnil); | |
| 853 | 2942 unbind_to (count); |
| 428 | 2943 } |
| 2944 | |
| 2945 | |
| 563 | 2946 /************************ convenience error functions ***********************/ |
| 2947 | |
| 436 | 2948 Lisp_Object |
| 428 | 2949 signal_void_function_error (Lisp_Object function) |
| 2950 { | |
| 436 | 2951 return Fsignal (Qvoid_function, list1 (function)); |
| 428 | 2952 } |
| 2953 | |
| 436 | 2954 Lisp_Object |
| 428 | 2955 signal_invalid_function_error (Lisp_Object function) |
| 2956 { | |
| 436 | 2957 return Fsignal (Qinvalid_function, list1 (function)); |
| 428 | 2958 } |
| 2959 | |
| 436 | 2960 Lisp_Object |
| 428 | 2961 signal_wrong_number_of_arguments_error (Lisp_Object function, int nargs) |
| 2962 { | |
| 436 | 2963 return Fsignal (Qwrong_number_of_arguments, |
| 2964 list2 (function, make_int (nargs))); | |
| 428 | 2965 } |
| 2966 | |
| 2967 /* Used in list traversal macros for efficiency. */ | |
| 436 | 2968 DOESNT_RETURN |
| 428 | 2969 signal_malformed_list_error (Lisp_Object list) |
| 2970 { | |
| 563 | 2971 signal_error (Qmalformed_list, 0, list); |
| 428 | 2972 } |
| 2973 | |
| 436 | 2974 DOESNT_RETURN |
| 428 | 2975 signal_malformed_property_list_error (Lisp_Object list) |
| 2976 { | |
| 563 | 2977 signal_error (Qmalformed_property_list, 0, list); |
| 428 | 2978 } |
| 2979 | |
| 436 | 2980 DOESNT_RETURN |
| 428 | 2981 signal_circular_list_error (Lisp_Object list) |
| 2982 { | |
| 563 | 2983 signal_error (Qcircular_list, 0, list); |
| 428 | 2984 } |
| 2985 | |
| 436 | 2986 DOESNT_RETURN |
| 428 | 2987 signal_circular_property_list_error (Lisp_Object list) |
| 2988 { | |
| 563 | 2989 signal_error (Qcircular_property_list, 0, list); |
| 428 | 2990 } |
| 442 | 2991 |
| 2267 | 2992 /* Called from within emacs_doprnt_1, so REASON is not formatted. */ |
| 442 | 2993 DOESNT_RETURN |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
2994 syntax_error (const Ascbyte *reason, Lisp_Object frob) |
| 442 | 2995 { |
| 563 | 2996 signal_error (Qsyntax_error, reason, frob); |
| 442 | 2997 } |
| 2998 | |
| 2999 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3000 syntax_error_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2) |
| 442 | 3001 { |
| 563 | 3002 signal_error_2 (Qsyntax_error, reason, frob1, frob2); |
| 3003 } | |
| 3004 | |
| 3005 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3006 maybe_syntax_error (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3007 Lisp_Object class_, Error_Behavior errb) |
| 3008 { | |
| 3009 maybe_signal_error (Qsyntax_error, reason, frob, class_, errb); | |
| 563 | 3010 } |
| 3011 | |
| 3012 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3013 sferror (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3014 { |
| 3015 signal_error (Qstructure_formation_error, reason, frob); | |
| 3016 } | |
| 3017 | |
| 3018 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3019 sferror_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2) |
| 563 | 3020 { |
| 3021 signal_error_2 (Qstructure_formation_error, reason, frob1, frob2); | |
| 3022 } | |
| 3023 | |
| 3024 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3025 maybe_sferror (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3026 Lisp_Object class_, Error_Behavior errb) |
| 3027 { | |
| 3028 maybe_signal_error (Qstructure_formation_error, reason, frob, class_, errb); | |
| 442 | 3029 } |
| 3030 | |
| 3031 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3032 invalid_argument (const Ascbyte *reason, Lisp_Object frob) |
| 442 | 3033 { |
| 563 | 3034 signal_error (Qinvalid_argument, reason, frob); |
| 442 | 3035 } |
| 3036 | |
| 3037 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3038 invalid_argument_2 (const Ascbyte *reason, Lisp_Object frob1, |
| 609 | 3039 Lisp_Object frob2) |
| 442 | 3040 { |
| 563 | 3041 signal_error_2 (Qinvalid_argument, reason, frob1, frob2); |
| 3042 } | |
| 3043 | |
| 3044 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3045 maybe_invalid_argument (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3046 Lisp_Object class_, Error_Behavior errb) |
| 3047 { | |
| 3048 maybe_signal_error (Qinvalid_argument, reason, frob, class_, errb); | |
| 563 | 3049 } |
| 3050 | |
| 3051 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3052 invalid_constant (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3053 { |
| 3054 signal_error (Qinvalid_constant, reason, frob); | |
| 3055 } | |
| 3056 | |
| 3057 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3058 invalid_constant_2 (const Ascbyte *reason, Lisp_Object frob1, |
| 609 | 3059 Lisp_Object frob2) |
| 563 | 3060 { |
| 3061 signal_error_2 (Qinvalid_constant, reason, frob1, frob2); | |
| 3062 } | |
| 3063 | |
| 3064 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3065 maybe_invalid_constant (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3066 Lisp_Object class_, Error_Behavior errb) |
| 3067 { | |
| 3068 maybe_signal_error (Qinvalid_constant, reason, frob, class_, errb); | |
| 442 | 3069 } |
| 3070 | |
| 3071 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3072 invalid_operation (const Ascbyte *reason, Lisp_Object frob) |
| 442 | 3073 { |
| 563 | 3074 signal_error (Qinvalid_operation, reason, frob); |
| 442 | 3075 } |
| 3076 | |
| 3077 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3078 invalid_operation_2 (const Ascbyte *reason, Lisp_Object frob1, |
| 609 | 3079 Lisp_Object frob2) |
| 442 | 3080 { |
| 563 | 3081 signal_error_2 (Qinvalid_operation, reason, frob1, frob2); |
| 3082 } | |
| 3083 | |
| 3084 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3085 maybe_invalid_operation (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3086 Lisp_Object class_, Error_Behavior errb) |
| 3087 { | |
| 3088 maybe_signal_error (Qinvalid_operation, reason, frob, class_, errb); | |
| 442 | 3089 } |
| 3090 | |
| 3091 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3092 invalid_change (const Ascbyte *reason, Lisp_Object frob) |
| 442 | 3093 { |
| 563 | 3094 signal_error (Qinvalid_change, reason, frob); |
| 442 | 3095 } |
| 3096 | |
| 3097 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3098 invalid_change_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2) |
| 442 | 3099 { |
| 563 | 3100 signal_error_2 (Qinvalid_change, reason, frob1, frob2); |
| 3101 } | |
| 3102 | |
| 3103 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3104 maybe_invalid_change (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3105 Lisp_Object class_, Error_Behavior errb) |
| 3106 { | |
| 3107 maybe_signal_error (Qinvalid_change, reason, frob, class_, errb); | |
| 563 | 3108 } |
| 3109 | |
| 3110 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3111 invalid_state (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3112 { |
| 3113 signal_error (Qinvalid_state, reason, frob); | |
| 3114 } | |
| 3115 | |
| 3116 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3117 invalid_state_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2) |
| 563 | 3118 { |
| 3119 signal_error_2 (Qinvalid_state, reason, frob1, frob2); | |
| 3120 } | |
| 3121 | |
| 3122 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3123 maybe_invalid_state (const Ascbyte *reason, Lisp_Object frob, |
| 1204 | 3124 Lisp_Object class_, Error_Behavior errb) |
| 3125 { | |
| 3126 maybe_signal_error (Qinvalid_state, reason, frob, class_, errb); | |
| 563 | 3127 } |
| 3128 | |
| 3129 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3130 wtaerror (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3131 { |
| 3132 signal_error (Qwrong_type_argument, reason, frob); | |
| 3133 } | |
| 3134 | |
| 3135 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3136 stack_overflow (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3137 { |
| 3138 signal_error (Qstack_overflow, reason, frob); | |
| 3139 } | |
| 3140 | |
| 3141 DOESNT_RETURN | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
3142 out_of_memory (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3143 { |
| 3144 signal_error (Qout_of_memory, reason, frob); | |
| 3145 } | |
| 3146 | |
| 428 | 3147 |
| 3148 /************************************************************************/ | |
| 3149 /* User commands */ | |
| 3150 /************************************************************************/ | |
| 3151 | |
| 3152 DEFUN ("commandp", Fcommandp, 1, 1, 0, /* | |
| 3153 Return t if FUNCTION makes provisions for interactive calling. | |
| 3154 This means it contains a description for how to read arguments to give it. | |
| 3155 The value is nil for an invalid function or a symbol with no function | |
| 3156 definition. | |
| 3157 | |
| 3158 Interactively callable functions include | |
| 3159 | |
| 3160 -- strings and vectors (treated as keyboard macros) | |
| 3161 -- lambda-expressions that contain a top-level call to `interactive' | |
| 3162 -- autoload definitions made by `autoload' with non-nil fourth argument | |
| 3163 (i.e. the interactive flag) | |
| 3164 -- compiled-function objects with a non-nil `compiled-function-interactive' | |
| 3165 value | |
| 3166 -- subrs (built-in functions) that are interactively callable | |
| 3167 | |
| 3168 Also, a symbol satisfies `commandp' if its function definition does so. | |
| 3169 */ | |
| 3170 (function)) | |
| 3171 { | |
| 3172 Lisp_Object fun = indirect_function (function, 0); | |
| 3173 | |
| 3174 if (COMPILED_FUNCTIONP (fun)) | |
| 3175 return XCOMPILED_FUNCTION (fun)->flags.interactivep ? Qt : Qnil; | |
| 3176 | |
| 3177 /* Lists may represent commands. */ | |
| 3178 if (CONSP (fun)) | |
| 3179 { | |
| 3180 Lisp_Object funcar = XCAR (fun); | |
| 3181 if (EQ (funcar, Qlambda)) | |
| 3182 return Fassq (Qinteractive, Fcdr (Fcdr (fun))); | |
| 3183 if (EQ (funcar, Qautoload)) | |
| 3184 return Fcar (Fcdr (Fcdr (Fcdr (fun)))); | |
| 3185 else | |
| 3186 return Qnil; | |
| 3187 } | |
| 3188 | |
| 3189 /* Emacs primitives are interactive if their DEFUN specifies an | |
| 3190 interactive spec. */ | |
| 3191 if (SUBRP (fun)) | |
| 3192 return XSUBR (fun)->prompt ? Qt : Qnil; | |
| 3193 | |
| 3194 /* Strings and vectors are keyboard macros. */ | |
| 3195 if (VECTORP (fun) || STRINGP (fun)) | |
| 3196 return Qt; | |
| 3197 | |
| 3198 /* Everything else (including Qunbound) is not a command. */ | |
| 3199 return Qnil; | |
| 3200 } | |
| 3201 | |
| 3202 DEFUN ("command-execute", Fcommand_execute, 1, 3, 0, /* | |
| 3203 Execute CMD as an editor command. | |
| 3204 CMD must be an object that satisfies the `commandp' predicate. | |
| 3205 Optional second arg RECORD-FLAG is as in `call-interactively'. | |
| 3206 The argument KEYS specifies the value to use instead of (this-command-keys) | |
| 3207 when reading the arguments. | |
| 3208 */ | |
| 444 | 3209 (cmd, record_flag, keys)) |
| 428 | 3210 { |
| 3211 /* This function can GC */ | |
| 3212 Lisp_Object prefixarg; | |
| 3213 Lisp_Object final = cmd; | |
| 4162 | 3214 PROFILE_DECLARE(); |
| 428 | 3215 struct console *con = XCONSOLE (Vselected_console); |
| 3216 | |
| 3217 prefixarg = con->prefix_arg; | |
| 3218 con->prefix_arg = Qnil; | |
| 3219 Vcurrent_prefix_arg = prefixarg; | |
| 3220 debug_on_next_call = 0; /* #### from FSFmacs; correct? */ | |
| 3221 | |
| 3222 if (SYMBOLP (cmd) && !NILP (Fget (cmd, Qdisabled, Qnil))) | |
| 733 | 3223 return run_hook (Qdisabled_command_hook); |
| 428 | 3224 |
| 3225 for (;;) | |
| 3226 { | |
| 3227 final = indirect_function (cmd, 1); | |
| 3228 if (CONSP (final) && EQ (Fcar (final), Qautoload)) | |
| 970 | 3229 { |
| 3230 /* do_autoload GCPROs both arguments */ | |
| 3231 do_autoload (final, cmd); | |
| 3232 } | |
| 428 | 3233 else |
| 3234 break; | |
| 3235 } | |
| 3236 | |
| 3237 if (CONSP (final) || SUBRP (final) || COMPILED_FUNCTIONP (final)) | |
| 3238 { | |
| 3239 backtrace.function = &Qcall_interactively; | |
| 3240 backtrace.args = &cmd; | |
| 3241 backtrace.nargs = 1; | |
| 3242 backtrace.evalargs = 0; | |
| 1292 | 3243 backtrace.pdlcount = specpdl_depth (); |
| 428 | 3244 backtrace.debug_on_exit = 0; |
| 1292 | 3245 backtrace.function_being_called = 0; |
| 428 | 3246 PUSH_BACKTRACE (backtrace); |
| 3247 | |
| 1292 | 3248 PROFILE_ENTER_FUNCTION (); |
| 444 | 3249 final = Fcall_interactively (cmd, record_flag, keys); |
| 1292 | 3250 PROFILE_EXIT_FUNCTION (); |
| 428 | 3251 |
| 3252 POP_BACKTRACE (backtrace); | |
| 3253 return final; | |
| 3254 } | |
| 3255 else if (STRINGP (final) || VECTORP (final)) | |
| 3256 { | |
| 3257 return Fexecute_kbd_macro (final, prefixarg); | |
| 3258 } | |
| 3259 else | |
| 3260 { | |
| 3261 Fsignal (Qwrong_type_argument, | |
| 3262 Fcons (Qcommandp, | |
| 3263 (EQ (cmd, final) | |
| 3264 ? list1 (cmd) | |
| 3265 : list2 (cmd, final)))); | |
| 3266 return Qnil; | |
| 3267 } | |
| 3268 } | |
| 3269 | |
| 3270 DEFUN ("interactive-p", Finteractive_p, 0, 0, 0, /* | |
| 3271 Return t if function in which this appears was called interactively. | |
| 3272 This means that the function was called with call-interactively (which | |
| 3273 includes being called as the binding of a key) | |
| 3274 and input is currently coming from the keyboard (not in keyboard macro). | |
| 3275 */ | |
| 3276 ()) | |
| 3277 { | |
| 3278 REGISTER struct backtrace *btp; | |
| 3279 REGISTER Lisp_Object fun; | |
| 3280 | |
| 3281 if (!INTERACTIVE) | |
| 3282 return Qnil; | |
| 3283 | |
| 3284 /* Unless the object was compiled, skip the frame of interactive-p itself | |
| 3285 (if interpreted) or the frame of byte-code (if called from a compiled | |
| 3286 function). Note that *btp->function may be a symbol pointing at a | |
| 3287 compiled function. */ | |
| 3288 btp = backtrace_list; | |
| 3289 | |
| 3290 #if 0 /* FSFmacs */ | |
| 3291 | |
| 3292 /* #### FSFmacs does the following instead. I can't figure | |
| 3293 out which one is more correct. */ | |
| 3294 /* If this isn't a byte-compiled function, there may be a frame at | |
| 3295 the top for Finteractive_p itself. If so, skip it. */ | |
| 3296 fun = Findirect_function (*btp->function); | |
| 3297 if (SUBRP (fun) && XSUBR (fun) == &Sinteractive_p) | |
| 3298 btp = btp->next; | |
| 3299 | |
| 3300 /* If we're running an Emacs 18-style byte-compiled function, there | |
| 3301 may be a frame for Fbyte_code. Now, given the strictest | |
| 3302 definition, this function isn't really being called | |
| 3303 interactively, but because that's the way Emacs 18 always builds | |
| 3304 byte-compiled functions, we'll accept it for now. */ | |
| 3305 if (EQ (*btp->function, Qbyte_code)) | |
| 3306 btp = btp->next; | |
| 3307 | |
| 3308 /* If this isn't a byte-compiled function, then we may now be | |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
3309 looking at several frames for special operators. Skip past them. */ |
| 428 | 3310 while (btp && |
| 3311 btp->nargs == UNEVALLED) | |
| 3312 btp = btp->next; | |
| 3313 | |
| 3314 #else | |
| 3315 | |
| 3316 if (! (COMPILED_FUNCTIONP (Findirect_function (*btp->function)))) | |
| 3317 btp = btp->next; | |
| 3318 for (; | |
| 3319 btp && (btp->nargs == UNEVALLED | |
| 3320 || EQ (*btp->function, Qbyte_code)); | |
| 3321 btp = btp->next) | |
| 3322 {} | |
| 3323 /* btp now points at the frame of the innermost function | |
| 3324 that DOES eval its args. | |
| 3325 If it is a built-in function (such as load or eval-region) | |
| 3326 return nil. */ | |
| 3327 /* Beats me why this is necessary, but it is */ | |
| 3328 if (btp && EQ (*btp->function, Qcall_interactively)) | |
| 3329 return Qt; | |
| 3330 | |
| 3331 #endif | |
| 3332 | |
| 3333 fun = Findirect_function (*btp->function); | |
| 3334 if (SUBRP (fun)) | |
| 3335 return Qnil; | |
| 3336 /* btp points to the frame of a Lisp function that called interactive-p. | |
| 3337 Return t if that function was called interactively. */ | |
| 3338 if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively)) | |
| 3339 return Qt; | |
| 3340 return Qnil; | |
| 3341 } | |
| 3342 | |
| 3343 | |
| 3344 /************************************************************************/ | |
| 3345 /* Autoloading */ | |
| 3346 /************************************************************************/ | |
| 3347 | |
| 3348 DEFUN ("autoload", Fautoload, 2, 5, 0, /* | |
| 444 | 3349 Define FUNCTION to autoload from FILENAME. |
| 3350 FUNCTION is a symbol; FILENAME is a file name string to pass to `load'. | |
| 3351 The remaining optional arguments provide additional info about the | |
| 3352 real definition. | |
| 3353 DOCSTRING is documentation for FUNCTION. | |
| 3354 INTERACTIVE, if non-nil, says FUNCTION can be called interactively. | |
| 3355 TYPE indicates the type of the object: | |
| 428 | 3356 nil or omitted says FUNCTION is a function, |
| 3357 `keymap' says FUNCTION is really a keymap, and | |
| 3358 `macro' or t says FUNCTION is really a macro. | |
| 444 | 3359 If FUNCTION already has a non-void function definition that is not an |
| 3360 autoload object, this function does nothing and returns nil. | |
| 428 | 3361 */ |
| 444 | 3362 (function, filename, docstring, interactive, type)) |
| 428 | 3363 { |
| 3364 /* This function can GC */ | |
| 3365 CHECK_SYMBOL (function); | |
| 444 | 3366 CHECK_STRING (filename); |
| 428 | 3367 |
| 3368 /* If function is defined and not as an autoload, don't override */ | |
| 3369 { | |
| 3370 Lisp_Object f = XSYMBOL (function)->function; | |
| 3371 if (!UNBOUNDP (f) && !(CONSP (f) && EQ (XCAR (f), Qautoload))) | |
| 3372 return Qnil; | |
| 3373 } | |
| 3374 | |
| 3375 if (purify_flag) | |
| 3376 { | |
| 3377 /* Attempt to avoid consing identical (string=) pure strings. */ | |
| 444 | 3378 filename = Fsymbol_name (Fintern (filename, Qnil)); |
| 428 | 3379 } |
| 440 | 3380 |
| 444 | 3381 return Ffset (function, Fcons (Qautoload, list4 (filename, |
| 428 | 3382 docstring, |
| 3383 interactive, | |
| 3384 type))); | |
| 3385 } | |
| 3386 | |
| 3387 Lisp_Object | |
| 3388 un_autoload (Lisp_Object oldqueue) | |
| 3389 { | |
| 3390 /* This function can GC */ | |
| 3391 REGISTER Lisp_Object queue, first, second; | |
| 3392 | |
| 3393 /* Queue to unwind is current value of Vautoload_queue. | |
| 3394 oldqueue is the shadowed value to leave in Vautoload_queue. */ | |
| 3395 queue = Vautoload_queue; | |
| 3396 Vautoload_queue = oldqueue; | |
| 3397 while (CONSP (queue)) | |
| 3398 { | |
| 3399 first = XCAR (queue); | |
| 3400 second = Fcdr (first); | |
| 3401 first = Fcar (first); | |
| 3402 if (NILP (second)) | |
| 3403 Vfeatures = first; | |
| 3404 else | |
| 3405 Ffset (first, second); | |
| 3406 queue = Fcdr (queue); | |
| 3407 } | |
| 3408 return Qnil; | |
| 3409 } | |
| 3410 | |
| 970 | 3411 /* do_autoload GCPROs both arguments */ |
| 428 | 3412 void |
| 3413 do_autoload (Lisp_Object fundef, | |
| 3414 Lisp_Object funname) | |
| 3415 { | |
| 3416 /* This function can GC */ | |
| 3417 int speccount = specpdl_depth(); | |
| 3418 Lisp_Object fun = funname; | |
| 970 | 3419 struct gcpro gcpro1, gcpro2, gcpro3; |
| 428 | 3420 |
| 3421 CHECK_SYMBOL (funname); | |
| 970 | 3422 GCPRO3 (fundef, funname, fun); |
| 428 | 3423 |
| 3424 /* Value saved here is to be restored into Vautoload_queue */ | |
| 3425 record_unwind_protect (un_autoload, Vautoload_queue); | |
| 3426 Vautoload_queue = Qt; | |
| 3427 call4 (Qload, Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, Qnil); | |
| 3428 | |
| 3429 { | |
| 3430 Lisp_Object queue; | |
| 3431 | |
| 3432 /* Save the old autoloads, in case we ever do an unload. */ | |
| 3433 for (queue = Vautoload_queue; CONSP (queue); queue = XCDR (queue)) | |
| 3434 { | |
| 3435 Lisp_Object first = XCAR (queue); | |
| 3436 Lisp_Object second = Fcdr (first); | |
| 3437 | |
| 3438 first = Fcar (first); | |
| 3439 | |
| 3440 /* Note: This test is subtle. The cdr of an autoload-queue entry | |
| 3441 may be an atom if the autoload entry was generated by a defalias | |
| 3442 or fset. */ | |
| 3443 if (CONSP (second)) | |
| 3444 Fput (first, Qautoload, (XCDR (second))); | |
| 3445 } | |
| 3446 } | |
| 3447 | |
| 3448 /* Once loading finishes, don't undo it. */ | |
| 3449 Vautoload_queue = Qt; | |
| 771 | 3450 unbind_to (speccount); |
| 428 | 3451 |
| 3452 fun = indirect_function (fun, 0); | |
| 3453 | |
| 3454 #if 0 /* FSFmacs */ | |
| 3455 if (!NILP (Fequal (fun, fundef))) | |
| 3456 #else | |
| 3457 if (UNBOUNDP (fun) | |
| 3458 || (CONSP (fun) | |
| 3459 && EQ (XCAR (fun), Qautoload))) | |
| 3460 #endif | |
| 563 | 3461 invalid_state ("Autoloading failed to define function", funname); |
| 428 | 3462 UNGCPRO; |
| 3463 } | |
| 3464 | |
| 3465 | |
| 3466 /************************************************************************/ | |
| 3467 /* eval, funcall, apply */ | |
| 3468 /************************************************************************/ | |
| 3469 | |
| 814 | 3470 /* NOTE: If you are hearing the endless complaint that function calls in |
| 3471 elisp are extremely slow, it just isn't true any more! The stuff below | |
| 3472 -- in particular, the calling of subrs and compiled functions, the most | |
| 3473 common cases -- has been highly optimized. There isn't a whole lot left | |
| 3474 to do to squeeze more speed out except by switching to lexical | |
| 3475 variables, which would eliminate the specbind loop. (But the real gain | |
| 3476 from lexical variables would come from better optimization -- with | |
| 3477 dynamic binding, you have the constant problem that any function call | |
| 3478 that you haven't explicitly proven to be side-effect-free might | |
| 3479 potentially side effect your local variables, which makes optimization | |
| 3480 extremely difficult when there are function calls anywhere in a chunk of | |
| 3481 code to be optimized. Even worse, you don't know that *your* local | |
| 3482 variables aren't side-effecting an outer function's local variables, so | |
| 3483 it's impossible to optimize away almost *any* variable assignment.) */ | |
| 3484 | |
| 428 | 3485 static Lisp_Object funcall_lambda (Lisp_Object fun, |
| 442 | 3486 int nargs, Lisp_Object args[]); |
| 428 | 3487 static int in_warnings; |
| 3488 | |
| 3489 | |
| 814 | 3490 void handle_compiled_function_with_and_rest (Lisp_Compiled_Function *f, |
| 3491 int nargs, | |
| 3492 Lisp_Object args[]); | |
| 3493 | |
| 3494 /* The theory behind making this a separate function is to shrink | |
| 3495 funcall_compiled_function() so as to increase the likelihood of a cache | |
| 3496 hit in the L1 cache -- &rest processing is not going to be fast anyway. | |
| 3497 The idea is the same as with execute_rare_opcode() in bytecode.c. We | |
| 3498 make this non-static to ensure the compiler doesn't inline it. */ | |
| 3499 | |
| 3500 void | |
| 3501 handle_compiled_function_with_and_rest (Lisp_Compiled_Function *f, int nargs, | |
| 3502 Lisp_Object args[]) | |
| 3503 { | |
| 3504 REGISTER int i = 0; | |
| 3505 int max_non_rest_args = f->args_in_array - 1; | |
| 3506 int bindargs = min (nargs, max_non_rest_args); | |
| 3507 | |
| 3508 for (i = 0; i < bindargs; i++) | |
| 3092 | 3509 #ifdef NEW_GC |
| 3510 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3511 args[i]); | |
| 3512 #else /* not NEW_GC */ | |
| 814 | 3513 SPECBIND_FAST_UNSAFE (f->args[i], args[i]); |
| 3092 | 3514 #endif /* not NEW_GC */ |
| 814 | 3515 for (i = bindargs; i < max_non_rest_args; i++) |
| 3092 | 3516 #ifdef NEW_GC |
| 3517 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3518 Qnil); | |
| 3519 #else /* not NEW_GC */ | |
| 814 | 3520 SPECBIND_FAST_UNSAFE (f->args[i], Qnil); |
| 3092 | 3521 #endif /* not NEW_GC */ |
| 3522 #ifdef NEW_GC | |
| 3523 SPECBIND_FAST_UNSAFE | |
| 3524 (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[max_non_rest_args], | |
| 3525 nargs > max_non_rest_args ? | |
| 3526 Flist (nargs - max_non_rest_args, &args[max_non_rest_args]) : | |
| 3527 Qnil); | |
| 3528 #else /* not NEW_GC */ | |
| 814 | 3529 SPECBIND_FAST_UNSAFE |
| 3530 (f->args[max_non_rest_args], | |
| 3531 nargs > max_non_rest_args ? | |
| 3532 Flist (nargs - max_non_rest_args, &args[max_non_rest_args]) : | |
| 3533 Qnil); | |
| 3092 | 3534 #endif /* not NEW_GC */ |
| 814 | 3535 } |
| 3536 | |
| 3537 /* Apply compiled-function object FUN to the NARGS evaluated arguments | |
| 3538 in ARGS, and return the result of evaluation. */ | |
| 3539 inline static Lisp_Object | |
| 3540 funcall_compiled_function (Lisp_Object fun, int nargs, Lisp_Object args[]) | |
| 3541 { | |
| 3542 /* This function can GC */ | |
| 3543 int speccount = specpdl_depth(); | |
| 3544 REGISTER int i = 0; | |
| 3545 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun); | |
| 3546 | |
| 3547 if (!OPAQUEP (f->instructions)) | |
| 3548 /* Lazily munge the instructions into a more efficient form */ | |
| 3549 optimize_compiled_function (fun); | |
| 3550 | |
| 3551 /* optimize_compiled_function() guaranteed that f->specpdl_depth is | |
| 3552 the required space on the specbinding stack for binding the args | |
| 3553 and local variables of fun. So just reserve it once. */ | |
| 3554 SPECPDL_RESERVE (f->specpdl_depth); | |
| 3555 | |
| 3556 if (nargs == f->max_args) /* Optimize for the common case -- no unspecified | |
| 3557 optional arguments. */ | |
| 3558 { | |
| 3559 #if 1 | |
| 3560 for (i = 0; i < nargs; i++) | |
| 3092 | 3561 #ifdef NEW_GC |
| 3562 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3563 args[i]); | |
| 3564 #else /* not NEW_GC */ | |
| 814 | 3565 SPECBIND_FAST_UNSAFE (f->args[i], args[i]); |
| 3092 | 3566 #endif /* not NEW_GC */ |
| 814 | 3567 #else |
| 3568 /* Here's an alternate way to write the loop that tries to further | |
| 3569 optimize funcalls for functions with few arguments by partially | |
| 3570 unrolling the loop. It's not clear whether this is a win since it | |
| 3571 increases the size of the function and the possibility of L1 cache | |
| 3572 misses. (Microsoft VC++ 6 with /O2 /G5 generates 0x90 == 144 bytes | |
| 3573 per SPECBIND_FAST_UNSAFE().) Tests under VC++ 6, running the byte | |
| 3574 compiler repeatedly and looking at the total time, show very | |
| 3575 little difference between the simple loop above, the unrolled code | |
| 3576 below, and a "partly unrolled" solution with only cases 0-2 below | |
| 3577 instead of 0-4. Therefore, I'm keeping it at the simple loop | |
| 3578 because it's smaller. */ | |
| 3579 switch (nargs) | |
| 3580 { | |
| 3581 default: | |
| 3582 for (i = nargs - 1; i >= 4; i--) | |
| 3583 SPECBIND_FAST_UNSAFE (f->args[i], args[i]); | |
| 3584 case 4: SPECBIND_FAST_UNSAFE (f->args[3], args[3]); | |
| 3585 case 3: SPECBIND_FAST_UNSAFE (f->args[2], args[2]); | |
| 3586 case 2: SPECBIND_FAST_UNSAFE (f->args[1], args[1]); | |
| 3587 case 1: SPECBIND_FAST_UNSAFE (f->args[0], args[0]); | |
| 3588 case 0: break; | |
| 3589 } | |
| 3590 #endif | |
| 3591 } | |
| 3592 else if (nargs < f->min_args) | |
| 3593 goto wrong_number_of_arguments; | |
| 3594 else if (nargs < f->max_args) | |
| 3595 { | |
| 3596 for (i = 0; i < nargs; i++) | |
| 3092 | 3597 #ifdef NEW_GC |
| 3598 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3599 args[i]); | |
| 3600 #else /* not NEW_GC */ | |
| 814 | 3601 SPECBIND_FAST_UNSAFE (f->args[i], args[i]); |
| 3092 | 3602 #endif /* not NEW_GC */ |
| 814 | 3603 for (i = nargs; i < f->max_args; i++) |
| 3092 | 3604 #ifdef NEW_GC |
| 3605 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3606 Qnil); | |
| 3607 #else /* not NEW_GC */ | |
| 814 | 3608 SPECBIND_FAST_UNSAFE (f->args[i], Qnil); |
| 3092 | 3609 #endif /* not NEW_GC */ |
| 814 | 3610 } |
| 3611 else if (f->max_args == MANY) | |
| 3612 handle_compiled_function_with_and_rest (f, nargs, args); | |
| 3613 else | |
| 3614 { | |
| 3615 wrong_number_of_arguments: | |
| 3616 /* The actual printed compiled_function object is incomprehensible. | |
| 3617 Check the backtrace to see if we can get a more meaningful symbol. */ | |
| 3618 if (EQ (fun, indirect_function (*backtrace_list->function, 0))) | |
| 3619 fun = *backtrace_list->function; | |
| 3620 return Fsignal (Qwrong_number_of_arguments, | |
| 3621 list2 (fun, make_int (nargs))); | |
| 3622 } | |
| 3623 | |
| 3624 { | |
| 3625 Lisp_Object value = | |
| 3626 execute_optimized_program ((Opbyte *) XOPAQUE_DATA (f->instructions), | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4905
diff
changeset
|
3627 #ifdef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4905
diff
changeset
|
3628 XOPAQUE_SIZE (f->instructions) / |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4905
diff
changeset
|
3629 sizeof (Opbyte), |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4905
diff
changeset
|
3630 #endif |
| 814 | 3631 f->stack_depth, |
| 3632 XVECTOR_DATA (f->constants)); | |
| 3633 | |
| 3634 /* The attempt to optimize this by only unbinding variables failed | |
| 3635 because using buffer-local variables as function parameters | |
| 3636 leads to specpdl_ptr->func != 0 */ | |
| 3637 /* UNBIND_TO_GCPRO_VARIABLES_ONLY (speccount, value); */ | |
| 3638 UNBIND_TO_GCPRO (speccount, value); | |
| 3639 return value; | |
| 3640 } | |
| 3641 } | |
| 3642 | |
| 428 | 3643 DEFUN ("eval", Feval, 1, 1, 0, /* |
| 3644 Evaluate FORM and return its value. | |
| 3645 */ | |
| 3646 (form)) | |
| 3647 { | |
| 3648 /* This function can GC */ | |
| 3649 Lisp_Object fun, val, original_fun, original_args; | |
| 3650 int nargs; | |
| 4162 | 3651 PROFILE_DECLARE(); |
| 428 | 3652 |
| 1318 | 3653 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS |
| 3654 check_proper_critical_section_lisp_protection (); | |
| 3655 #endif | |
| 3656 | |
| 3989 | 3657 if (!CONSP (form)) |
| 3658 { | |
| 3659 if (SYMBOLP (form)) | |
| 3660 { | |
| 3661 return Fsymbol_value (form); | |
| 3662 } | |
| 3663 | |
| 3664 return form; | |
| 3665 } | |
| 3666 | |
| 428 | 3667 /* I think this is a pretty safe place to call Lisp code, don't you? */ |
| 853 | 3668 while (!in_warnings && !NILP (Vpending_warnings) |
| 3669 /* well, perhaps not so safe after all! */ | |
| 3670 && !(inhibit_flags & INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY)) | |
| 428 | 3671 { |
| 3672 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; | |
| 1204 | 3673 Lisp_Object this_warning_cons, this_warning, class_, level, messij; |
| 853 | 3674 int speccount = internal_bind_int (&in_warnings, 1); |
| 3675 | |
| 428 | 3676 this_warning_cons = Vpending_warnings; |
| 3677 this_warning = XCAR (this_warning_cons); | |
| 3678 /* in case an error occurs in the warn function, at least | |
| 3679 it won't happen infinitely */ | |
| 3680 Vpending_warnings = XCDR (Vpending_warnings); | |
| 853 | 3681 free_cons (this_warning_cons); |
| 1204 | 3682 class_ = XCAR (this_warning); |
| 428 | 3683 level = XCAR (XCDR (this_warning)); |
| 3684 messij = XCAR (XCDR (XCDR (this_warning))); | |
| 3685 free_list (this_warning); | |
| 3686 | |
| 3687 if (NILP (Vpending_warnings)) | |
| 3688 Vpending_warnings_tail = Qnil; /* perhaps not strictly necessary, | |
| 3689 but safer */ | |
| 3690 | |
| 1204 | 3691 GCPRO4 (form, class_, level, messij); |
| 428 | 3692 if (!STRINGP (messij)) |
| 3693 messij = Fprin1_to_string (messij, Qnil); | |
| 1204 | 3694 call3 (Qdisplay_warning, class_, messij, level); |
| 428 | 3695 UNGCPRO; |
| 771 | 3696 unbind_to (speccount); |
| 428 | 3697 } |
| 3698 | |
| 3699 QUIT; | |
| 814 | 3700 if (need_to_garbage_collect) |
| 428 | 3701 { |
| 3702 struct gcpro gcpro1; | |
| 3703 GCPRO1 (form); | |
| 3092 | 3704 #ifdef NEW_GC |
| 3705 gc_incremental (); | |
| 3706 #else /* not NEW_GC */ | |
| 428 | 3707 garbage_collect_1 (); |
| 3092 | 3708 #endif /* not NEW_GC */ |
| 428 | 3709 UNGCPRO; |
| 3710 } | |
| 3711 | |
| 3712 if (++lisp_eval_depth > max_lisp_eval_depth) | |
| 3713 { | |
| 3714 if (max_lisp_eval_depth < 100) | |
| 3715 max_lisp_eval_depth = 100; | |
| 3716 if (lisp_eval_depth > max_lisp_eval_depth) | |
| 563 | 3717 stack_overflow ("Lisp nesting exceeds `max-lisp-eval-depth'", |
| 3718 Qunbound); | |
| 428 | 3719 } |
| 3720 | |
| 3721 /* We guaranteed CONSP (form) above */ | |
| 3722 original_fun = XCAR (form); | |
| 3723 original_args = XCDR (form); | |
| 3724 | |
| 3725 GET_EXTERNAL_LIST_LENGTH (original_args, nargs); | |
| 3726 | |
| 3727 backtrace.pdlcount = specpdl_depth(); | |
| 3728 backtrace.function = &original_fun; /* This also protects them from gc */ | |
| 3729 backtrace.args = &original_args; | |
| 3730 backtrace.nargs = UNEVALLED; | |
| 3731 backtrace.evalargs = 1; | |
| 3732 backtrace.debug_on_exit = 0; | |
| 1292 | 3733 backtrace.function_being_called = 0; |
| 428 | 3734 PUSH_BACKTRACE (backtrace); |
| 3735 | |
| 3736 if (debug_on_next_call) | |
| 3737 do_debug_on_call (Qt); | |
| 3738 | |
| 3739 /* At this point, only original_fun and original_args | |
| 3740 have values that will be used below. */ | |
| 3741 retry: | |
| 3989 | 3742 /* Optimise for no indirection. */ |
| 3743 fun = original_fun; | |
| 3744 if (SYMBOLP (fun) && !EQ (fun, Qunbound) | |
| 3745 && (fun = XSYMBOL (fun)->function, SYMBOLP (fun))) | |
| 3746 { | |
| 3747 fun = indirect_function(original_fun, 1); | |
| 3748 } | |
| 428 | 3749 |
| 3750 if (SUBRP (fun)) | |
| 3751 { | |
| 3752 Lisp_Subr *subr = XSUBR (fun); | |
| 3753 int max_args = subr->max_args; | |
| 3754 | |
| 3755 if (nargs < subr->min_args) | |
| 3756 goto wrong_number_of_arguments; | |
| 3757 | |
| 3758 if (max_args == UNEVALLED) /* Optimize for the common case */ | |
| 3759 { | |
| 3760 backtrace.evalargs = 0; | |
| 1292 | 3761 PROFILE_ENTER_FUNCTION (); |
| 428 | 3762 val = (((Lisp_Object (*) (Lisp_Object)) subr_function (subr)) |
| 3763 (original_args)); | |
| 1292 | 3764 PROFILE_EXIT_FUNCTION (); |
| 428 | 3765 } |
| 3766 else if (nargs <= max_args) | |
| 3767 { | |
| 3768 struct gcpro gcpro1; | |
| 3769 Lisp_Object args[SUBR_MAX_ARGS]; | |
| 3770 REGISTER Lisp_Object *p = args; | |
| 3771 | |
| 3772 GCPRO1 (args[0]); | |
| 3773 gcpro1.nvars = 0; | |
| 3774 | |
| 3775 { | |
| 3776 LIST_LOOP_2 (arg, original_args) | |
| 3777 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
3778 *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); |
| 428 | 3779 gcpro1.nvars++; |
| 3780 } | |
| 3781 } | |
| 3782 | |
| 3783 /* &optional args default to nil. */ | |
| 3784 while (p - args < max_args) | |
| 3785 *p++ = Qnil; | |
| 3786 | |
| 3787 backtrace.args = args; | |
| 3788 backtrace.nargs = nargs; | |
| 3789 | |
| 1292 | 3790 PROFILE_ENTER_FUNCTION (); |
| 428 | 3791 FUNCALL_SUBR (val, subr, args, max_args); |
| 1292 | 3792 PROFILE_EXIT_FUNCTION (); |
| 428 | 3793 |
| 3794 UNGCPRO; | |
| 3795 } | |
| 3796 else if (max_args == MANY) | |
| 3797 { | |
| 3798 /* Pass a vector of evaluated arguments */ | |
| 3799 struct gcpro gcpro1; | |
| 3800 Lisp_Object *args = alloca_array (Lisp_Object, nargs); | |
| 3801 REGISTER Lisp_Object *p = args; | |
| 3802 | |
| 3803 GCPRO1 (args[0]); | |
| 3804 gcpro1.nvars = 0; | |
| 3805 | |
| 3806 { | |
| 3807 LIST_LOOP_2 (arg, original_args) | |
| 3808 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
3809 *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); |
| 428 | 3810 gcpro1.nvars++; |
| 3811 } | |
| 3812 } | |
| 3813 | |
| 3814 backtrace.args = args; | |
| 3815 backtrace.nargs = nargs; | |
| 3816 | |
| 1292 | 3817 PROFILE_ENTER_FUNCTION (); |
| 428 | 3818 val = (((Lisp_Object (*) (int, Lisp_Object *)) subr_function (subr)) |
| 3819 (nargs, args)); | |
| 1292 | 3820 PROFILE_EXIT_FUNCTION (); |
| 428 | 3821 |
| 3822 UNGCPRO; | |
| 3823 } | |
| 3824 else | |
| 3825 { | |
| 3826 wrong_number_of_arguments: | |
| 440 | 3827 val = signal_wrong_number_of_arguments_error (original_fun, nargs); |
| 428 | 3828 } |
| 3829 } | |
| 3830 else if (COMPILED_FUNCTIONP (fun)) | |
| 3831 { | |
| 3832 struct gcpro gcpro1; | |
| 3833 Lisp_Object *args = alloca_array (Lisp_Object, nargs); | |
| 3834 REGISTER Lisp_Object *p = args; | |
| 3835 | |
| 3836 GCPRO1 (args[0]); | |
| 3837 gcpro1.nvars = 0; | |
| 3838 | |
| 3839 { | |
| 3840 LIST_LOOP_2 (arg, original_args) | |
| 3841 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
3842 *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); |
| 428 | 3843 gcpro1.nvars++; |
| 3844 } | |
| 3845 } | |
| 3846 | |
| 3847 backtrace.args = args; | |
| 3848 backtrace.nargs = nargs; | |
| 3849 backtrace.evalargs = 0; | |
| 3850 | |
| 1292 | 3851 PROFILE_ENTER_FUNCTION (); |
| 428 | 3852 val = funcall_compiled_function (fun, nargs, args); |
| 1292 | 3853 PROFILE_EXIT_FUNCTION (); |
| 428 | 3854 |
| 3855 /* Do the debug-on-exit now, while args is still GCPROed. */ | |
| 3856 if (backtrace.debug_on_exit) | |
| 3857 val = do_debug_on_exit (val); | |
| 3858 /* Don't do it again when we return to eval. */ | |
| 3859 backtrace.debug_on_exit = 0; | |
| 3860 | |
| 3861 UNGCPRO; | |
| 3862 } | |
| 3863 else if (CONSP (fun)) | |
| 3864 { | |
| 3865 Lisp_Object funcar = XCAR (fun); | |
| 3866 | |
| 3867 if (EQ (funcar, Qautoload)) | |
| 3868 { | |
| 970 | 3869 /* do_autoload GCPROs both arguments */ |
| 428 | 3870 do_autoload (fun, original_fun); |
| 3871 goto retry; | |
| 3872 } | |
| 3873 else if (EQ (funcar, Qmacro)) | |
| 3874 { | |
| 1292 | 3875 PROFILE_ENTER_FUNCTION (); |
| 428 | 3876 val = Feval (apply1 (XCDR (fun), original_args)); |
| 1292 | 3877 PROFILE_EXIT_FUNCTION (); |
| 428 | 3878 } |
| 3879 else if (EQ (funcar, Qlambda)) | |
| 3880 { | |
| 3881 struct gcpro gcpro1; | |
| 3882 Lisp_Object *args = alloca_array (Lisp_Object, nargs); | |
| 3883 REGISTER Lisp_Object *p = args; | |
| 3884 | |
| 3885 GCPRO1 (args[0]); | |
| 3886 gcpro1.nvars = 0; | |
| 3887 | |
| 3888 { | |
| 3889 LIST_LOOP_2 (arg, original_args) | |
| 3890 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
3891 *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); |
| 428 | 3892 gcpro1.nvars++; |
| 3893 } | |
| 3894 } | |
| 3895 | |
| 3896 UNGCPRO; | |
| 3897 | |
| 3898 backtrace.args = args; /* this also GCPROs `args' */ | |
| 3899 backtrace.nargs = nargs; | |
| 3900 backtrace.evalargs = 0; | |
| 3901 | |
| 1292 | 3902 PROFILE_ENTER_FUNCTION (); |
| 428 | 3903 val = funcall_lambda (fun, nargs, args); |
| 1292 | 3904 PROFILE_EXIT_FUNCTION (); |
| 428 | 3905 |
| 3906 /* Do the debug-on-exit now, while args is still GCPROed. */ | |
| 3907 if (backtrace.debug_on_exit) | |
| 3908 val = do_debug_on_exit (val); | |
| 3909 /* Don't do it again when we return to eval. */ | |
| 3910 backtrace.debug_on_exit = 0; | |
| 3911 } | |
| 3912 else | |
| 3913 { | |
| 3914 goto invalid_function; | |
| 3915 } | |
| 3916 } | |
| 4104 | 3917 else if (UNBOUNDP (fun)) |
| 3918 { | |
| 3919 val = signal_void_function_error (original_fun); | |
| 3920 } | |
| 3921 else /* ! (SUBRP (fun) || COMPILED_FUNCTIONP (fun) || CONSP (fun) | |
| 3922 UNBOUNDP (fun)) */ | |
| 428 | 3923 { |
| 3924 invalid_function: | |
| 436 | 3925 val = signal_invalid_function_error (fun); |
| 428 | 3926 } |
| 3927 | |
| 3928 lisp_eval_depth--; | |
| 3929 if (backtrace.debug_on_exit) | |
| 3930 val = do_debug_on_exit (val); | |
| 3931 POP_BACKTRACE (backtrace); | |
| 3932 return val; | |
| 3933 } | |
| 3934 | |
| 3935 | |
| 1111 | 3936 |
| 3937 static void | |
| 3938 run_post_gc_hook (void) | |
| 3939 { | |
| 3940 Lisp_Object args[2]; | |
| 3941 | |
| 3942 args[0] = Qpost_gc_hook; | |
| 3943 args[1] = Fcons (Fcons (Qfinalize_list, zap_finalize_list ()), Qnil); | |
| 3944 | |
| 3945 run_hook_with_args_trapping_problems | |
| 1333 | 3946 (Qgarbage_collecting, 2, args, RUN_HOOKS_TO_COMPLETION, |
| 1111 | 3947 INHIBIT_QUIT | NO_INHIBIT_ERRORS); |
| 3948 } | |
| 3949 | |
| 428 | 3950 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
|
3951 Call FUNCTION as a function, passing the remaining arguments to it. |
| 428 | 3952 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
|
3953 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
3954 arguments: (FUNCTION &rest ARGS) |
| 428 | 3955 */ |
| 3956 (int nargs, Lisp_Object *args)) | |
| 3957 { | |
| 3958 /* This function can GC */ | |
| 3959 Lisp_Object fun; | |
| 3960 Lisp_Object val; | |
| 4162 | 3961 PROFILE_DECLARE(); |
| 428 | 3962 int fun_nargs = nargs - 1; |
| 3963 Lisp_Object *fun_args = args + 1; | |
| 3964 | |
| 1318 | 3965 /* QUIT will check for proper redisplay wrapping */ |
| 3966 | |
| 428 | 3967 QUIT; |
| 851 | 3968 |
| 3969 if (funcall_allocation_flag) | |
| 3970 { | |
| 3971 if (need_to_garbage_collect) | |
| 3972 /* Callers should gcpro lexpr args */ | |
| 3092 | 3973 #ifdef NEW_GC |
| 3974 gc_incremental (); | |
| 3975 #else /* not NEW_GC */ | |
| 851 | 3976 garbage_collect_1 (); |
| 3092 | 3977 #endif /* not NEW_GC */ |
| 851 | 3978 if (need_to_check_c_alloca) |
| 3979 { | |
| 3980 if (++funcall_alloca_count >= MAX_FUNCALLS_BETWEEN_ALLOCA_CLEANUP) | |
| 3981 { | |
| 3982 xemacs_c_alloca (0); | |
| 3983 funcall_alloca_count = 0; | |
| 3984 } | |
| 3985 } | |
| 887 | 3986 if (need_to_signal_post_gc) |
| 3987 { | |
| 3988 need_to_signal_post_gc = 0; | |
| 1111 | 3989 recompute_funcall_allocation_flag (); |
| 3263 | 3990 #ifdef NEW_GC |
| 3991 run_finalizers (); | |
| 3992 #endif /* NEW_GC */ | |
| 1111 | 3993 run_post_gc_hook (); |
| 887 | 3994 } |
| 851 | 3995 } |
| 428 | 3996 |
| 3997 if (++lisp_eval_depth > max_lisp_eval_depth) | |
| 3998 { | |
| 3999 if (max_lisp_eval_depth < 100) | |
| 4000 max_lisp_eval_depth = 100; | |
| 4001 if (lisp_eval_depth > max_lisp_eval_depth) | |
| 563 | 4002 stack_overflow ("Lisp nesting exceeds `max-lisp-eval-depth'", |
| 4003 Qunbound); | |
| 428 | 4004 } |
| 4005 | |
| 1292 | 4006 backtrace.pdlcount = specpdl_depth (); |
| 428 | 4007 backtrace.function = &args[0]; |
| 4008 backtrace.args = fun_args; | |
| 4009 backtrace.nargs = fun_nargs; | |
| 4010 backtrace.evalargs = 0; | |
| 4011 backtrace.debug_on_exit = 0; | |
| 1292 | 4012 backtrace.function_being_called = 0; |
| 428 | 4013 PUSH_BACKTRACE (backtrace); |
| 4014 | |
| 4015 if (debug_on_next_call) | |
| 4016 do_debug_on_call (Qlambda); | |
| 4017 | |
| 4018 retry: | |
| 4019 | |
| 4020 fun = args[0]; | |
| 4021 | |
| 4022 /* We could call indirect_function directly, but profiling shows | |
| 4023 this is worth optimizing by partially unrolling the loop. */ | |
| 4024 if (SYMBOLP (fun)) | |
| 4025 { | |
| 4026 fun = XSYMBOL (fun)->function; | |
| 4027 if (SYMBOLP (fun)) | |
| 4028 { | |
| 4029 fun = XSYMBOL (fun)->function; | |
| 4030 if (SYMBOLP (fun)) | |
| 4031 fun = indirect_function (fun, 1); | |
| 4032 } | |
| 4033 } | |
| 4034 | |
| 4035 if (SUBRP (fun)) | |
| 4036 { | |
| 4037 Lisp_Subr *subr = XSUBR (fun); | |
| 4038 int max_args = subr->max_args; | |
| 4039 Lisp_Object spacious_args[SUBR_MAX_ARGS]; | |
| 4040 | |
| 4041 if (fun_nargs == max_args) /* Optimize for the common case */ | |
| 4042 { | |
| 4043 funcall_subr: | |
| 1292 | 4044 PROFILE_ENTER_FUNCTION (); |
| 428 | 4045 FUNCALL_SUBR (val, subr, fun_args, max_args); |
| 1292 | 4046 PROFILE_EXIT_FUNCTION (); |
| 428 | 4047 } |
| 436 | 4048 else if (fun_nargs < subr->min_args) |
| 4049 { | |
| 4050 goto wrong_number_of_arguments; | |
| 4051 } | |
| 428 | 4052 else if (fun_nargs < max_args) |
| 4053 { | |
| 4054 Lisp_Object *p = spacious_args; | |
| 4055 | |
| 4056 /* Default optionals to nil */ | |
| 4057 while (fun_nargs--) | |
| 4058 *p++ = *fun_args++; | |
| 4059 while (p - spacious_args < max_args) | |
| 4060 *p++ = Qnil; | |
| 4061 | |
| 4062 fun_args = spacious_args; | |
| 4063 goto funcall_subr; | |
| 4064 } | |
| 4065 else if (max_args == MANY) | |
| 4066 { | |
| 1292 | 4067 PROFILE_ENTER_FUNCTION (); |
| 436 | 4068 val = SUBR_FUNCTION (subr, MANY) (fun_nargs, fun_args); |
| 1292 | 4069 PROFILE_EXIT_FUNCTION (); |
| 428 | 4070 } |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
4071 else if (max_args == UNEVALLED) /* Can't funcall a special operator */ |
| 428 | 4072 { |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4073 /* Ugh, ugh, ugh. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4074 if (EQ (fun, XSYMBOL_FUNCTION (Qthrow))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4075 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4076 args[0] = Qobsolete_throw; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4077 goto retry; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4078 } |
| 428 | 4079 goto invalid_function; |
| 4080 } | |
| 4081 else | |
| 4082 { | |
| 4083 wrong_number_of_arguments: | |
| 436 | 4084 val = signal_wrong_number_of_arguments_error (fun, fun_nargs); |
| 428 | 4085 } |
| 4086 } | |
| 4087 else if (COMPILED_FUNCTIONP (fun)) | |
| 4088 { | |
| 1292 | 4089 PROFILE_ENTER_FUNCTION (); |
| 428 | 4090 val = funcall_compiled_function (fun, fun_nargs, fun_args); |
| 1292 | 4091 PROFILE_EXIT_FUNCTION (); |
| 428 | 4092 } |
| 4093 else if (CONSP (fun)) | |
| 4094 { | |
| 4095 Lisp_Object funcar = XCAR (fun); | |
| 4096 | |
| 4097 if (EQ (funcar, Qlambda)) | |
| 4098 { | |
| 1292 | 4099 PROFILE_ENTER_FUNCTION (); |
| 428 | 4100 val = funcall_lambda (fun, fun_nargs, fun_args); |
| 1292 | 4101 PROFILE_EXIT_FUNCTION (); |
| 428 | 4102 } |
| 4103 else if (EQ (funcar, Qautoload)) | |
| 4104 { | |
| 970 | 4105 /* do_autoload GCPROs both arguments */ |
| 428 | 4106 do_autoload (fun, args[0]); |
| 4107 goto retry; | |
| 4108 } | |
| 4109 else /* Can't funcall a macro */ | |
| 4110 { | |
| 4111 goto invalid_function; | |
| 4112 } | |
| 4113 } | |
| 4114 else if (UNBOUNDP (fun)) | |
| 4115 { | |
| 436 | 4116 val = signal_void_function_error (args[0]); |
| 428 | 4117 } |
| 4118 else | |
| 4119 { | |
| 4120 invalid_function: | |
| 436 | 4121 val = signal_invalid_function_error (fun); |
| 428 | 4122 } |
| 4123 | |
| 4124 lisp_eval_depth--; | |
| 4125 if (backtrace.debug_on_exit) | |
| 4126 val = do_debug_on_exit (val); | |
| 4127 POP_BACKTRACE (backtrace); | |
| 4128 return val; | |
| 4129 } | |
| 4130 | |
| 4131 DEFUN ("functionp", Ffunctionp, 1, 1, 0, /* | |
| 4132 Return t if OBJECT can be called as a function, else nil. | |
| 4133 A function is an object that can be applied to arguments, | |
| 4134 using for example `funcall' or `apply'. | |
| 4135 */ | |
| 4136 (object)) | |
| 4137 { | |
| 4138 if (SYMBOLP (object)) | |
| 4139 object = indirect_function (object, 0); | |
| 4140 | |
|
4795
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4744
diff
changeset
|
4141 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
|
4142 || (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
|
4143 && (XSUBR (object)->max_args != UNEVALLED))) |
| 919 | 4144 return Qt; |
| 4145 if (CONSP (object)) | |
| 4146 { | |
| 4147 Lisp_Object car = XCAR (object); | |
| 4148 if (EQ (car, Qlambda)) | |
| 4149 return Qt; | |
| 4150 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
|
4151 && 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
|
4152 (Fcdr_safe (XCDR (object))))))) |
| 919 | 4153 return Qt; |
| 4154 } | |
| 4155 return Qnil; | |
| 428 | 4156 } |
| 4157 | |
| 4158 static Lisp_Object | |
| 4159 function_argcount (Lisp_Object function, int function_min_args_p) | |
| 4160 { | |
| 4161 Lisp_Object orig_function = function; | |
| 4162 Lisp_Object arglist; | |
| 4163 | |
| 4164 retry: | |
| 4165 | |
| 4166 if (SYMBOLP (function)) | |
| 4167 function = indirect_function (function, 1); | |
| 4168 | |
| 4169 if (SUBRP (function)) | |
| 4170 { | |
| 442 | 4171 /* Using return with the ?: operator tickles a DEC CC compiler bug. */ |
| 4172 if (function_min_args_p) | |
| 4173 return Fsubr_min_args (function); | |
| 4174 else | |
| 4175 return Fsubr_max_args (function); | |
| 428 | 4176 } |
| 4177 else if (COMPILED_FUNCTIONP (function)) | |
| 4178 { | |
| 814 | 4179 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (function); |
| 4180 | |
| 1737 | 4181 if (!OPAQUEP (f->instructions)) |
| 4182 /* Lazily munge the instructions into a more efficient form */ | |
| 4183 /* Needed to set max_args */ | |
| 4184 optimize_compiled_function (function); | |
| 4185 | |
| 814 | 4186 if (function_min_args_p) |
| 4187 return make_int (f->min_args); | |
| 4188 else if (f->max_args == MANY) | |
| 4189 return Qnil; | |
| 4190 else | |
| 4191 return make_int (f->max_args); | |
| 428 | 4192 } |
| 4193 else if (CONSP (function)) | |
| 4194 { | |
| 4195 Lisp_Object funcar = XCAR (function); | |
| 4196 | |
| 4197 if (EQ (funcar, Qmacro)) | |
| 4198 { | |
| 4199 function = XCDR (function); | |
| 4200 goto retry; | |
| 4201 } | |
| 4202 else if (EQ (funcar, Qautoload)) | |
| 4203 { | |
| 970 | 4204 /* do_autoload GCPROs both arguments */ |
| 428 | 4205 do_autoload (function, orig_function); |
| 442 | 4206 function = orig_function; |
| 428 | 4207 goto retry; |
| 4208 } | |
| 4209 else if (EQ (funcar, Qlambda)) | |
| 4210 { | |
| 4211 arglist = Fcar (XCDR (function)); | |
| 4212 } | |
| 4213 else | |
| 4214 { | |
| 4215 goto invalid_function; | |
| 4216 } | |
| 4217 } | |
| 4218 else | |
| 4219 { | |
| 4220 invalid_function: | |
| 442 | 4221 return signal_invalid_function_error (orig_function); |
| 428 | 4222 } |
| 4223 | |
| 4224 { | |
| 4225 int argcount = 0; | |
| 4226 | |
| 4227 EXTERNAL_LIST_LOOP_2 (arg, arglist) | |
| 4228 { | |
| 4229 if (EQ (arg, Qand_optional)) | |
| 4230 { | |
| 4231 if (function_min_args_p) | |
| 4232 break; | |
| 4233 } | |
| 4234 else if (EQ (arg, Qand_rest)) | |
| 4235 { | |
| 4236 if (function_min_args_p) | |
| 4237 break; | |
| 4238 else | |
| 4239 return Qnil; | |
| 4240 } | |
| 4241 else | |
| 4242 { | |
| 4243 argcount++; | |
| 4244 } | |
| 4245 } | |
| 4246 | |
| 4247 return make_int (argcount); | |
| 4248 } | |
| 4249 } | |
| 4250 | |
| 4251 DEFUN ("function-min-args", Ffunction_min_args, 1, 1, 0, /* | |
| 617 | 4252 Return the minimum number of arguments a function may be called with. |
| 428 | 4253 The function may be any form that can be passed to `funcall', |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
4254 any special operator, or any macro. |
| 853 | 4255 |
| 4256 To check if a function can be called with a specified number of | |
| 4257 arguments, use `function-allows-args'. | |
| 428 | 4258 */ |
| 4259 (function)) | |
| 4260 { | |
| 4261 return function_argcount (function, 1); | |
| 4262 } | |
| 4263 | |
| 4264 DEFUN ("function-max-args", Ffunction_max_args, 1, 1, 0, /* | |
| 617 | 4265 Return the maximum number of arguments a function may be called with. |
| 428 | 4266 The function may be any form that can be passed to `funcall', |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
4267 any special operator, or any macro. |
| 428 | 4268 If the function takes an arbitrary number of arguments or is |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
4269 a built-in special operator, nil is returned. |
| 853 | 4270 |
| 4271 To check if a function can be called with a specified number of | |
| 4272 arguments, use `function-allows-args'. | |
| 428 | 4273 */ |
| 4274 (function)) | |
| 4275 { | |
| 4276 return function_argcount (function, 0); | |
| 4277 } | |
| 4278 | |
| 4279 | |
| 4280 DEFUN ("apply", Fapply, 2, MANY, 0, /* | |
| 4281 Call FUNCTION with the remaining args, using the last arg as a list of args. | |
| 4282 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
|
4283 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
4284 arguments: (FUNCTION &rest ARGS) |
| 428 | 4285 */ |
| 4286 (int nargs, Lisp_Object *args)) | |
| 4287 { | |
| 4288 /* This function can GC */ | |
| 4289 Lisp_Object fun = args[0]; | |
| 4290 Lisp_Object spread_arg = args [nargs - 1]; | |
| 4291 int numargs; | |
| 4292 int funcall_nargs; | |
| 4293 | |
| 4294 GET_EXTERNAL_LIST_LENGTH (spread_arg, numargs); | |
| 4295 | |
| 4296 if (numargs == 0) | |
| 4297 /* (apply foo 0 1 '()) */ | |
| 4298 return Ffuncall (nargs - 1, args); | |
| 4299 else if (numargs == 1) | |
| 4300 { | |
| 4301 /* (apply foo 0 1 '(2)) */ | |
| 4302 args [nargs - 1] = XCAR (spread_arg); | |
| 4303 return Ffuncall (nargs, args); | |
| 4304 } | |
| 4305 | |
| 4306 /* -1 for function, -1 for spread arg */ | |
| 4307 numargs = nargs - 2 + numargs; | |
| 4308 /* +1 for function */ | |
| 4309 funcall_nargs = 1 + numargs; | |
| 4310 | |
| 4311 if (SYMBOLP (fun)) | |
| 4312 fun = indirect_function (fun, 0); | |
| 4313 | |
| 4314 if (SUBRP (fun)) | |
| 4315 { | |
| 4316 Lisp_Subr *subr = XSUBR (fun); | |
| 4317 int max_args = subr->max_args; | |
| 4318 | |
| 4319 if (numargs < subr->min_args | |
| 4320 || (max_args >= 0 && max_args < numargs)) | |
| 4321 { | |
| 4322 /* Let funcall get the error */ | |
| 4323 } | |
| 4324 else if (max_args > numargs) | |
| 4325 { | |
| 4326 /* Avoid having funcall cons up yet another new vector of arguments | |
| 4327 by explicitly supplying nil's for optional values */ | |
| 4328 funcall_nargs += (max_args - numargs); | |
| 4329 } | |
| 4330 } | |
| 4331 else if (UNBOUNDP (fun)) | |
| 4332 { | |
| 4333 /* Let funcall get the error */ | |
| 4334 fun = args[0]; | |
| 4335 } | |
| 4336 | |
| 4337 { | |
| 4338 REGISTER int i; | |
| 4339 Lisp_Object *funcall_args = alloca_array (Lisp_Object, funcall_nargs); | |
| 4340 struct gcpro gcpro1; | |
| 4341 | |
| 4342 GCPRO1 (*funcall_args); | |
| 4343 gcpro1.nvars = funcall_nargs; | |
| 4344 | |
| 4345 /* Copy in the unspread args */ | |
| 4346 memcpy (funcall_args, args, (nargs - 1) * sizeof (Lisp_Object)); | |
| 4347 /* Spread the last arg we got. Its first element goes in | |
| 4348 the slot that it used to occupy, hence this value of I. */ | |
| 4349 for (i = nargs - 1; | |
| 4350 !NILP (spread_arg); /* i < 1 + numargs */ | |
| 4351 i++, spread_arg = XCDR (spread_arg)) | |
| 4352 { | |
| 4353 funcall_args [i] = XCAR (spread_arg); | |
| 4354 } | |
| 4355 /* Supply nil for optional args (to subrs) */ | |
| 4356 for (; i < funcall_nargs; i++) | |
| 4357 funcall_args[i] = Qnil; | |
| 4358 | |
| 4359 | |
| 4360 RETURN_UNGCPRO (Ffuncall (funcall_nargs, funcall_args)); | |
| 4361 } | |
| 4362 } | |
| 4363 | |
| 4364 /* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and | |
| 4365 return the result of evaluation. */ | |
| 4366 | |
| 4367 static Lisp_Object | |
| 4368 funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object args[]) | |
| 4369 { | |
| 4370 /* This function can GC */ | |
| 442 | 4371 Lisp_Object arglist, body, tail; |
| 428 | 4372 int speccount = specpdl_depth(); |
| 4373 REGISTER int i = 0; | |
| 4374 | |
| 4375 tail = XCDR (fun); | |
| 4376 | |
| 4377 if (!CONSP (tail)) | |
| 4378 goto invalid_function; | |
| 4379 | |
| 4380 arglist = XCAR (tail); | |
| 4381 body = XCDR (tail); | |
| 4382 | |
| 4383 { | |
| 4384 int optional = 0, rest = 0; | |
| 4385 | |
| 442 | 4386 EXTERNAL_LIST_LOOP_2 (symbol, arglist) |
| 428 | 4387 { |
| 4388 if (!SYMBOLP (symbol)) | |
| 4389 goto invalid_function; | |
| 4390 if (EQ (symbol, Qand_rest)) | |
| 4391 rest = 1; | |
| 4392 else if (EQ (symbol, Qand_optional)) | |
| 4393 optional = 1; | |
| 4394 else if (rest) | |
| 4395 { | |
| 4396 specbind (symbol, Flist (nargs - i, &args[i])); | |
| 4397 i = nargs; | |
| 4398 } | |
| 4399 else if (i < nargs) | |
| 4400 specbind (symbol, args[i++]); | |
| 4401 else if (!optional) | |
| 4402 goto wrong_number_of_arguments; | |
| 4403 else | |
| 4404 specbind (symbol, Qnil); | |
| 4405 } | |
| 4406 } | |
| 4407 | |
| 4408 if (i < nargs) | |
| 4409 goto wrong_number_of_arguments; | |
| 4410 | |
| 771 | 4411 return unbind_to_1 (speccount, Fprogn (body)); |
| 428 | 4412 |
| 4413 wrong_number_of_arguments: | |
| 436 | 4414 return signal_wrong_number_of_arguments_error (fun, nargs); |
| 428 | 4415 |
| 4416 invalid_function: | |
| 436 | 4417 return signal_invalid_function_error (fun); |
| 428 | 4418 } |
| 4419 | |
| 4420 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4421 /* Multiple 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 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
|
4424 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4425 -- The number of arguments to #'values is not one, and: |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
4426 -- Some special operator in the call stack is prepared to handle more than |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4427 one multiple value. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4428 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4429 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
|
4430 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4431 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
|
4432 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
|
4433 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
|
4434 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
|
4435 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
|
4436 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
|
4437 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
|
4438 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
|
4439 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4440 The specific multiple values saved and returned depend on how many |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
4441 multiple-values special operators in the stack are interested in; for |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4442 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
|
4443 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
|
4444 #'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
|
4445 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
|
4446 be saved and returned. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4447 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4448 (#'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
|
4449 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
|
4450 #'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
|
4451 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
|
4452 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
|
4453 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4454 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
|
4455 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
|
4456 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
|
4457 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
|
4458 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4459 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
|
4460 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
|
4461 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
|
4462 on being printed from within GDB. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4463 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4464 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
|
4465 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
|
4466 #'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
|
4467 #'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
|
4468 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
|
4469 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
|
4470 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
|
4471 *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
|
4472 not have this penalty. |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4473 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4474 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
|
4475 admirable clarity by CLTL2: |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4476 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4477 "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
|
4478 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
|
4479 used." |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4480 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4481 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
|
4482 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
|
4483 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
|
4484 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
|
4485 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4486 static Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4487 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
|
4488 Elemcount first_desired, Elemcount upper_limit) |
|
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 Bytecount sizem; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4491 struct multiple_value *mv; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4492 Elemcount i, allocated_count; |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
4493 Lisp_Object mvobj; |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4494 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4495 assert (count != 1); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4496 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4497 if (1 != upper_limit && (0 == first_desired)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4498 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4499 /* We always allocate element zero, and that's taken into account when |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4500 working out allocated_count: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4501 first_desired = 1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4502 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4503 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4504 if (first_desired >= count) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4505 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4506 /* We can't pass anything back that our caller is interested in. Only |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4507 allocate for the first argument. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4508 allocated_count = 1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4509 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4510 else |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4511 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4512 allocated_count = 1 + ((upper_limit > count ? count : upper_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4513 - first_desired); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4514 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4515 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4516 sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (multiple_value, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4517 Lisp_Object, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4518 contents, allocated_count); |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
4519 mvobj = ALLOC_SIZED_LISP_OBJECT (sizem, multiple_value); |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
4520 mv = XMULTIPLE_VALUE (mvobj); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4521 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4522 mv->count = count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4523 mv->first_desired = first_desired; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4524 mv->allocated_count = allocated_count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4525 mv->contents[0] = first_value; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4526 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4527 for (i = first_desired; i < upper_limit && i < count; ++i) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4528 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4529 mv->contents[1 + (i - first_desired)] = Qunbound; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4530 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4531 |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
4532 return mvobj; |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4533 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4534 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4535 void |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4536 multiple_value_aset (Lisp_Object obj, Elemcount index, Lisp_Object value) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4537 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4538 struct multiple_value *mv = XMULTIPLE_VALUE (obj); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4539 Elemcount first_desired = mv->first_desired; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4540 Elemcount allocated_count = mv->allocated_count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4541 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4542 if (index != 0 && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4543 (index < first_desired || index >= (first_desired + allocated_count))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4544 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4545 args_out_of_range (make_int (first_desired), |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4546 make_int (first_desired + allocated_count)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4547 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4548 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4549 mv->contents[index == 0 ? 0 : 1 + (index - first_desired)] = value; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4550 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4551 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4552 Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4553 multiple_value_aref (Lisp_Object obj, Elemcount index) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4554 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4555 struct multiple_value *mv = XMULTIPLE_VALUE (obj); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4556 Elemcount first_desired = mv->first_desired; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4557 Elemcount allocated_count = mv->allocated_count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4558 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4559 if (index != 0 && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4560 (index < first_desired || index >= (first_desired + allocated_count))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4561 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4562 args_out_of_range (make_int (first_desired), |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4563 make_int (first_desired + allocated_count)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4564 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4565 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4566 return mv->contents[index == 0 ? 0 : 1 + (index - first_desired)]; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4567 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4568 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4569 static void |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4570 print_multiple_value (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4571 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4572 struct multiple_value *mv = XMULTIPLE_VALUE (obj); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4573 Elemcount first_desired = mv->first_desired; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4574 Elemcount allocated_count = mv->allocated_count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4575 Elemcount count = mv->count, index; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4576 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4577 if (print_readably) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4578 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4579 printing_unreadable_object ("multiple values"); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4580 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4581 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4582 if (0 == count) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4583 { |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
4584 write_msg_string (printcharfun, "#<zero-length multiple value>"); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4585 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4586 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4587 for (index = 0; index < count;) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4588 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4589 if (index != 0 && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4590 (index < first_desired || |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4591 index >= (first_desired + (allocated_count - 1)))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4592 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4593 write_fmt_string (printcharfun, "#<discarded-multiple-value %d>", |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4594 index); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4595 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4596 else |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4597 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4598 print_internal (multiple_value_aref (obj, index), |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4599 printcharfun, escapeflag); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4600 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4601 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4602 ++index; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4603 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4604 if (count > 1 && index < count) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4605 { |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
4606 write_ascstring (printcharfun, " ;\n"); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4607 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4608 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4609 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4610 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4611 static Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4612 mark_multiple_value (Lisp_Object obj) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4613 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4614 struct multiple_value *mv = XMULTIPLE_VALUE (obj); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4615 Elemcount index, allocated_count = mv->allocated_count; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4616 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4617 for (index = 0; index < allocated_count; ++index) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4618 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4619 mark_object (mv->contents[index]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4620 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4621 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4622 return Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4623 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4624 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4625 static Bytecount |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
4626 size_multiple_value (Lisp_Object obj) |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4627 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4628 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (struct multiple_value, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4629 Lisp_Object, contents, |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
4630 XMULTIPLE_VALUE (obj)->allocated_count); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4631 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4632 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4633 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
|
4634 { 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
|
4635 { 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
|
4636 { 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
|
4637 { 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
|
4638 XD_INDIRECT (1, 0) }, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4639 { XD_END } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4640 }; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4641 |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
4642 DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("multiple-value", multiple_value, |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4643 mark_multiple_value, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4644 print_multiple_value, 0, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4645 0, /* No equal method. */ |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4646 0, /* No hash method. */ |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4647 multiple_value_description, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4648 size_multiple_value, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
4649 struct multiple_value); |
|
4677
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 /* 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
|
4652 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
|
4653 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
|
4654 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
|
4655 int |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4656 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
|
4657 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4658 int result = specpdl_depth(); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4659 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4660 if (!(upper > first)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4661 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4662 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
|
4663 " FIRST-DESIRED-MULTIPLE-VALUE", Qunbound); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4664 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4665 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4666 if (upper > Vmultiple_values_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4667 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4668 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
|
4669 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4670 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4671 /* 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
|
4672 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
|
4673 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
|
4674 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
|
4675 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4676 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
|
4677 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
|
4678 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4679 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
|
4680 if (0 == first) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4681 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4682 first = 1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4683 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4684 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4685 if (0 == first_desired_multiple_value |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4686 || first < first_desired_multiple_value) |
|
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 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
|
4689 } |
|
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 if (upper > multiple_value_current_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4692 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4693 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
|
4694 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4695 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4696 return result; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4697 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4698 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4699 Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4700 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
|
4701 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4702 /* The argument order here is horrible: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4703 int i, speccount = XINT (args[3]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4704 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
|
4705 struct gcpro gcpro1, gcpro2; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4706 Lisp_Object apply_args[2]; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4707 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4708 GCPRO2 (head, result); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4709 list_offset = head; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4710 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4711 assert (!(MULTIPLE_VALUEP (args[0]))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4712 CHECK_FUNCTION (args[0]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4713 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4714 /* 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
|
4715 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
|
4716 #'multiple-value-list-internal needs them): */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4717 for (i = 4; i < nargs; ++i) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4718 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4719 result = args[i]; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4720 if (MULTIPLE_VALUEP (result)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4721 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4722 Lisp_Object val; |
|
5016
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
4723 Elemcount j, count = XMULTIPLE_VALUE_COUNT (result); |
|
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
4724 |
|
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
4725 for (j = 0; j < count; j++) |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4726 { |
|
5016
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
4727 val = multiple_value_aref (result, j); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4728 assert (!UNBOUNDP (val)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4729 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4730 XSETCDR (list_offset, Fcons (val, Qnil)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4731 list_offset = XCDR (list_offset); |
|
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 else |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4735 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4736 XSETCDR (list_offset, Fcons (result, Qnil)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4737 list_offset = XCDR (list_offset); |
|
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 } |
|
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 apply_args [0] = XCAR (head); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4742 apply_args [1] = XCDR (head); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4743 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4744 unbind_to (speccount); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4745 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4746 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
|
4747 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4748 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4749 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
|
4750 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
|
4751 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4752 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
|
4753 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
|
4754 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
|
4755 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
|
4756 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4757 arguments: (FUNCTION &rest FORMS) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4758 */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4759 (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4760 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4761 int listcount, i = 0, speccount; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4762 Lisp_Object *constructed_args; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4763 struct gcpro gcpro1; |
|
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 GET_EXTERNAL_LIST_LENGTH (args, listcount); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4766 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4767 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
|
4768 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4769 /* 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
|
4770 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
|
4771 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4772 GCPRO1 (*constructed_args); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4773 gcpro1.nvars = ++i; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4774 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4775 /* The argument order is horrible here. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4776 constructed_args[i] = make_int (0); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4777 gcpro1.nvars = ++i; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4778 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
|
4779 gcpro1.nvars = ++i; |
|
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 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
|
4782 constructed_args[i] = make_int (speccount); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4783 gcpro1.nvars = ++i; |
|
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 LIST_LOOP_2 (elt, XCDR (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 constructed_args[i] = Feval (elt); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4789 gcpro1.nvars = ++i; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4790 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4791 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4792 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4793 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
|
4794 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4795 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4796 Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4797 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
|
4798 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4799 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
|
4800 speccount = XINT(args[2]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4801 Lisp_Object result = Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4802 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4803 assert (nargs == 4); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4804 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4805 result = args[3]; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4806 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4807 unbind_to (speccount); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4808 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4809 if (MULTIPLE_VALUEP (result)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4810 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4811 Lisp_Object head = Fcons (Qnil, Qnil); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4812 Lisp_Object list_offset = head, val; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4813 Elemcount count = XMULTIPLE_VALUE_COUNT(result); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4814 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4815 for (; first < upper && first < count; ++first) |
|
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 val = multiple_value_aref (result, first); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4818 assert (!UNBOUNDP (val)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4819 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4820 XSETCDR (list_offset, Fcons (val, Qnil)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4821 list_offset = XCDR (list_offset); |
|
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 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4824 return XCDR (head); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4825 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4826 else |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4827 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4828 if (first == 0) |
|
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 return Fcons (result, Qnil); |
|
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 else |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4833 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4834 return Qnil; |
|
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 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4837 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4838 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4839 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
|
4840 UNEVALLED, 0, /* |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4841 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
|
4842 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4843 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
|
4844 Lisp, instead. |
|
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 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
|
4847 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
|
4848 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
|
4849 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
|
4850 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
|
4851 `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
|
4852 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4853 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
|
4854 */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4855 (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4856 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4857 Lisp_Object argv[4]; |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4858 int first, upper, nargs; |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4859 struct gcpro gcpro1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4860 |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4861 GET_LIST_LENGTH (args, nargs); |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4862 if (nargs != 3) |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4863 { |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4864 Fsignal (Qwrong_number_of_arguments, |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4865 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
|
4866 } |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
4867 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4868 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
|
4869 CHECK_NATNUM (argv[0]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4870 first = XINT (argv[0]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4871 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4872 GCPRO1 (argv[0]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4873 gcpro1.nvars = 1; |
|
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 args = XCDR (args); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4876 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4877 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
|
4878 CHECK_NATNUM (argv[1]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4879 upper = XINT (argv[1]); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4880 gcpro1.nvars = 2; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4881 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4882 /* 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
|
4883 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
|
4884 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
|
4885 arguments. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4886 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
|
4887 gcpro1.nvars = 3; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4888 args = XCDR (args); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4889 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4890 /* 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
|
4891 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
|
4892 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
|
4893 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
|
4894 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
|
4895 it doesn't matter for performance. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4896 argv[3] = Feval (XCAR (args)); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4897 gcpro1.nvars = 4; |
|
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 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
|
4900 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4901 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4902 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
|
4903 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
|
4904 `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
|
4905 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4906 arguments: (FIRST &rest BODY) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4907 */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4908 (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4909 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4910 /* This function can GC */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4911 Lisp_Object val; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4912 struct gcpro gcpro1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4913 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4914 val = Feval (XCAR (args)); |
|
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 GCPRO1 (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 LIST_LOOP_2 (form, XCDR (args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4920 Feval (form); |
|
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 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4923 RETURN_UNGCPRO (val); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4924 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4925 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4926 DEFUN ("values", Fvalues, 0, MANY, 0, /* |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4927 Return all ARGS as multiple values. |
|
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 arguments: (&rest ARGS) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4930 */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4931 (int nargs, Lisp_Object *args)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4932 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4933 Lisp_Object result = Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4934 int counting = 1; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4935 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4936 /* 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
|
4937 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
|
4938 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4939 return nargs ? args[0] : Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4940 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4941 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4942 /* 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
|
4943 #'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
|
4944 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
|
4945 transform them to nil. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4946 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
|
4947 first_desired_multiple_value, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4948 multiple_value_current_limit); |
|
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 for (; counting < nargs; ++counting) |
|
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 if (counting >= first_desired_multiple_value && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4953 counting < multiple_value_current_limit) |
|
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 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
|
4956 } |
|
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 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4959 return result; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4960 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4961 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4962 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
|
4963 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
|
4964 */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4965 (list)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4966 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4967 Lisp_Object result = Qnil; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4968 int counting = 1, listcount; |
|
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 GET_EXTERNAL_LIST_LENGTH (list, listcount); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4971 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4972 /* 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
|
4973 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
|
4974 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4975 return Fcar_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 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
|
4979 first_desired_multiple_value, |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4980 multiple_value_current_limit); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4981 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4982 list = Fcdr_safe (list); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4983 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4984 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4985 EXTERNAL_LIST_LOOP_2 (elt, list) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4986 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4987 if (counting >= first_desired_multiple_value && |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4988 counting < multiple_value_current_limit) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4989 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4990 multiple_value_aset (result, counting, elt); |
|
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 ++counting; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4993 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4994 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4995 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4996 return result; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4997 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4998 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
4999 Lisp_Object |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5000 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
|
5001 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5002 Lisp_Object argv[2]; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5003 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5004 argv[0] = first; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5005 argv[1] = second; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5006 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5007 return Fvalues (countof (argv), argv); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5008 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5009 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5010 |
| 428 | 5011 /************************************************************************/ |
| 5012 /* Run hook variables in various ways. */ | |
| 5013 /************************************************************************/ | |
| 5014 | |
| 5015 DEFUN ("run-hooks", Frun_hooks, 1, MANY, 0, /* | |
| 5016 Run each hook in HOOKS. Major mode functions use this. | |
| 5017 Each argument should be a symbol, a hook variable. | |
| 5018 These symbols are processed in the order specified. | |
| 5019 If a hook symbol has a non-nil value, that value may be a function | |
| 5020 or a list of functions to be called to run the hook. | |
| 5021 If the value is a function, it is called with no arguments. | |
| 5022 If it is a list, the elements are called, in order, with no arguments. | |
| 5023 | |
| 5024 To make a hook variable buffer-local, use `make-local-hook', | |
| 5025 not `make-local-variable'. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5026 |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4686
diff
changeset
|
5027 arguments: (FIRST &rest REST) |
| 428 | 5028 */ |
| 5029 (int nargs, Lisp_Object *args)) | |
| 5030 { | |
| 5031 REGISTER int i; | |
| 5032 | |
| 5033 for (i = 0; i < nargs; i++) | |
| 5034 run_hook_with_args (1, args + i, RUN_HOOKS_TO_COMPLETION); | |
| 5035 | |
| 5036 return Qnil; | |
| 5037 } | |
| 5038 | |
| 5039 DEFUN ("run-hook-with-args", Frun_hook_with_args, 1, MANY, 0, /* | |
| 5040 Run HOOK with the specified arguments ARGS. | |
| 5041 HOOK should be a symbol, a hook variable. If HOOK has a non-nil | |
| 5042 value, that value may be a function or a list of functions to be | |
| 5043 called to run the hook. If the value is a function, it is called with | |
| 5044 the given arguments and its return value is returned. If it is a list | |
| 5045 of functions, those functions are called, in order, | |
| 5046 with the given arguments ARGS. | |
| 444 | 5047 It is best not to depend on the value returned by `run-hook-with-args', |
| 428 | 5048 as that may change. |
| 5049 | |
| 5050 To make a hook variable buffer-local, use `make-local-hook', | |
| 5051 not `make-local-variable'. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5052 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5053 arguments: (HOOK &rest ARGS) |
| 428 | 5054 */ |
| 5055 (int nargs, Lisp_Object *args)) | |
| 5056 { | |
| 5057 return run_hook_with_args (nargs, args, RUN_HOOKS_TO_COMPLETION); | |
| 5058 } | |
| 5059 | |
| 5060 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success, 1, MANY, 0, /* | |
| 5061 Run HOOK with the specified arguments ARGS. | |
| 5062 HOOK should be a symbol, a hook variable. Its value should | |
| 5063 be a list of functions. We call those functions, one by one, | |
| 5064 passing arguments ARGS to each of them, until one of them | |
| 5065 returns a non-nil value. Then we return that value. | |
| 5066 If all the functions return nil, we return nil. | |
| 5067 | |
| 5068 To make a hook variable buffer-local, use `make-local-hook', | |
| 5069 not `make-local-variable'. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5070 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5071 arguments: (HOOK &rest ARGS) |
| 428 | 5072 */ |
| 5073 (int nargs, Lisp_Object *args)) | |
| 5074 { | |
| 5075 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_SUCCESS); | |
| 5076 } | |
| 5077 | |
| 5078 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure, 1, MANY, 0, /* | |
| 5079 Run HOOK with the specified arguments ARGS. | |
| 5080 HOOK should be a symbol, a hook variable. Its value should | |
| 5081 be a list of functions. We call those functions, one by one, | |
| 5082 passing arguments ARGS to each of them, until one of them | |
| 5083 returns nil. Then we return nil. | |
| 5084 If all the functions return non-nil, we return non-nil. | |
| 5085 | |
| 5086 To make a hook variable buffer-local, use `make-local-hook', | |
| 5087 not `make-local-variable'. | |
|
4642
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5088 |
|
48b45a606961
Support #'function-arglist with built-in special forms.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4624
diff
changeset
|
5089 arguments: (HOOK &rest ARGS) |
| 428 | 5090 */ |
| 5091 (int nargs, Lisp_Object *args)) | |
| 5092 { | |
| 5093 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_FAILURE); | |
| 5094 } | |
| 5095 | |
| 5096 /* ARGS[0] should be a hook symbol. | |
| 5097 Call each of the functions in the hook value, passing each of them | |
| 5098 as arguments all the rest of ARGS (all NARGS - 1 elements). | |
| 5099 COND specifies a condition to test after each call | |
| 5100 to decide whether to stop. | |
| 5101 The caller (or its caller, etc) must gcpro all of ARGS, | |
| 5102 except that it isn't necessary to gcpro ARGS[0]. */ | |
| 5103 | |
| 5104 Lisp_Object | |
| 5105 run_hook_with_args_in_buffer (struct buffer *buf, int nargs, Lisp_Object *args, | |
| 5106 enum run_hooks_condition cond) | |
| 5107 { | |
| 5108 Lisp_Object sym, val, ret; | |
| 5109 | |
| 5110 if (!initialized || preparing_for_armageddon) | |
| 5111 /* We need to bail out of here pronto. */ | |
| 5112 return Qnil; | |
| 5113 | |
| 3092 | 5114 #ifndef NEW_GC |
| 428 | 5115 /* Whenever gc_in_progress is true, preparing_for_armageddon |
| 5116 will also be true unless something is really hosed. */ | |
| 5117 assert (!gc_in_progress); | |
| 3092 | 5118 #endif /* not NEW_GC */ |
| 428 | 5119 |
| 5120 sym = args[0]; | |
| 771 | 5121 val = symbol_value_in_buffer (sym, wrap_buffer (buf)); |
| 428 | 5122 ret = (cond == RUN_HOOKS_UNTIL_FAILURE ? Qt : Qnil); |
| 5123 | |
| 5124 if (UNBOUNDP (val) || NILP (val)) | |
| 5125 return ret; | |
| 5126 else if (!CONSP (val) || EQ (XCAR (val), Qlambda)) | |
| 5127 { | |
| 5128 args[0] = val; | |
| 5129 return Ffuncall (nargs, args); | |
| 5130 } | |
| 5131 else | |
| 5132 { | |
| 5133 struct gcpro gcpro1, gcpro2, gcpro3; | |
| 5134 Lisp_Object globals = Qnil; | |
| 5135 GCPRO3 (sym, val, globals); | |
| 5136 | |
| 5137 for (; | |
| 5138 CONSP (val) && ((cond == RUN_HOOKS_TO_COMPLETION) | |
| 5139 || (cond == RUN_HOOKS_UNTIL_SUCCESS ? NILP (ret) | |
| 5140 : !NILP (ret))); | |
| 5141 val = XCDR (val)) | |
| 5142 { | |
| 5143 if (EQ (XCAR (val), Qt)) | |
| 5144 { | |
| 5145 /* t indicates this hook has a local binding; | |
| 5146 it means to run the global binding too. */ | |
| 5147 globals = Fdefault_value (sym); | |
| 5148 | |
| 5149 if ((! CONSP (globals) || EQ (XCAR (globals), Qlambda)) && | |
| 5150 ! NILP (globals)) | |
| 5151 { | |
| 5152 args[0] = globals; | |
| 5153 ret = Ffuncall (nargs, args); | |
| 5154 } | |
| 5155 else | |
| 5156 { | |
| 5157 for (; | |
| 5158 CONSP (globals) && ((cond == RUN_HOOKS_TO_COMPLETION) | |
| 5159 || (cond == RUN_HOOKS_UNTIL_SUCCESS | |
| 5160 ? NILP (ret) | |
| 5161 : !NILP (ret))); | |
| 5162 globals = XCDR (globals)) | |
| 5163 { | |
| 5164 args[0] = XCAR (globals); | |
| 5165 /* In a global value, t should not occur. If it does, we | |
| 5166 must ignore it to avoid an endless loop. */ | |
| 5167 if (!EQ (args[0], Qt)) | |
| 5168 ret = Ffuncall (nargs, args); | |
| 5169 } | |
| 5170 } | |
| 5171 } | |
| 5172 else | |
| 5173 { | |
| 5174 args[0] = XCAR (val); | |
| 5175 ret = Ffuncall (nargs, args); | |
| 5176 } | |
| 5177 } | |
| 5178 | |
| 5179 UNGCPRO; | |
| 5180 return ret; | |
| 5181 } | |
| 5182 } | |
| 5183 | |
| 5184 Lisp_Object | |
| 5185 run_hook_with_args (int nargs, Lisp_Object *args, | |
| 5186 enum run_hooks_condition cond) | |
| 5187 { | |
| 5188 return run_hook_with_args_in_buffer (current_buffer, nargs, args, cond); | |
| 5189 } | |
| 5190 | |
| 5191 #if 0 | |
| 5192 | |
| 853 | 5193 /* From FSF 19.30, not currently used; seems like a big kludge. */ |
| 428 | 5194 |
| 5195 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual | |
| 5196 present value of that symbol. | |
| 5197 Call each element of FUNLIST, | |
| 5198 passing each of them the rest of ARGS. | |
| 5199 The caller (or its caller, etc) must gcpro all of ARGS, | |
| 5200 except that it isn't necessary to gcpro ARGS[0]. */ | |
| 5201 | |
| 5202 Lisp_Object | |
| 5203 run_hook_list_with_args (Lisp_Object funlist, int nargs, Lisp_Object *args) | |
| 5204 { | |
| 853 | 5205 omitted; |
| 428 | 5206 } |
| 5207 | |
| 5208 #endif /* 0 */ | |
| 5209 | |
| 5210 void | |
| 5211 va_run_hook_with_args (Lisp_Object hook_var, int nargs, ...) | |
| 5212 { | |
| 5213 /* This function can GC */ | |
| 5214 struct gcpro gcpro1; | |
| 5215 int i; | |
| 5216 va_list vargs; | |
| 5217 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs); | |
| 5218 | |
| 5219 va_start (vargs, nargs); | |
| 5220 funcall_args[0] = hook_var; | |
| 5221 for (i = 0; i < nargs; i++) | |
| 5222 funcall_args[i + 1] = va_arg (vargs, Lisp_Object); | |
| 5223 va_end (vargs); | |
| 5224 | |
| 5225 GCPRO1 (*funcall_args); | |
| 5226 gcpro1.nvars = nargs + 1; | |
| 5227 run_hook_with_args (nargs + 1, funcall_args, RUN_HOOKS_TO_COMPLETION); | |
| 5228 UNGCPRO; | |
| 5229 } | |
| 5230 | |
| 5231 void | |
| 5232 va_run_hook_with_args_in_buffer (struct buffer *buf, Lisp_Object hook_var, | |
| 5233 int nargs, ...) | |
| 5234 { | |
| 5235 /* This function can GC */ | |
| 5236 struct gcpro gcpro1; | |
| 5237 int i; | |
| 5238 va_list vargs; | |
| 5239 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs); | |
| 5240 | |
| 5241 va_start (vargs, nargs); | |
| 5242 funcall_args[0] = hook_var; | |
| 5243 for (i = 0; i < nargs; i++) | |
| 5244 funcall_args[i + 1] = va_arg (vargs, Lisp_Object); | |
| 5245 va_end (vargs); | |
| 5246 | |
| 5247 GCPRO1 (*funcall_args); | |
| 5248 gcpro1.nvars = nargs + 1; | |
| 5249 run_hook_with_args_in_buffer (buf, nargs + 1, funcall_args, | |
| 5250 RUN_HOOKS_TO_COMPLETION); | |
| 5251 UNGCPRO; | |
| 5252 } | |
| 5253 | |
| 5254 Lisp_Object | |
| 5255 run_hook (Lisp_Object hook) | |
| 5256 { | |
| 853 | 5257 return run_hook_with_args (1, &hook, RUN_HOOKS_TO_COMPLETION); |
| 428 | 5258 } |
| 5259 | |
| 5260 | |
| 5261 /************************************************************************/ | |
| 5262 /* Front-ends to eval, funcall, apply */ | |
| 5263 /************************************************************************/ | |
| 5264 | |
| 5265 /* Apply fn to arg */ | |
| 5266 Lisp_Object | |
| 5267 apply1 (Lisp_Object fn, Lisp_Object arg) | |
| 5268 { | |
| 5269 /* This function can GC */ | |
| 5270 struct gcpro gcpro1; | |
| 5271 Lisp_Object args[2]; | |
| 5272 | |
| 5273 if (NILP (arg)) | |
| 5274 return Ffuncall (1, &fn); | |
| 5275 GCPRO1 (args[0]); | |
| 5276 gcpro1.nvars = 2; | |
| 5277 args[0] = fn; | |
| 5278 args[1] = arg; | |
| 5279 RETURN_UNGCPRO (Fapply (2, args)); | |
| 5280 } | |
| 5281 | |
| 5282 /* Call function fn on no arguments */ | |
| 5283 Lisp_Object | |
| 5284 call0 (Lisp_Object fn) | |
| 5285 { | |
| 5286 /* This function can GC */ | |
| 5287 struct gcpro gcpro1; | |
| 5288 | |
| 5289 GCPRO1 (fn); | |
| 5290 RETURN_UNGCPRO (Ffuncall (1, &fn)); | |
| 5291 } | |
| 5292 | |
| 5293 /* Call function fn with argument arg0 */ | |
| 5294 Lisp_Object | |
| 5295 call1 (Lisp_Object fn, | |
| 5296 Lisp_Object arg0) | |
| 5297 { | |
| 5298 /* This function can GC */ | |
| 5299 struct gcpro gcpro1; | |
| 5300 Lisp_Object args[2]; | |
| 5301 args[0] = fn; | |
| 5302 args[1] = arg0; | |
| 5303 GCPRO1 (args[0]); | |
| 5304 gcpro1.nvars = 2; | |
| 5305 RETURN_UNGCPRO (Ffuncall (2, args)); | |
| 5306 } | |
| 5307 | |
| 5308 /* Call function fn with arguments arg0, arg1 */ | |
| 5309 Lisp_Object | |
| 5310 call2 (Lisp_Object fn, | |
| 5311 Lisp_Object arg0, Lisp_Object arg1) | |
| 5312 { | |
| 5313 /* This function can GC */ | |
| 5314 struct gcpro gcpro1; | |
| 5315 Lisp_Object args[3]; | |
| 5316 args[0] = fn; | |
| 5317 args[1] = arg0; | |
| 5318 args[2] = arg1; | |
| 5319 GCPRO1 (args[0]); | |
| 5320 gcpro1.nvars = 3; | |
| 5321 RETURN_UNGCPRO (Ffuncall (3, args)); | |
| 5322 } | |
| 5323 | |
| 5324 /* Call function fn with arguments arg0, arg1, arg2 */ | |
| 5325 Lisp_Object | |
| 5326 call3 (Lisp_Object fn, | |
| 5327 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2) | |
| 5328 { | |
| 5329 /* This function can GC */ | |
| 5330 struct gcpro gcpro1; | |
| 5331 Lisp_Object args[4]; | |
| 5332 args[0] = fn; | |
| 5333 args[1] = arg0; | |
| 5334 args[2] = arg1; | |
| 5335 args[3] = arg2; | |
| 5336 GCPRO1 (args[0]); | |
| 5337 gcpro1.nvars = 4; | |
| 5338 RETURN_UNGCPRO (Ffuncall (4, args)); | |
| 5339 } | |
| 5340 | |
| 5341 /* Call function fn with arguments arg0, arg1, arg2, arg3 */ | |
| 5342 Lisp_Object | |
| 5343 call4 (Lisp_Object fn, | |
| 5344 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5345 Lisp_Object arg3) | |
| 5346 { | |
| 5347 /* This function can GC */ | |
| 5348 struct gcpro gcpro1; | |
| 5349 Lisp_Object args[5]; | |
| 5350 args[0] = fn; | |
| 5351 args[1] = arg0; | |
| 5352 args[2] = arg1; | |
| 5353 args[3] = arg2; | |
| 5354 args[4] = arg3; | |
| 5355 GCPRO1 (args[0]); | |
| 5356 gcpro1.nvars = 5; | |
| 5357 RETURN_UNGCPRO (Ffuncall (5, args)); | |
| 5358 } | |
| 5359 | |
| 5360 /* Call function fn with arguments arg0, arg1, arg2, arg3, arg4 */ | |
| 5361 Lisp_Object | |
| 5362 call5 (Lisp_Object fn, | |
| 5363 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5364 Lisp_Object arg3, Lisp_Object arg4) | |
| 5365 { | |
| 5366 /* This function can GC */ | |
| 5367 struct gcpro gcpro1; | |
| 5368 Lisp_Object args[6]; | |
| 5369 args[0] = fn; | |
| 5370 args[1] = arg0; | |
| 5371 args[2] = arg1; | |
| 5372 args[3] = arg2; | |
| 5373 args[4] = arg3; | |
| 5374 args[5] = arg4; | |
| 5375 GCPRO1 (args[0]); | |
| 5376 gcpro1.nvars = 6; | |
| 5377 RETURN_UNGCPRO (Ffuncall (6, args)); | |
| 5378 } | |
| 5379 | |
| 5380 Lisp_Object | |
| 5381 call6 (Lisp_Object fn, | |
| 5382 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5383 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5) | |
| 5384 { | |
| 5385 /* This function can GC */ | |
| 5386 struct gcpro gcpro1; | |
| 5387 Lisp_Object args[7]; | |
| 5388 args[0] = fn; | |
| 5389 args[1] = arg0; | |
| 5390 args[2] = arg1; | |
| 5391 args[3] = arg2; | |
| 5392 args[4] = arg3; | |
| 5393 args[5] = arg4; | |
| 5394 args[6] = arg5; | |
| 5395 GCPRO1 (args[0]); | |
| 5396 gcpro1.nvars = 7; | |
| 5397 RETURN_UNGCPRO (Ffuncall (7, args)); | |
| 5398 } | |
| 5399 | |
| 5400 Lisp_Object | |
| 5401 call7 (Lisp_Object fn, | |
| 5402 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5403 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5, | |
| 5404 Lisp_Object arg6) | |
| 5405 { | |
| 5406 /* This function can GC */ | |
| 5407 struct gcpro gcpro1; | |
| 5408 Lisp_Object args[8]; | |
| 5409 args[0] = fn; | |
| 5410 args[1] = arg0; | |
| 5411 args[2] = arg1; | |
| 5412 args[3] = arg2; | |
| 5413 args[4] = arg3; | |
| 5414 args[5] = arg4; | |
| 5415 args[6] = arg5; | |
| 5416 args[7] = arg6; | |
| 5417 GCPRO1 (args[0]); | |
| 5418 gcpro1.nvars = 8; | |
| 5419 RETURN_UNGCPRO (Ffuncall (8, args)); | |
| 5420 } | |
| 5421 | |
| 5422 Lisp_Object | |
| 5423 call8 (Lisp_Object fn, | |
| 5424 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5425 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5, | |
| 5426 Lisp_Object arg6, Lisp_Object arg7) | |
| 5427 { | |
| 5428 /* This function can GC */ | |
| 5429 struct gcpro gcpro1; | |
| 5430 Lisp_Object args[9]; | |
| 5431 args[0] = fn; | |
| 5432 args[1] = arg0; | |
| 5433 args[2] = arg1; | |
| 5434 args[3] = arg2; | |
| 5435 args[4] = arg3; | |
| 5436 args[5] = arg4; | |
| 5437 args[6] = arg5; | |
| 5438 args[7] = arg6; | |
| 5439 args[8] = arg7; | |
| 5440 GCPRO1 (args[0]); | |
| 5441 gcpro1.nvars = 9; | |
| 5442 RETURN_UNGCPRO (Ffuncall (9, args)); | |
| 5443 } | |
| 5444 | |
| 5445 Lisp_Object | |
| 5446 call0_in_buffer (struct buffer *buf, Lisp_Object fn) | |
| 5447 { | |
| 5448 if (current_buffer == buf) | |
| 5449 return call0 (fn); | |
| 5450 else | |
| 5451 { | |
| 5452 Lisp_Object val; | |
| 5453 int speccount = specpdl_depth(); | |
| 5454 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5455 set_buffer_internal (buf); | |
| 5456 val = call0 (fn); | |
| 771 | 5457 unbind_to (speccount); |
| 428 | 5458 return val; |
| 5459 } | |
| 5460 } | |
| 5461 | |
| 5462 Lisp_Object | |
| 5463 call1_in_buffer (struct buffer *buf, Lisp_Object fn, | |
| 5464 Lisp_Object arg0) | |
| 5465 { | |
| 5466 if (current_buffer == buf) | |
| 5467 return call1 (fn, arg0); | |
| 5468 else | |
| 5469 { | |
| 5470 Lisp_Object val; | |
| 5471 int speccount = specpdl_depth(); | |
| 5472 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5473 set_buffer_internal (buf); | |
| 5474 val = call1 (fn, arg0); | |
| 771 | 5475 unbind_to (speccount); |
| 428 | 5476 return val; |
| 5477 } | |
| 5478 } | |
| 5479 | |
| 5480 Lisp_Object | |
| 5481 call2_in_buffer (struct buffer *buf, Lisp_Object fn, | |
| 5482 Lisp_Object arg0, Lisp_Object arg1) | |
| 5483 { | |
| 5484 if (current_buffer == buf) | |
| 5485 return call2 (fn, arg0, arg1); | |
| 5486 else | |
| 5487 { | |
| 5488 Lisp_Object val; | |
| 5489 int speccount = specpdl_depth(); | |
| 5490 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5491 set_buffer_internal (buf); | |
| 5492 val = call2 (fn, arg0, arg1); | |
| 771 | 5493 unbind_to (speccount); |
| 428 | 5494 return val; |
| 5495 } | |
| 5496 } | |
| 5497 | |
| 5498 Lisp_Object | |
| 5499 call3_in_buffer (struct buffer *buf, Lisp_Object fn, | |
| 5500 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2) | |
| 5501 { | |
| 5502 if (current_buffer == buf) | |
| 5503 return call3 (fn, arg0, arg1, arg2); | |
| 5504 else | |
| 5505 { | |
| 5506 Lisp_Object val; | |
| 5507 int speccount = specpdl_depth(); | |
| 5508 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5509 set_buffer_internal (buf); | |
| 5510 val = call3 (fn, arg0, arg1, arg2); | |
| 771 | 5511 unbind_to (speccount); |
| 428 | 5512 return val; |
| 5513 } | |
| 5514 } | |
| 5515 | |
| 5516 Lisp_Object | |
| 5517 call4_in_buffer (struct buffer *buf, Lisp_Object fn, | |
| 5518 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 5519 Lisp_Object arg3) | |
| 5520 { | |
| 5521 if (current_buffer == buf) | |
| 5522 return call4 (fn, arg0, arg1, arg2, arg3); | |
| 5523 else | |
| 5524 { | |
| 5525 Lisp_Object val; | |
| 5526 int speccount = specpdl_depth(); | |
| 5527 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5528 set_buffer_internal (buf); | |
| 5529 val = call4 (fn, arg0, arg1, arg2, arg3); | |
| 771 | 5530 unbind_to (speccount); |
| 428 | 5531 return val; |
| 5532 } | |
| 5533 } | |
| 5534 | |
| 5535 Lisp_Object | |
| 5536 eval_in_buffer (struct buffer *buf, Lisp_Object form) | |
| 5537 { | |
| 5538 if (current_buffer == buf) | |
| 5539 return Feval (form); | |
| 5540 else | |
| 5541 { | |
| 5542 Lisp_Object val; | |
| 5543 int speccount = specpdl_depth(); | |
| 5544 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 5545 set_buffer_internal (buf); | |
| 5546 val = Feval (form); | |
| 771 | 5547 unbind_to (speccount); |
| 428 | 5548 return val; |
| 5549 } | |
| 5550 } | |
| 5551 | |
| 5552 | |
| 5553 /************************************************************************/ | |
| 5554 /* Error-catching front-ends to eval, funcall, apply */ | |
| 5555 /************************************************************************/ | |
| 5556 | |
| 853 | 5557 int |
| 5558 get_inhibit_flags (void) | |
| 5559 { | |
| 5560 return inhibit_flags; | |
| 5561 } | |
| 5562 | |
| 5563 void | |
| 2286 | 5564 check_allowed_operation (int what, Lisp_Object obj, Lisp_Object UNUSED (prop)) |
| 853 | 5565 { |
| 5566 if (inhibit_flags & INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION) | |
| 5567 { | |
| 5568 if (what == OPERATION_MODIFY_BUFFER_TEXT && BUFFERP (obj) | |
| 5569 && NILP (memq_no_quit (obj, Vmodifiable_buffers))) | |
| 5570 invalid_change | |
| 5571 ("Modification of this buffer not currently permitted", obj); | |
| 5572 } | |
| 5573 if (inhibit_flags & INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION) | |
| 5574 { | |
| 5575 if (what == OPERATION_DELETE_OBJECT | |
| 5576 && (BUFFERP (obj) || WINDOWP (obj) || FRAMEP (obj) || DEVICEP (obj) | |
| 5577 || CONSOLEP (obj)) | |
| 5578 && NILP (memq_no_quit (obj, Vdeletable_permanent_display_objects))) | |
| 5579 invalid_change | |
| 5580 ("Deletion of this object not currently permitted", obj); | |
| 5581 } | |
| 5582 } | |
| 5583 | |
| 5584 void | |
| 5585 note_object_created (Lisp_Object obj) | |
| 5586 { | |
| 5587 if (inhibit_flags & INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION) | |
| 5588 { | |
| 5589 if (BUFFERP (obj)) | |
| 5590 Vmodifiable_buffers = Fcons (obj, Vmodifiable_buffers); | |
| 5591 } | |
| 5592 if (inhibit_flags & INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION) | |
| 5593 { | |
| 5594 if (BUFFERP (obj) || WINDOWP (obj) || FRAMEP (obj) || DEVICEP (obj) | |
| 5595 || CONSOLEP (obj)) | |
| 5596 Vdeletable_permanent_display_objects = | |
| 5597 Fcons (obj, Vdeletable_permanent_display_objects); | |
| 5598 } | |
| 5599 } | |
| 5600 | |
| 5601 void | |
| 5602 note_object_deleted (Lisp_Object obj) | |
| 5603 { | |
| 5604 if (inhibit_flags & INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION) | |
| 5605 { | |
| 5606 if (BUFFERP (obj)) | |
| 5607 Vmodifiable_buffers = delq_no_quit (obj, Vmodifiable_buffers); | |
| 5608 } | |
| 5609 if (inhibit_flags & INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION) | |
| 5610 { | |
| 5611 if (BUFFERP (obj) || WINDOWP (obj) || FRAMEP (obj) || DEVICEP (obj) | |
| 5612 || CONSOLEP (obj)) | |
| 5613 Vdeletable_permanent_display_objects = | |
| 5614 delq_no_quit (obj, Vdeletable_permanent_display_objects); | |
| 5615 } | |
| 5616 } | |
| 5617 | |
| 5618 struct call_trapping_problems | |
| 5619 { | |
| 5620 Lisp_Object catchtag; | |
| 5621 Lisp_Object error_conditions; | |
| 5622 Lisp_Object data; | |
| 5623 Lisp_Object backtrace; | |
| 5624 Lisp_Object warning_class; | |
| 5625 | |
| 867 | 5626 const CIbyte *warning_string; |
| 853 | 5627 Lisp_Object (*fun) (void *); |
| 5628 void *arg; | |
| 5629 }; | |
| 428 | 5630 |
| 2532 | 5631 static Lisp_Object |
| 5632 maybe_get_trapping_problems_backtrace (void) | |
| 5633 { | |
| 5634 Lisp_Object backtrace; | |
| 853 | 5635 |
| 1123 | 5636 if (!(inhibit_flags & INHIBIT_WARNING_ISSUE) |
| 2532 | 5637 && !warning_will_be_discarded (current_warning_level ())) |
| 428 | 5638 { |
| 1333 | 5639 struct gcpro gcpro1; |
| 5640 Lisp_Object lstream = Qnil; | |
| 5641 int speccount = specpdl_depth (); | |
| 5642 | |
| 853 | 5643 /* We're no longer protected against errors or quit here, so at |
| 5644 least let's temporarily inhibit quit. We definitely do not | |
| 5645 want to inhibit quit during the calling of the function | |
| 5646 itself!!!!!!!!!!! */ | |
| 5647 | |
| 5648 specbind (Qinhibit_quit, Qt); | |
| 5649 | |
| 5650 GCPRO1 (lstream); | |
| 5651 lstream = make_resizing_buffer_output_stream (); | |
| 5652 Fbacktrace (lstream, Qt); | |
| 5653 Lstream_flush (XLSTREAM (lstream)); | |
| 2532 | 5654 backtrace = resizing_buffer_to_lisp_string (XLSTREAM (lstream)); |
| 853 | 5655 Lstream_delete (XLSTREAM (lstream)); |
| 5656 UNGCPRO; | |
| 5657 | |
| 5658 unbind_to (speccount); | |
| 428 | 5659 } |
| 853 | 5660 else |
| 2532 | 5661 backtrace = Qnil; |
| 5662 | |
| 5663 return backtrace; | |
| 5664 } | |
| 5665 | |
| 5666 static DECLARE_DOESNT_RETURN_TYPE | |
| 5667 (Lisp_Object, flagged_a_squirmer (Lisp_Object, Lisp_Object, Lisp_Object)); | |
| 5668 | |
| 5669 static DOESNT_RETURN_TYPE (Lisp_Object) | |
| 5670 flagged_a_squirmer (Lisp_Object error_conditions, Lisp_Object data, | |
| 5671 Lisp_Object opaque) | |
| 5672 { | |
| 5673 struct call_trapping_problems *p = | |
| 5674 (struct call_trapping_problems *) get_opaque_ptr (opaque); | |
| 5675 | |
| 5676 if (!EQ (error_conditions, Qquit)) | |
| 5677 p->backtrace = maybe_get_trapping_problems_backtrace (); | |
| 5678 else | |
| 853 | 5679 p->backtrace = Qnil; |
| 5680 p->error_conditions = error_conditions; | |
| 5681 p->data = data; | |
| 5682 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
5683 throw_or_bomb_out (p->catchtag, Qnil, 0, Qnil, Qnil); |
| 2268 | 5684 RETURN_NOT_REACHED (Qnil); |
| 853 | 5685 } |
| 5686 | |
| 5687 static Lisp_Object | |
| 5688 call_trapping_problems_2 (Lisp_Object opaque) | |
| 5689 { | |
| 5690 struct call_trapping_problems *p = | |
| 5691 (struct call_trapping_problems *) get_opaque_ptr (opaque); | |
| 5692 | |
| 5693 return (p->fun) (p->arg); | |
| 428 | 5694 } |
| 5695 | |
| 5696 static Lisp_Object | |
| 853 | 5697 call_trapping_problems_1 (Lisp_Object opaque) |
| 5698 { | |
| 5699 return call_with_condition_handler (flagged_a_squirmer, opaque, | |
| 5700 call_trapping_problems_2, opaque); | |
| 5701 } | |
| 5702 | |
| 1333 | 5703 static void |
| 5704 issue_call_trapping_problems_warning (Lisp_Object warning_class, | |
| 5705 const CIbyte *warning_string, | |
| 5706 struct call_trapping_problems_result *p) | |
| 5707 { | |
| 5708 if (!warning_will_be_discarded (current_warning_level ())) | |
| 5709 { | |
| 5710 int depth = specpdl_depth (); | |
| 5711 | |
| 5712 /* We're no longer protected against errors or quit here, so at | |
| 5713 least let's temporarily inhibit quit. */ | |
| 5714 specbind (Qinhibit_quit, Qt); | |
| 5715 | |
| 5716 if (p->caught_throw) | |
| 5717 { | |
| 5718 Lisp_Object errstr = | |
| 5719 emacs_sprintf_string_lisp | |
| 2532 | 5720 ("%s: Attempt to throw outside of function:" |
| 5721 "To catch `%s' with value `%s'\n\nBacktrace follows:\n\n%s", | |
| 2725 | 5722 Qnil, 4, |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
5723 build_msg_cistring (warning_string ? warning_string : "error"), |
| 2532 | 5724 p->thrown_tag, p->thrown_value, p->backtrace); |
| 1333 | 5725 warn_when_safe_lispobj (Qerror, current_warning_level (), errstr); |
| 5726 } | |
| 2421 | 5727 else if (p->caught_error && !EQ (p->error_conditions, Qquit)) |
| 1333 | 5728 { |
| 5729 Lisp_Object errstr; | |
| 5730 /* #### This should call | |
| 5731 (with-output-to-string (display-error (cons error_conditions | |
| 5732 data)) | |
| 5733 but that stuff is all in Lisp currently. */ | |
| 5734 errstr = | |
| 5735 emacs_sprintf_string_lisp | |
| 5736 ("%s: (%s %s)\n\nBacktrace follows:\n\n%s", | |
| 5737 Qnil, 4, | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
5738 build_msg_cistring (warning_string ? warning_string : "error"), |
| 1333 | 5739 p->error_conditions, p->data, p->backtrace); |
| 5740 | |
| 5741 warn_when_safe_lispobj (warning_class, current_warning_level (), | |
| 5742 errstr); | |
| 5743 } | |
| 5744 | |
| 5745 unbind_to (depth); | |
| 5746 } | |
| 5747 } | |
| 5748 | |
| 1318 | 5749 /* Turn on the trapping flags in FLAGS -- see call_trapping_problems(). |
| 5750 This cannot handle INTERNAL_INHIBIT_THROWS() or INTERNAL_INHIBIT_ERRORS | |
| 5751 (because they ultimately boil down to a setjmp()!) -- you must directly | |
| 5752 use call_trapping_problems() for that. Turn the flags off with | |
| 5753 unbind_to(). Returns the "canonicalized" flags (particularly in the | |
| 5754 case of INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY, which is shorthand for | |
| 5755 various other flags). */ | |
| 5756 | |
| 5757 int | |
| 5758 set_trapping_problems_flags (int flags) | |
| 5759 { | |
| 5760 int new_inhibit_flags; | |
| 5761 | |
| 5762 if (flags & INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY) | |
| 5763 flags |= INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION | |
| 5764 | INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION | |
| 5765 | INHIBIT_ENTERING_DEBUGGER | |
| 5766 | INHIBIT_WARNING_ISSUE | |
| 5767 | INHIBIT_GC; | |
| 5768 | |
| 5769 new_inhibit_flags = inhibit_flags | flags; | |
| 5770 if (new_inhibit_flags != inhibit_flags) | |
| 5771 internal_bind_int (&inhibit_flags, new_inhibit_flags); | |
| 5772 | |
| 5773 if (flags & INHIBIT_QUIT) | |
| 5774 specbind (Qinhibit_quit, Qt); | |
| 5775 | |
| 5776 if (flags & UNINHIBIT_QUIT) | |
| 5777 begin_do_check_for_quit (); | |
| 5778 | |
| 5779 if (flags & INHIBIT_GC) | |
| 5780 begin_gc_forbidden (); | |
| 5781 | |
| 5782 /* #### If we have nested calls to call_trapping_problems(), and the | |
| 5783 inner one creates some buffers/etc., should the outer one be able | |
| 5784 to delete them? I think so, but it means we need to combine rather | |
| 5785 than just reset the value. */ | |
| 5786 if (flags & INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION) | |
| 5787 internal_bind_lisp_object (&Vdeletable_permanent_display_objects, Qnil); | |
| 5788 | |
| 5789 if (flags & INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION) | |
| 5790 internal_bind_lisp_object (&Vmodifiable_buffers, Qnil); | |
| 5791 | |
| 5792 return flags; | |
| 5793 } | |
| 5794 | |
| 853 | 5795 /* This is equivalent to (*fun) (arg), except that various conditions |
| 5796 can be trapped or inhibited, according to FLAGS. | |
| 5797 | |
| 5798 If FLAGS does not contain NO_INHIBIT_ERRORS, when an error occurs, | |
| 5799 the error is caught and a warning is issued, specifying the | |
| 5800 specific error that occurred and a backtrace. In that case, | |
| 5801 WARNING_STRING should be given, and will be printed at the | |
| 5802 beginning of the error to indicate where the error occurred. | |
| 5803 | |
| 5804 If FLAGS does not contain NO_INHIBIT_THROWS, all attempts to | |
| 5805 `throw' out of the function being called are trapped, and a warning | |
| 5806 issued. (Again, WARNING_STRING should be given.) | |
| 5807 | |
| 2367 | 5808 If FLAGS contains INHIBIT_WARNING_ISSUE, no warnings are issued; |
| 853 | 5809 this applies to recursive invocations of call_trapping_problems, too. |
| 5810 | |
| 1333 | 5811 If FLAGS contains POSTPONE_WARNING_ISSUE, no warnings are issued; |
| 5812 but values useful for generating a warning are still computed (in | |
| 5813 particular, the backtrace), so that the calling function can issue | |
| 5814 a warning. | |
| 5815 | |
| 853 | 5816 If FLAGS contains ISSUE_WARNINGS_AT_DEBUG_LEVEL, warnings will be |
| 5817 issued, but at level `debug', which normally is below the minimum | |
| 5818 specified by `log-warning-minimum-level', meaning such warnings will | |
| 5819 be ignored entirely. The user can change this variable, however, | |
| 5820 to see the warnings.) | |
| 5821 | |
| 5822 Note: If neither of NO_INHIBIT_THROWS or NO_INHIBIT_ERRORS is | |
| 5823 given, you are *guaranteed* that there will be no non-local exits | |
| 5824 out of this function. | |
| 5825 | |
| 5826 If FLAGS contains INHIBIT_QUIT, QUIT using C-g is inhibited. (This | |
| 5827 is *rarely* a good idea. Unless you use NO_INHIBIT_ERRORS, QUIT is | |
| 5828 automatically caught as well, and treated as an error; you can | |
| 5829 check for this using EQ (problems->error_conditions, Qquit). | |
| 5830 | |
| 5831 If FLAGS contains UNINHIBIT_QUIT, QUIT checking will be explicitly | |
| 5832 turned on. (It will abort the code being called, but will still be | |
| 5833 trapped and reported as an error, unless NO_INHIBIT_ERRORS is | |
| 5834 given.) This is useful when QUIT checking has been turned off by a | |
| 5835 higher-level caller. | |
| 5836 | |
| 5837 If FLAGS contains INHIBIT_GC, garbage collection is inhibited. | |
| 1123 | 5838 This is useful for Lisp called within redisplay, for example. |
| 853 | 5839 |
| 5840 If FLAGS contains INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION, | |
| 5841 Lisp code is not allowed to delete any window, buffers, frames, devices, | |
| 5842 or consoles that were already in existence at the time this function | |
| 5843 was called. (However, it's perfectly legal for code to create a new | |
| 5844 buffer and then delete it.) | |
| 5845 | |
| 5846 #### It might be useful to have a flag that inhibits deletion of a | |
| 5847 specific permanent display object and everything it's attached to | |
| 5848 (e.g. a window, and the buffer, frame, device, and console it's | |
| 5849 attached to. | |
| 5850 | |
| 5851 If FLAGS contains INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION, Lisp | |
| 5852 code is not allowed to modify the text of any buffers that were | |
| 5853 already in existence at the time this function was called. | |
| 5854 (However, it's perfectly legal for code to create a new buffer and | |
| 5855 then modify its text.) | |
| 5856 | |
| 5857 [These last two flags are implemented using global variables | |
| 5858 Vdeletable_permanent_display_objects and Vmodifiable_buffers, | |
| 5859 which keep track of a list of all buffers or permanent display | |
| 5860 objects created since the last time one of these flags was set. | |
| 5861 The code that deletes buffers, etc. and modifies buffers checks | |
| 5862 | |
| 5863 (1) if the corresponding flag is set (through the global variable | |
| 5864 inhibit_flags or its accessor function get_inhibit_flags()), and | |
| 5865 | |
| 5866 (2) if the object to be modified or deleted is not in the | |
| 5867 appropriate list. | |
| 5868 | |
| 5869 If so, it signals an error. | |
| 5870 | |
| 5871 Recursive calls to call_trapping_problems() are allowed. In | |
| 5872 the case of the two flags mentioned above, the current values | |
| 5873 of the global variables are stored in an unwind-protect, and | |
| 5874 they're reset to nil.] | |
| 5875 | |
| 5876 If FLAGS contains INHIBIT_ENTERING_DEBUGGER, the debugger will not | |
| 5877 be entered if an error occurs inside the Lisp code being called, | |
| 5878 even when the user has requested an error. In such case, a warning | |
| 5879 is issued stating that access to the debugger is denied, unless | |
| 5880 INHIBIT_WARNING_ISSUE has also been supplied. This is useful when | |
| 5881 calling Lisp code inside redisplay, in menu callbacks, etc. because | |
| 5882 in such cases either the display is in an inconsistent state or | |
| 5883 doing window operations is explicitly forbidden by the OS, and the | |
| 5884 debugger would causes visual changes on the screen and might create | |
| 5885 another frame. | |
| 5886 | |
| 5887 If FLAGS contains INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY, no | |
| 5888 changes of any sort to extents, faces, glyphs, buffer text, | |
| 5889 specifiers relating to display, other variables relating to | |
| 5890 display, splitting, deleting, or resizing windows or frames, | |
| 5891 deleting buffers, windows, frames, devices, or consoles, etc. is | |
| 5892 allowed. This is for things called absolutely in the middle of | |
| 5893 redisplay, which expects things to be *exactly* the same after the | |
| 5894 call as before. This isn't completely implemented and needs to be | |
| 5895 thought out some more to determine exactly what its semantics are. | |
| 5896 For the moment, turning on this flag also turns on | |
| 5897 | |
| 5898 INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION | |
| 5899 INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION | |
| 5900 INHIBIT_ENTERING_DEBUGGER | |
| 5901 INHIBIT_WARNING_ISSUE | |
| 5902 INHIBIT_GC | |
| 5903 | |
| 5904 #### The following five flags are defined, but unimplemented: | |
| 5905 | |
| 5906 #define INHIBIT_EXISTING_CODING_SYSTEM_DELETION (1<<6) | |
| 5907 #define INHIBIT_EXISTING_CHARSET_DELETION (1<<7) | |
| 5908 #define INHIBIT_PERMANENT_DISPLAY_OBJECT_CREATION (1<<8) | |
| 5909 #define INHIBIT_CODING_SYSTEM_CREATION (1<<9) | |
| 5910 #define INHIBIT_CHARSET_CREATION (1<<10) | |
| 5911 | |
| 5912 FLAGS containing CALL_WITH_SUSPENDED_ERRORS is a sign that | |
| 5913 call_with_suspended_errors() was invoked. This exists only for | |
| 5914 debugging purposes -- often we want to break when a signal happens, | |
| 5915 but ignore signals from call_with_suspended_errors(), because they | |
| 5916 occur often and for legitimate reasons. | |
| 5917 | |
| 5918 If PROBLEM is non-zero, it should be a pointer to a structure into | |
| 5919 which exact information about any occurring problems (either an | |
| 5920 error or an attempted throw past this boundary). | |
| 5921 | |
| 5922 If a problem occurred and aborted operation (error, quit, or | |
| 5923 invalid throw), Qunbound is returned. Otherwise the return value | |
| 5924 from the call to (*fun) (arg) is returned. */ | |
| 5925 | |
| 5926 Lisp_Object | |
| 5927 call_trapping_problems (Lisp_Object warning_class, | |
| 867 | 5928 const CIbyte *warning_string, |
| 853 | 5929 int flags, |
| 5930 struct call_trapping_problems_result *problem, | |
| 5931 Lisp_Object (*fun) (void *), | |
| 5932 void *arg) | |
| 5933 { | |
| 1318 | 5934 int speccount = specpdl_depth (); |
| 853 | 5935 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; |
| 5936 struct call_trapping_problems package; | |
| 1333 | 5937 struct call_trapping_problems_result real_problem; |
| 2532 | 5938 Lisp_Object opaque, thrown_tag, tem, thrown_backtrace; |
| 853 | 5939 int thrown = 0; |
| 5940 | |
| 5941 assert (SYMBOLP (warning_class)); /* sanity-check */ | |
| 5942 assert (!NILP (warning_class)); | |
| 5943 | |
| 5944 flags ^= INTERNAL_INHIBIT_ERRORS | INTERNAL_INHIBIT_THROWS; | |
| 5945 | |
| 5946 package.warning_class = warning_class; | |
| 5947 package.warning_string = warning_string; | |
| 5948 package.fun = fun; | |
| 5949 package.arg = arg; | |
| 5950 package.catchtag = | |
| 5951 flags & INTERNAL_INHIBIT_THROWS ? Vcatch_everything_tag : | |
| 5952 flags & INTERNAL_INHIBIT_ERRORS ? make_opaque_ptr (0) : | |
| 5953 Qnil; | |
| 5954 package.error_conditions = Qnil; | |
| 5955 package.data = Qnil; | |
| 5956 package.backtrace = Qnil; | |
| 5957 | |
| 1318 | 5958 flags = set_trapping_problems_flags (flags); |
| 853 | 5959 |
| 5960 if (flags & (INTERNAL_INHIBIT_THROWS | INTERNAL_INHIBIT_ERRORS)) | |
| 5961 opaque = make_opaque_ptr (&package); | |
| 5962 else | |
| 5963 opaque = Qnil; | |
| 5964 | |
| 5965 GCPRO5 (package.catchtag, package.error_conditions, package.data, | |
| 5966 package.backtrace, opaque); | |
| 5967 | |
| 5968 if (flags & INTERNAL_INHIBIT_ERRORS) | |
| 5969 /* We need a catch so that our condition-handler can throw back here | |
| 5970 after printing the warning. (We print the warning in the stack | |
| 5971 context of the error, so we can get a backtrace.) */ | |
| 5972 tem = internal_catch (package.catchtag, call_trapping_problems_1, opaque, | |
| 2532 | 5973 &thrown, &thrown_tag, &thrown_backtrace); |
| 853 | 5974 else if (flags & INTERNAL_INHIBIT_THROWS) |
| 5975 /* We skip over the first wrapper, which traps errors. */ | |
| 5976 tem = internal_catch (package.catchtag, call_trapping_problems_2, opaque, | |
| 2532 | 5977 &thrown, &thrown_tag, &thrown_backtrace); |
| 853 | 5978 else |
| 5979 /* Nothing special. */ | |
| 5980 tem = (fun) (arg); | |
| 5981 | |
| 1333 | 5982 if (!problem) |
| 5983 problem = &real_problem; | |
| 5984 | |
| 5985 if (!thrown) | |
| 853 | 5986 { |
| 1333 | 5987 problem->caught_error = 0; |
| 5988 problem->caught_throw = 0; | |
| 5989 problem->error_conditions = Qnil; | |
| 5990 problem->data = Qnil; | |
| 5991 problem->backtrace = Qnil; | |
| 5992 problem->thrown_tag = Qnil; | |
| 5993 problem->thrown_value = Qnil; | |
| 853 | 5994 } |
| 1333 | 5995 else if (EQ (thrown_tag, package.catchtag)) |
| 853 | 5996 { |
| 1333 | 5997 problem->caught_error = 1; |
| 5998 problem->caught_throw = 0; | |
| 5999 problem->error_conditions = package.error_conditions; | |
| 6000 problem->data = package.data; | |
| 6001 problem->backtrace = package.backtrace; | |
| 6002 problem->thrown_tag = Qnil; | |
| 6003 problem->thrown_value = Qnil; | |
| 853 | 6004 } |
| 1333 | 6005 else |
| 6006 { | |
| 6007 problem->caught_error = 0; | |
| 6008 problem->caught_throw = 1; | |
| 6009 problem->error_conditions = Qnil; | |
| 6010 problem->data = Qnil; | |
| 2532 | 6011 problem->backtrace = thrown_backtrace; |
| 1333 | 6012 problem->thrown_tag = thrown_tag; |
| 6013 problem->thrown_value = tem; | |
| 6014 } | |
| 6015 | |
| 6016 if (!(flags & INHIBIT_WARNING_ISSUE) && !(flags & POSTPONE_WARNING_ISSUE)) | |
| 6017 issue_call_trapping_problems_warning (warning_class, warning_string, | |
| 6018 problem); | |
| 853 | 6019 |
| 6020 if (!NILP (package.catchtag) && | |
| 6021 !EQ (package.catchtag, Vcatch_everything_tag)) | |
| 6022 free_opaque_ptr (package.catchtag); | |
| 6023 | |
| 6024 if (!NILP (opaque)) | |
| 6025 free_opaque_ptr (opaque); | |
| 6026 | |
| 6027 unbind_to (speccount); | |
| 6028 RETURN_UNGCPRO (thrown ? Qunbound : tem); | |
| 6029 } | |
| 6030 | |
| 6031 struct va_call_trapping_problems | |
| 6032 { | |
| 6033 lisp_fn_t fun; | |
| 6034 int nargs; | |
| 6035 Lisp_Object *args; | |
| 6036 }; | |
| 6037 | |
| 6038 static Lisp_Object | |
| 6039 va_call_trapping_problems_1 (void *ai_mi_madre) | |
| 6040 { | |
| 6041 struct va_call_trapping_problems *ai_no_corrida = | |
| 6042 (struct va_call_trapping_problems *) ai_mi_madre; | |
| 6043 Lisp_Object pegar_no_bumbum; | |
| 6044 | |
| 6045 PRIMITIVE_FUNCALL (pegar_no_bumbum, ai_no_corrida->fun, | |
| 6046 ai_no_corrida->args, ai_no_corrida->nargs); | |
| 6047 return pegar_no_bumbum; | |
| 6048 } | |
| 6049 | |
| 6050 /* #### document me. */ | |
| 6051 | |
| 6052 Lisp_Object | |
| 6053 va_call_trapping_problems (Lisp_Object warning_class, | |
| 867 | 6054 const CIbyte *warning_string, |
| 853 | 6055 int flags, |
| 6056 struct call_trapping_problems_result *problem, | |
| 6057 lisp_fn_t fun, int nargs, ...) | |
| 6058 { | |
| 6059 va_list vargs; | |
| 6060 Lisp_Object args[20]; | |
| 6061 int i; | |
| 6062 struct va_call_trapping_problems fazer_invocacao_atrapalhando_problemas; | |
| 6063 struct gcpro gcpro1; | |
| 6064 | |
| 6065 assert (nargs >= 0 && nargs < 20); | |
| 6066 | |
| 6067 va_start (vargs, nargs); | |
| 6068 for (i = 0; i < nargs; i++) | |
| 6069 args[i] = va_arg (vargs, Lisp_Object); | |
| 6070 va_end (vargs); | |
| 6071 | |
| 6072 fazer_invocacao_atrapalhando_problemas.fun = fun; | |
| 6073 fazer_invocacao_atrapalhando_problemas.nargs = nargs; | |
| 6074 fazer_invocacao_atrapalhando_problemas.args = args; | |
| 6075 | |
| 6076 GCPRO1_ARRAY (args, nargs); | |
| 6077 RETURN_UNGCPRO | |
| 6078 (call_trapping_problems | |
| 6079 (warning_class, warning_string, flags, problem, | |
| 6080 va_call_trapping_problems_1, &fazer_invocacao_atrapalhando_problemas)); | |
| 6081 } | |
| 6082 | |
| 6083 /* this is an older interface, barely different from | |
| 6084 va_call_trapping_problems. | |
| 6085 | |
| 6086 #### eliminate this or at least merge the ERROR_BEHAVIOR stuff into | |
| 6087 va_call_trapping_problems(). */ | |
| 6088 | |
| 6089 Lisp_Object | |
| 6090 call_with_suspended_errors (lisp_fn_t fun, Lisp_Object retval, | |
| 1204 | 6091 Lisp_Object class_, Error_Behavior errb, |
| 853 | 6092 int nargs, ...) |
| 6093 { | |
| 6094 va_list vargs; | |
| 6095 Lisp_Object args[20]; | |
| 6096 int i; | |
| 6097 struct va_call_trapping_problems fazer_invocacao_atrapalhando_problemas; | |
| 6098 int flags; | |
| 6099 struct gcpro gcpro1; | |
| 6100 | |
| 1204 | 6101 assert (SYMBOLP (class_)); /* sanity-check */ |
| 6102 assert (!NILP (class_)); | |
| 853 | 6103 assert (nargs >= 0 && nargs < 20); |
| 6104 | |
| 6105 va_start (vargs, nargs); | |
| 6106 for (i = 0; i < nargs; i++) | |
| 6107 args[i] = va_arg (vargs, Lisp_Object); | |
| 6108 va_end (vargs); | |
| 6109 | |
| 6110 /* If error-checking is not disabled, just call the function. */ | |
| 6111 | |
| 6112 if (ERRB_EQ (errb, ERROR_ME)) | |
| 6113 { | |
| 6114 Lisp_Object val; | |
| 6115 PRIMITIVE_FUNCALL (val, fun, args, nargs); | |
| 6116 return val; | |
| 6117 } | |
| 6118 | |
| 6119 if (ERRB_EQ (errb, ERROR_ME_NOT)) /* person wants no warnings */ | |
| 6120 flags = INHIBIT_WARNING_ISSUE | INHIBIT_ENTERING_DEBUGGER; | |
| 6121 else if (ERRB_EQ (errb, ERROR_ME_DEBUG_WARN)) | |
| 6122 flags = ISSUE_WARNINGS_AT_DEBUG_LEVEL | INHIBIT_ENTERING_DEBUGGER; | |
| 6123 else | |
| 6124 { | |
| 6125 assert (ERRB_EQ (errb, ERROR_ME_WARN)); | |
| 6126 flags = INHIBIT_ENTERING_DEBUGGER; | |
| 6127 } | |
| 6128 | |
| 6129 flags |= CALL_WITH_SUSPENDED_ERRORS; | |
| 6130 | |
| 6131 fazer_invocacao_atrapalhando_problemas.fun = fun; | |
| 6132 fazer_invocacao_atrapalhando_problemas.nargs = nargs; | |
| 6133 fazer_invocacao_atrapalhando_problemas.args = args; | |
| 6134 | |
| 6135 GCPRO1_ARRAY (args, nargs); | |
| 6136 { | |
| 6137 Lisp_Object its_way_too_goddamn_late = | |
| 6138 call_trapping_problems | |
| 1204 | 6139 (class_, 0, flags, 0, va_call_trapping_problems_1, |
| 853 | 6140 &fazer_invocacao_atrapalhando_problemas); |
| 6141 UNGCPRO; | |
| 6142 if (UNBOUNDP (its_way_too_goddamn_late)) | |
| 6143 return retval; | |
| 6144 else | |
| 6145 return its_way_too_goddamn_late; | |
| 6146 } | |
| 6147 } | |
| 6148 | |
| 6149 struct calln_trapping_problems | |
| 6150 { | |
| 6151 int nargs; | |
| 6152 Lisp_Object *args; | |
| 6153 }; | |
| 6154 | |
| 6155 static Lisp_Object | |
| 6156 calln_trapping_problems_1 (void *puta) | |
| 6157 { | |
| 6158 struct calln_trapping_problems *p = (struct calln_trapping_problems *) puta; | |
| 6159 | |
| 6160 return Ffuncall (p->nargs, p->args); | |
| 428 | 6161 } |
| 6162 | |
| 6163 static Lisp_Object | |
| 853 | 6164 calln_trapping_problems (Lisp_Object warning_class, |
| 867 | 6165 const CIbyte *warning_string, int flags, |
| 853 | 6166 struct call_trapping_problems_result *problem, |
| 6167 int nargs, Lisp_Object *args) | |
| 6168 { | |
| 6169 struct calln_trapping_problems foo; | |
| 6170 struct gcpro gcpro1; | |
| 6171 | |
| 6172 if (SYMBOLP (args[0])) | |
| 6173 { | |
| 6174 Lisp_Object tem = XSYMBOL (args[0])->function; | |
| 6175 if (NILP (tem) || UNBOUNDP (tem)) | |
| 6176 { | |
| 6177 if (problem) | |
| 6178 { | |
| 6179 problem->caught_error = 0; | |
| 6180 problem->caught_throw = 0; | |
| 6181 problem->error_conditions = Qnil; | |
| 6182 problem->data = Qnil; | |
| 6183 problem->backtrace = Qnil; | |
| 6184 problem->thrown_tag = Qnil; | |
| 6185 problem->thrown_value = Qnil; | |
| 6186 } | |
| 6187 return Qnil; | |
| 6188 } | |
| 6189 } | |
| 6190 | |
| 6191 foo.nargs = nargs; | |
| 6192 foo.args = args; | |
| 6193 | |
| 6194 GCPRO1_ARRAY (args, nargs); | |
| 6195 RETURN_UNGCPRO (call_trapping_problems (warning_class, warning_string, | |
| 6196 flags, problem, | |
| 6197 calln_trapping_problems_1, | |
| 6198 &foo)); | |
| 6199 } | |
| 6200 | |
| 6201 /* #### fix these functions to follow the calling convention of | |
| 6202 call_trapping_problems! */ | |
| 6203 | |
| 6204 Lisp_Object | |
| 867 | 6205 call0_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6206 int flags) |
| 6207 { | |
| 6208 return calln_trapping_problems (Qerror, warning_string, flags, 0, 1, | |
| 6209 &function); | |
| 428 | 6210 } |
| 6211 | |
| 6212 Lisp_Object | |
| 867 | 6213 call1_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6214 Lisp_Object object, int flags) |
| 6215 { | |
| 6216 Lisp_Object args[2]; | |
| 6217 | |
| 6218 args[0] = function; | |
| 6219 args[1] = object; | |
| 6220 | |
| 6221 return calln_trapping_problems (Qerror, warning_string, flags, 0, 2, | |
| 6222 args); | |
| 6223 } | |
| 6224 | |
| 6225 Lisp_Object | |
| 867 | 6226 call2_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6227 Lisp_Object object1, Lisp_Object object2, |
| 6228 int flags) | |
| 6229 { | |
| 6230 Lisp_Object args[3]; | |
| 6231 | |
| 6232 args[0] = function; | |
| 6233 args[1] = object1; | |
| 6234 args[2] = object2; | |
| 6235 | |
| 6236 return calln_trapping_problems (Qerror, warning_string, flags, 0, 3, | |
| 6237 args); | |
| 6238 } | |
| 6239 | |
| 6240 Lisp_Object | |
| 867 | 6241 call3_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6242 Lisp_Object object1, Lisp_Object object2, |
| 6243 Lisp_Object object3, int flags) | |
| 6244 { | |
| 6245 Lisp_Object args[4]; | |
| 6246 | |
| 6247 args[0] = function; | |
| 6248 args[1] = object1; | |
| 6249 args[2] = object2; | |
| 6250 args[3] = object3; | |
| 6251 | |
| 6252 return calln_trapping_problems (Qerror, warning_string, flags, 0, 4, | |
| 6253 args); | |
| 6254 } | |
| 6255 | |
| 6256 Lisp_Object | |
| 867 | 6257 call4_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6258 Lisp_Object object1, Lisp_Object object2, |
| 6259 Lisp_Object object3, Lisp_Object object4, | |
| 6260 int flags) | |
| 6261 { | |
| 6262 Lisp_Object args[5]; | |
| 6263 | |
| 6264 args[0] = function; | |
| 6265 args[1] = object1; | |
| 6266 args[2] = object2; | |
| 6267 args[3] = object3; | |
| 6268 args[4] = object4; | |
| 6269 | |
| 6270 return calln_trapping_problems (Qerror, warning_string, flags, 0, 5, | |
| 6271 args); | |
| 6272 } | |
| 6273 | |
| 6274 Lisp_Object | |
| 867 | 6275 call5_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 6276 Lisp_Object object1, Lisp_Object object2, |
| 6277 Lisp_Object object3, Lisp_Object object4, | |
| 6278 Lisp_Object object5, int flags) | |
| 6279 { | |
| 6280 Lisp_Object args[6]; | |
| 6281 | |
| 6282 args[0] = function; | |
| 6283 args[1] = object1; | |
| 6284 args[2] = object2; | |
| 6285 args[3] = object3; | |
| 6286 args[4] = object4; | |
| 6287 args[5] = object5; | |
| 6288 | |
| 6289 return calln_trapping_problems (Qerror, warning_string, flags, 0, 6, | |
| 6290 args); | |
| 6291 } | |
| 6292 | |
| 6293 struct eval_in_buffer_trapping_problems | |
| 6294 { | |
| 6295 struct buffer *buf; | |
| 6296 Lisp_Object form; | |
| 6297 }; | |
| 6298 | |
| 6299 static Lisp_Object | |
| 6300 eval_in_buffer_trapping_problems_1 (void *arg) | |
| 6301 { | |
| 6302 struct eval_in_buffer_trapping_problems *p = | |
| 6303 (struct eval_in_buffer_trapping_problems *) arg; | |
| 6304 | |
| 6305 return eval_in_buffer (p->buf, p->form); | |
| 6306 } | |
| 6307 | |
| 6308 /* #### fix these functions to follow the calling convention of | |
| 6309 call_trapping_problems! */ | |
| 6310 | |
| 6311 Lisp_Object | |
| 867 | 6312 eval_in_buffer_trapping_problems (const CIbyte *warning_string, |
| 853 | 6313 struct buffer *buf, Lisp_Object form, |
| 6314 int flags) | |
| 6315 { | |
| 6316 struct eval_in_buffer_trapping_problems p; | |
| 6317 Lisp_Object buffer = wrap_buffer (buf); | |
| 428 | 6318 struct gcpro gcpro1, gcpro2; |
| 6319 | |
| 853 | 6320 GCPRO2 (buffer, form); |
| 6321 p.buf = buf; | |
| 6322 p.form = form; | |
| 6323 RETURN_UNGCPRO (call_trapping_problems (Qerror, warning_string, flags, 0, | |
| 6324 eval_in_buffer_trapping_problems_1, | |
| 6325 &p)); | |
| 6326 } | |
| 6327 | |
| 6328 Lisp_Object | |
| 1333 | 6329 run_hook_trapping_problems (Lisp_Object warning_class, |
| 853 | 6330 Lisp_Object hook_symbol, |
| 6331 int flags) | |
| 6332 { | |
| 1333 | 6333 return run_hook_with_args_trapping_problems (warning_class, 1, &hook_symbol, |
| 853 | 6334 RUN_HOOKS_TO_COMPLETION, |
| 6335 flags); | |
| 428 | 6336 } |
| 6337 | |
| 6338 static Lisp_Object | |
| 853 | 6339 safe_run_hook_trapping_problems_1 (void *puta) |
| 6340 { | |
| 5013 | 6341 Lisp_Object hook = GET_LISP_FROM_VOID (puta); |
| 853 | 6342 |
| 6343 run_hook (hook); | |
| 428 | 6344 return Qnil; |
| 6345 } | |
| 6346 | |
| 853 | 6347 /* Same as run_hook_trapping_problems() but also set the hook to nil |
| 6348 if an error occurs (but not a quit). */ | |
| 6349 | |
| 428 | 6350 Lisp_Object |
| 1333 | 6351 safe_run_hook_trapping_problems (Lisp_Object warning_class, |
| 6352 Lisp_Object hook_symbol, int flags) | |
| 853 | 6353 { |
| 428 | 6354 Lisp_Object tem; |
| 853 | 6355 struct gcpro gcpro1, gcpro2; |
| 6356 struct call_trapping_problems_result prob; | |
| 428 | 6357 |
| 6358 if (!initialized || preparing_for_armageddon) | |
| 6359 return Qnil; | |
| 6360 tem = find_symbol_value (hook_symbol); | |
| 6361 if (NILP (tem) || UNBOUNDP (tem)) | |
| 6362 return Qnil; | |
| 6363 | |
| 853 | 6364 GCPRO2 (hook_symbol, tem); |
| 1333 | 6365 tem = call_trapping_problems (Qerror, NULL, |
| 6366 flags | POSTPONE_WARNING_ISSUE, | |
| 853 | 6367 &prob, |
| 6368 safe_run_hook_trapping_problems_1, | |
| 5013 | 6369 STORE_LISP_IN_VOID (hook_symbol)); |
| 1333 | 6370 { |
| 6371 Lisp_Object hook_name = XSYMBOL_NAME (hook_symbol); | |
| 6372 Ibyte *hook_str = XSTRING_DATA (hook_name); | |
| 6373 Ibyte *err = alloca_ibytes (XSTRING_LENGTH (hook_name) + 100); | |
| 6374 | |
| 6375 if (prob.caught_throw || (prob.caught_error && !EQ (prob.error_conditions, | |
| 6376 Qquit))) | |
| 6377 { | |
| 6378 Fset (hook_symbol, Qnil); | |
| 6379 qxesprintf (err, "Error in `%s' (resetting to nil)", hook_str); | |
| 6380 } | |
| 6381 else | |
| 6382 qxesprintf (err, "Quit in `%s'", hook_str); | |
| 6383 | |
| 6384 | |
| 6385 issue_call_trapping_problems_warning (warning_class, (CIbyte *) err, | |
| 6386 &prob); | |
| 6387 } | |
| 6388 | |
| 6389 UNGCPRO; | |
| 6390 return tem; | |
| 853 | 6391 } |
| 6392 | |
| 6393 struct run_hook_with_args_in_buffer_trapping_problems | |
| 6394 { | |
| 6395 struct buffer *buf; | |
| 6396 int nargs; | |
| 6397 Lisp_Object *args; | |
| 6398 enum run_hooks_condition cond; | |
| 6399 }; | |
| 6400 | |
| 6401 static Lisp_Object | |
| 6402 run_hook_with_args_in_buffer_trapping_problems_1 (void *puta) | |
| 6403 { | |
| 6404 struct run_hook_with_args_in_buffer_trapping_problems *porra = | |
| 6405 (struct run_hook_with_args_in_buffer_trapping_problems *) puta; | |
| 6406 | |
| 6407 return run_hook_with_args_in_buffer (porra->buf, porra->nargs, porra->args, | |
| 6408 porra->cond); | |
| 6409 } | |
| 6410 | |
| 6411 /* #### fix these functions to follow the calling convention of | |
| 6412 call_trapping_problems! */ | |
| 428 | 6413 |
| 6414 Lisp_Object | |
| 1333 | 6415 run_hook_with_args_in_buffer_trapping_problems (Lisp_Object warning_class, |
| 853 | 6416 struct buffer *buf, int nargs, |
| 6417 Lisp_Object *args, | |
| 6418 enum run_hooks_condition cond, | |
| 6419 int flags) | |
| 6420 { | |
| 6421 Lisp_Object sym, val, ret; | |
| 6422 struct run_hook_with_args_in_buffer_trapping_problems diversity_and_distrust; | |
| 428 | 6423 struct gcpro gcpro1; |
| 1333 | 6424 Lisp_Object hook_name; |
| 6425 Ibyte *hook_str; | |
| 6426 Ibyte *err; | |
| 428 | 6427 |
| 6428 if (!initialized || preparing_for_armageddon) | |
| 853 | 6429 /* We need to bail out of here pronto. */ |
| 428 | 6430 return Qnil; |
| 6431 | |
| 853 | 6432 GCPRO1_ARRAY (args, nargs); |
| 6433 | |
| 6434 sym = args[0]; | |
| 6435 val = symbol_value_in_buffer (sym, wrap_buffer (buf)); | |
| 6436 ret = (cond == RUN_HOOKS_UNTIL_FAILURE ? Qt : Qnil); | |
| 6437 | |
| 6438 if (UNBOUNDP (val) || NILP (val)) | |
| 6439 RETURN_UNGCPRO (ret); | |
| 6440 | |
| 6441 diversity_and_distrust.buf = buf; | |
| 6442 diversity_and_distrust.nargs = nargs; | |
| 6443 diversity_and_distrust.args = args; | |
| 6444 diversity_and_distrust.cond = cond; | |
| 6445 | |
| 1333 | 6446 hook_name = XSYMBOL_NAME (args[0]); |
| 6447 hook_str = XSTRING_DATA (hook_name); | |
| 6448 err = alloca_ibytes (XSTRING_LENGTH (hook_name) + 100); | |
| 6449 qxesprintf (err, "Error in `%s'", hook_str); | |
| 853 | 6450 RETURN_UNGCPRO |
| 6451 (call_trapping_problems | |
| 1333 | 6452 (warning_class, (CIbyte *) err, flags, 0, |
| 853 | 6453 run_hook_with_args_in_buffer_trapping_problems_1, |
| 6454 &diversity_and_distrust)); | |
| 428 | 6455 } |
| 6456 | |
| 6457 Lisp_Object | |
| 1333 | 6458 run_hook_with_args_trapping_problems (Lisp_Object warning_class, |
| 853 | 6459 int nargs, |
| 6460 Lisp_Object *args, | |
| 6461 enum run_hooks_condition cond, | |
| 6462 int flags) | |
| 6463 { | |
| 6464 return run_hook_with_args_in_buffer_trapping_problems | |
| 1333 | 6465 (warning_class, current_buffer, nargs, args, cond, flags); |
| 428 | 6466 } |
| 6467 | |
| 6468 Lisp_Object | |
| 1333 | 6469 va_run_hook_with_args_trapping_problems (Lisp_Object warning_class, |
| 853 | 6470 Lisp_Object hook_var, |
| 6471 int nargs, ...) | |
| 6472 { | |
| 6473 /* This function can GC */ | |
| 6474 struct gcpro gcpro1; | |
| 6475 int i; | |
| 6476 va_list vargs; | |
| 6477 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs); | |
| 6478 int flags; | |
| 6479 | |
| 6480 va_start (vargs, nargs); | |
| 6481 funcall_args[0] = hook_var; | |
| 6482 for (i = 0; i < nargs; i++) | |
| 6483 funcall_args[i + 1] = va_arg (vargs, Lisp_Object); | |
| 6484 flags = va_arg (vargs, int); | |
| 6485 va_end (vargs); | |
| 6486 | |
| 6487 GCPRO1_ARRAY (funcall_args, nargs + 1); | |
| 6488 RETURN_UNGCPRO (run_hook_with_args_in_buffer_trapping_problems | |
| 1333 | 6489 (warning_class, current_buffer, nargs + 1, funcall_args, |
| 853 | 6490 RUN_HOOKS_TO_COMPLETION, flags)); |
| 428 | 6491 } |
| 6492 | |
| 6493 Lisp_Object | |
| 1333 | 6494 va_run_hook_with_args_in_buffer_trapping_problems (Lisp_Object warning_class, |
| 853 | 6495 struct buffer *buf, |
| 6496 Lisp_Object hook_var, | |
| 6497 int nargs, ...) | |
| 6498 { | |
| 6499 /* This function can GC */ | |
| 6500 struct gcpro gcpro1; | |
| 6501 int i; | |
| 6502 va_list vargs; | |
| 6503 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs); | |
| 6504 int flags; | |
| 6505 | |
| 6506 va_start (vargs, nargs); | |
| 6507 funcall_args[0] = hook_var; | |
| 6508 for (i = 0; i < nargs; i++) | |
| 6509 funcall_args[i + 1] = va_arg (vargs, Lisp_Object); | |
| 6510 flags = va_arg (vargs, int); | |
| 6511 va_end (vargs); | |
| 6512 | |
| 6513 GCPRO1_ARRAY (funcall_args, nargs + 1); | |
| 6514 RETURN_UNGCPRO (run_hook_with_args_in_buffer_trapping_problems | |
| 1333 | 6515 (warning_class, buf, nargs + 1, funcall_args, |
| 853 | 6516 RUN_HOOKS_TO_COMPLETION, flags)); |
| 428 | 6517 } |
| 6518 | |
| 6519 | |
| 6520 /************************************************************************/ | |
| 6521 /* The special binding stack */ | |
| 771 | 6522 /* Most C code should simply use specbind() and unbind_to_1(). */ |
| 428 | 6523 /* When performance is critical, use the macros in backtrace.h. */ |
| 6524 /************************************************************************/ | |
| 6525 | |
| 6526 #define min_max_specpdl_size 400 | |
| 6527 | |
| 6528 void | |
| 647 | 6529 grow_specpdl (EMACS_INT reserved) |
| 6530 { | |
| 6531 EMACS_INT size_needed = specpdl_depth() + reserved; | |
| 428 | 6532 if (size_needed >= max_specpdl_size) |
| 6533 { | |
| 6534 if (max_specpdl_size < min_max_specpdl_size) | |
| 6535 max_specpdl_size = min_max_specpdl_size; | |
| 6536 if (size_needed >= max_specpdl_size) | |
| 6537 { | |
| 1951 | 6538 /* Leave room for some specpdl in the debugger. */ |
| 6539 max_specpdl_size = size_needed + 100; | |
| 6540 if (max_specpdl_size > specpdl_size) | |
| 6541 { | |
| 6542 specpdl_size = max_specpdl_size; | |
| 6543 XREALLOC_ARRAY (specpdl, struct specbinding, specpdl_size); | |
| 6544 specpdl_ptr = specpdl + specpdl_depth(); | |
| 6545 } | |
| 563 | 6546 signal_continuable_error |
| 6547 (Qstack_overflow, | |
| 6548 "Variable binding depth exceeds max-specpdl-size", Qunbound); | |
| 428 | 6549 } |
| 6550 } | |
| 6551 while (specpdl_size < size_needed) | |
| 6552 { | |
| 6553 specpdl_size *= 2; | |
| 6554 if (specpdl_size > max_specpdl_size) | |
| 6555 specpdl_size = max_specpdl_size; | |
| 6556 } | |
| 6557 XREALLOC_ARRAY (specpdl, struct specbinding, specpdl_size); | |
| 6558 specpdl_ptr = specpdl + specpdl_depth(); | |
| 853 | 6559 check_specbind_stack_sanity (); |
| 428 | 6560 } |
| 6561 | |
| 6562 | |
| 6563 /* Handle unbinding buffer-local variables */ | |
| 6564 static Lisp_Object | |
| 6565 specbind_unwind_local (Lisp_Object ovalue) | |
| 6566 { | |
| 6567 Lisp_Object current = Fcurrent_buffer (); | |
| 6568 Lisp_Object symbol = specpdl_ptr->symbol; | |
| 853 | 6569 Lisp_Object victim = ovalue; |
| 6570 Lisp_Object buf = get_buffer (XCAR (victim), 0); | |
| 6571 ovalue = XCDR (victim); | |
| 428 | 6572 |
| 6573 free_cons (victim); | |
| 6574 | |
| 6575 if (NILP (buf)) | |
| 6576 { | |
| 6577 /* Deleted buffer -- do nothing */ | |
| 6578 } | |
| 6579 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buf)) == 0) | |
| 6580 { | |
| 6581 /* Was buffer-local when binding was made, now no longer is. | |
| 6582 * (kill-local-variable can do this.) | |
| 6583 * Do nothing in this case. | |
| 6584 */ | |
| 6585 } | |
| 6586 else if (EQ (buf, current)) | |
| 6587 Fset (symbol, ovalue); | |
| 6588 else | |
| 6589 { | |
| 6590 /* Urk! Somebody switched buffers */ | |
| 6591 struct gcpro gcpro1; | |
| 6592 GCPRO1 (current); | |
| 6593 Fset_buffer (buf); | |
| 6594 Fset (symbol, ovalue); | |
| 6595 Fset_buffer (current); | |
| 6596 UNGCPRO; | |
| 6597 } | |
| 6598 return symbol; | |
| 6599 } | |
| 6600 | |
| 6601 static Lisp_Object | |
| 6602 specbind_unwind_wasnt_local (Lisp_Object buffer) | |
| 6603 { | |
| 6604 Lisp_Object current = Fcurrent_buffer (); | |
| 6605 Lisp_Object symbol = specpdl_ptr->symbol; | |
| 6606 | |
| 6607 buffer = get_buffer (buffer, 0); | |
| 6608 if (NILP (buffer)) | |
| 6609 { | |
| 6610 /* Deleted buffer -- do nothing */ | |
| 6611 } | |
| 6612 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buffer)) == 0) | |
| 6613 { | |
| 6614 /* Was buffer-local when binding was made, now no longer is. | |
| 6615 * (kill-local-variable can do this.) | |
| 6616 * Do nothing in this case. | |
| 6617 */ | |
| 6618 } | |
| 6619 else if (EQ (buffer, current)) | |
| 6620 Fkill_local_variable (symbol); | |
| 6621 else | |
| 6622 { | |
| 6623 /* Urk! Somebody switched buffers */ | |
| 6624 struct gcpro gcpro1; | |
| 6625 GCPRO1 (current); | |
| 6626 Fset_buffer (buffer); | |
| 6627 Fkill_local_variable (symbol); | |
| 6628 Fset_buffer (current); | |
| 6629 UNGCPRO; | |
| 6630 } | |
| 6631 return symbol; | |
| 6632 } | |
| 6633 | |
| 6634 | |
| 6635 void | |
| 6636 specbind (Lisp_Object symbol, Lisp_Object value) | |
| 6637 { | |
| 6638 SPECBIND (symbol, value); | |
| 853 | 6639 |
| 6640 check_specbind_stack_sanity (); | |
| 428 | 6641 } |
| 6642 | |
| 6643 void | |
| 6644 specbind_magic (Lisp_Object symbol, Lisp_Object value) | |
| 6645 { | |
| 6646 int buffer_local = | |
| 6647 symbol_value_buffer_local_info (symbol, current_buffer); | |
| 6648 | |
| 6649 if (buffer_local == 0) | |
| 6650 { | |
| 6651 specpdl_ptr->old_value = find_symbol_value (symbol); | |
| 771 | 6652 specpdl_ptr->func = 0; /* Handled specially by unbind_to_1 */ |
| 428 | 6653 } |
| 6654 else if (buffer_local > 0) | |
| 6655 { | |
| 6656 /* Already buffer-local */ | |
| 6657 specpdl_ptr->old_value = noseeum_cons (Fcurrent_buffer (), | |
| 6658 find_symbol_value (symbol)); | |
| 6659 specpdl_ptr->func = specbind_unwind_local; | |
| 6660 } | |
| 6661 else | |
| 6662 { | |
| 6663 /* About to become buffer-local */ | |
| 6664 specpdl_ptr->old_value = Fcurrent_buffer (); | |
| 6665 specpdl_ptr->func = specbind_unwind_wasnt_local; | |
| 6666 } | |
| 6667 | |
| 6668 specpdl_ptr->symbol = symbol; | |
| 6669 specpdl_ptr++; | |
| 6670 specpdl_depth_counter++; | |
| 6671 | |
| 6672 Fset (symbol, value); | |
| 853 | 6673 |
| 6674 check_specbind_stack_sanity (); | |
| 428 | 6675 } |
| 6676 | |
| 771 | 6677 /* Record an unwind-protect -- FUNCTION will be called with ARG no matter |
| 6678 whether a normal or non-local exit occurs. (You need to call unbind_to_1() | |
| 6679 before your function returns normally, passing in the integer returned | |
| 6680 by this function.) Note: As long as the unwind-protect exists, ARG is | |
| 6681 automatically GCPRO'd. The return value from FUNCTION is completely | |
| 6682 ignored. #### We should eliminate it entirely. */ | |
| 6683 | |
| 6684 int | |
| 428 | 6685 record_unwind_protect (Lisp_Object (*function) (Lisp_Object arg), |
| 6686 Lisp_Object arg) | |
| 6687 { | |
| 6688 SPECPDL_RESERVE (1); | |
| 6689 specpdl_ptr->func = function; | |
| 6690 specpdl_ptr->symbol = Qnil; | |
| 6691 specpdl_ptr->old_value = arg; | |
| 6692 specpdl_ptr++; | |
| 6693 specpdl_depth_counter++; | |
| 853 | 6694 check_specbind_stack_sanity (); |
| 771 | 6695 return specpdl_depth_counter - 1; |
| 6696 } | |
| 6697 | |
| 6698 static Lisp_Object | |
| 802 | 6699 restore_lisp_object (Lisp_Object cons) |
| 6700 { | |
| 5013 | 6701 Lisp_Object laddr = XCAR (cons); |
| 6702 Lisp_Object *addr = (Lisp_Object *) GET_VOID_FROM_LISP (laddr); | |
| 802 | 6703 *addr = XCDR (cons); |
| 853 | 6704 free_cons (cons); |
| 802 | 6705 return Qnil; |
| 6706 } | |
| 6707 | |
| 6708 /* Establish an unwind-protect which will restore the Lisp_Object pointed to | |
| 6709 by ADDR with the value VAL. */ | |
| 814 | 6710 static int |
| 802 | 6711 record_unwind_protect_restoring_lisp_object (Lisp_Object *addr, |
| 6712 Lisp_Object val) | |
| 6713 { | |
| 5013 | 6714 /* We use a cons rather than a malloc()ed structure because we want the |
| 6715 Lisp object to have garbage-collection protection */ | |
| 6716 Lisp_Object laddr = STORE_VOID_IN_LISP (addr); | |
| 802 | 6717 return record_unwind_protect (restore_lisp_object, |
| 5013 | 6718 noseeum_cons (laddr, val)); |
| 802 | 6719 } |
| 6720 | |
| 6721 /* Similar to specbind() but for any C variable whose value is a | |
| 6722 Lisp_Object. Sets up an unwind-protect to restore the variable | |
| 6723 pointed to by ADDR to its existing value, and then changes its | |
| 6724 value to NEWVAL. Returns the previous value of specpdl_depth(); | |
| 6725 pass this to unbind_to() after you are done. */ | |
| 6726 int | |
| 6727 internal_bind_lisp_object (Lisp_Object *addr, Lisp_Object newval) | |
| 6728 { | |
| 6729 int count = specpdl_depth (); | |
| 6730 record_unwind_protect_restoring_lisp_object (addr, *addr); | |
| 6731 *addr = newval; | |
| 6732 return count; | |
| 6733 } | |
| 6734 | |
| 5013 | 6735 struct restore_int |
| 6736 { | |
| 6737 int *addr; | |
| 802 | 6738 int val; |
| 5013 | 6739 }; |
| 6740 | |
| 6741 static Lisp_Object | |
| 6742 restore_int (Lisp_Object obj) | |
| 6743 { | |
| 6744 struct restore_int *ri = (struct restore_int *) GET_VOID_FROM_LISP (obj); | |
| 6745 *(ri->addr) = ri->val; | |
| 6746 xfree (ri); | |
| 802 | 6747 return Qnil; |
| 6748 } | |
| 6749 | |
| 6750 /* Establish an unwind-protect which will restore the int pointed to | |
| 6751 by ADDR with the value VAL. This function works correctly with | |
| 6752 all ints, even those that don't fit into a Lisp integer. */ | |
| 1333 | 6753 int |
| 802 | 6754 record_unwind_protect_restoring_int (int *addr, int val) |
| 6755 { | |
| 5013 | 6756 struct restore_int *ri = xnew (struct restore_int); |
| 6757 ri->addr = addr; | |
| 6758 ri->val = val; | |
| 6759 return record_unwind_protect (restore_int, STORE_VOID_IN_LISP (ri)); | |
| 802 | 6760 } |
| 6761 | |
| 6762 /* Similar to specbind() but for any C variable whose value is an int. | |
| 6763 Sets up an unwind-protect to restore the variable pointed to by | |
| 6764 ADDR to its existing value, and then changes its value to NEWVAL. | |
| 6765 Returns the previous value of specpdl_depth(); pass this to | |
| 6766 unbind_to() after you are done. This function works correctly with | |
| 6767 all ints, even those that don't fit into a Lisp integer. */ | |
| 6768 int | |
| 6769 internal_bind_int (int *addr, int newval) | |
| 6770 { | |
| 6771 int count = specpdl_depth (); | |
| 6772 record_unwind_protect_restoring_int (addr, *addr); | |
| 6773 *addr = newval; | |
| 6774 return count; | |
| 6775 } | |
| 6776 | |
| 6777 static Lisp_Object | |
| 771 | 6778 free_pointer (Lisp_Object opaque) |
| 6779 { | |
| 5013 | 6780 void *ptr = GET_VOID_FROM_LISP (opaque); |
| 6781 xfree (ptr); | |
| 771 | 6782 return Qnil; |
| 6783 } | |
| 6784 | |
| 6785 /* Establish an unwind-protect which will free the specified block. | |
| 6786 */ | |
| 6787 int | |
| 6788 record_unwind_protect_freeing (void *ptr) | |
| 6789 { | |
| 5013 | 6790 return record_unwind_protect (free_pointer, STORE_VOID_IN_LISP (ptr)); |
| 771 | 6791 } |
| 6792 | |
| 6793 static Lisp_Object | |
| 6794 free_dynarr (Lisp_Object opaque) | |
| 6795 { | |
| 5013 | 6796 Dynarr_free (GET_VOID_FROM_LISP (opaque)); |
| 771 | 6797 return Qnil; |
| 6798 } | |
| 6799 | |
| 6800 int | |
| 6801 record_unwind_protect_freeing_dynarr (void *ptr) | |
| 6802 { | |
| 5013 | 6803 return record_unwind_protect (free_dynarr, STORE_VOID_IN_LISP (ptr)); |
| 771 | 6804 } |
| 428 | 6805 |
| 6806 /* Unwind the stack till specpdl_depth() == COUNT. | |
| 6807 VALUE is not used, except that, purely as a convenience to the | |
| 771 | 6808 caller, it is protected from garbage-protection and returned. */ |
| 428 | 6809 Lisp_Object |
| 771 | 6810 unbind_to_1 (int count, Lisp_Object value) |
| 428 | 6811 { |
| 6812 UNBIND_TO_GCPRO (count, value); | |
| 853 | 6813 check_specbind_stack_sanity (); |
| 428 | 6814 return value; |
| 6815 } | |
| 6816 | |
| 6817 /* Don't call this directly. | |
| 6818 Only for use by UNBIND_TO* macros in backtrace.h */ | |
| 6819 void | |
| 6820 unbind_to_hairy (int count) | |
| 6821 { | |
| 442 | 6822 ++specpdl_ptr; |
| 6823 ++specpdl_depth_counter; | |
| 6824 | |
| 428 | 6825 while (specpdl_depth_counter != count) |
| 6826 { | |
| 1313 | 6827 Lisp_Object oquit = Qunbound; |
| 6828 | |
| 6829 /* Do this check BEFORE decrementing the values below, because once | |
| 6830 they're decremented, GC protection is lost on | |
| 6831 specpdl_ptr->old_value. */ | |
| 1322 | 6832 if (specpdl_ptr[-1].func == Fprogn) |
| 1313 | 6833 { |
| 6834 /* Allow QUIT within unwind-protect routines, but defer any | |
| 6835 existing QUIT until afterwards. Only do this, however, for | |
| 6836 unwind-protects established by Lisp code, not by C code | |
| 6837 (e.g. free_opaque_ptr() or something), because the act of | |
| 6838 checking for QUIT can cause all sorts of weird things to | |
| 6839 happen, since it churns the event loop -- redisplay, running | |
| 6840 Lisp, etc. Code should not have to worry about this just | |
| 6841 because of establishing an unwind-protect. */ | |
| 6842 check_quit (); /* make Vquit_flag accurate */ | |
| 6843 oquit = Vquit_flag; | |
| 6844 Vquit_flag = Qnil; | |
| 6845 } | |
| 6846 | |
| 428 | 6847 --specpdl_ptr; |
| 6848 --specpdl_depth_counter; | |
| 6849 | |
| 1313 | 6850 /* #### At this point, there is no GC protection on old_value. This |
| 6851 could be a real problem, depending on what unwind-protect function | |
| 6852 is called. It looks like it just so happens that the ones | |
| 6853 actually called don't have a problem with this, e.g. Fprogn. But | |
| 6854 we should look into fixing this. (Many unwind-protect functions | |
| 6855 free values. Is it a problem if freed values are | |
| 6856 GC-protected?) */ | |
| 428 | 6857 if (specpdl_ptr->func != 0) |
| 1313 | 6858 { |
| 6859 /* An unwind-protect */ | |
| 6860 (*specpdl_ptr->func) (specpdl_ptr->old_value); | |
| 6861 } | |
| 6862 | |
| 428 | 6863 else |
| 6864 { | |
| 6865 /* We checked symbol for validity when we specbound it, | |
| 6866 so only need to call Fset if symbol has magic value. */ | |
| 440 | 6867 Lisp_Symbol *sym = XSYMBOL (specpdl_ptr->symbol); |
| 428 | 6868 if (!SYMBOL_VALUE_MAGIC_P (sym->value)) |
| 6869 sym->value = specpdl_ptr->old_value; | |
| 6870 else | |
| 6871 Fset (specpdl_ptr->symbol, specpdl_ptr->old_value); | |
| 6872 } | |
| 6873 | |
| 6874 #if 0 /* martin */ | |
| 6875 #ifndef EXCEEDINGLY_QUESTIONABLE_CODE | |
| 6876 /* There should never be anything here for us to remove. | |
| 6877 If so, it indicates a logic error in Emacs. Catches | |
| 6878 should get removed when a throw or signal occurs, or | |
| 6879 when a catch or condition-case exits normally. But | |
| 6880 it's too dangerous to just remove this code. --ben */ | |
| 6881 | |
| 6882 /* Furthermore, this code is not in FSFmacs!!! | |
| 6883 Braino on mly's part? */ | |
| 6884 /* If we're unwound past the pdlcount of a catch frame, | |
| 6885 that catch can't possibly still be valid. */ | |
| 6886 while (catchlist && catchlist->pdlcount > specpdl_depth_counter) | |
| 6887 { | |
| 6888 catchlist = catchlist->next; | |
| 6889 /* Don't mess with gcprolist, backtrace_list here */ | |
| 6890 } | |
| 6891 #endif | |
| 6892 #endif | |
| 1313 | 6893 |
| 6894 if (!UNBOUNDP (oquit)) | |
| 6895 Vquit_flag = oquit; | |
| 428 | 6896 } |
| 853 | 6897 check_specbind_stack_sanity (); |
| 428 | 6898 } |
| 6899 | |
| 6900 | |
| 6901 | |
| 6902 /* Get the value of symbol's global binding, even if that binding is | |
| 6903 not now dynamically visible. May return Qunbound or magic values. */ | |
| 6904 | |
| 6905 Lisp_Object | |
| 6906 top_level_value (Lisp_Object symbol) | |
| 6907 { | |
| 6908 REGISTER struct specbinding *ptr = specpdl; | |
| 6909 | |
| 6910 CHECK_SYMBOL (symbol); | |
| 6911 for (; ptr != specpdl_ptr; ptr++) | |
| 6912 { | |
| 6913 if (EQ (ptr->symbol, symbol)) | |
| 6914 return ptr->old_value; | |
| 6915 } | |
| 6916 return XSYMBOL (symbol)->value; | |
| 6917 } | |
| 6918 | |
| 6919 #if 0 | |
| 6920 | |
| 6921 Lisp_Object | |
| 6922 top_level_set (Lisp_Object symbol, Lisp_Object newval) | |
| 6923 { | |
| 6924 REGISTER struct specbinding *ptr = specpdl; | |
| 6925 | |
| 6926 CHECK_SYMBOL (symbol); | |
| 6927 for (; ptr != specpdl_ptr; ptr++) | |
| 6928 { | |
| 6929 if (EQ (ptr->symbol, symbol)) | |
| 6930 { | |
| 6931 ptr->old_value = newval; | |
| 6932 return newval; | |
| 6933 } | |
| 6934 } | |
| 6935 return Fset (symbol, newval); | |
| 6936 } | |
| 6937 | |
| 6938 #endif /* 0 */ | |
| 6939 | |
| 6940 | |
| 6941 /************************************************************************/ | |
| 6942 /* Backtraces */ | |
| 6943 /************************************************************************/ | |
| 6944 | |
| 6945 DEFUN ("backtrace-debug", Fbacktrace_debug, 2, 2, 0, /* | |
| 6946 Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG. | |
| 6947 The debugger is entered when that frame exits, if the flag is non-nil. | |
| 6948 */ | |
| 6949 (level, flag)) | |
| 6950 { | |
| 6951 REGISTER struct backtrace *backlist = backtrace_list; | |
| 6952 REGISTER int i; | |
| 6953 | |
| 6954 CHECK_INT (level); | |
| 6955 | |
| 6956 for (i = 0; backlist && i < XINT (level); i++) | |
| 6957 { | |
| 6958 backlist = backlist->next; | |
| 6959 } | |
| 6960 | |
| 6961 if (backlist) | |
| 6962 backlist->debug_on_exit = !NILP (flag); | |
| 6963 | |
| 6964 return flag; | |
| 6965 } | |
| 6966 | |
| 6967 static void | |
| 6968 backtrace_specials (int speccount, int speclimit, Lisp_Object stream) | |
| 6969 { | |
| 6970 int printing_bindings = 0; | |
| 6971 | |
| 6972 for (; speccount > speclimit; speccount--) | |
| 6973 { | |
| 6974 if (specpdl[speccount - 1].func == 0 | |
| 6975 || specpdl[speccount - 1].func == specbind_unwind_local | |
| 6976 || specpdl[speccount - 1].func == specbind_unwind_wasnt_local) | |
| 6977 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
6978 write_ascstring (stream, !printing_bindings ? " # bind (" : " "); |
| 428 | 6979 Fprin1 (specpdl[speccount - 1].symbol, stream); |
| 6980 printing_bindings = 1; | |
| 6981 } | |
| 6982 else | |
| 6983 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
6984 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
|
6985 write_ascstring (stream, " # (unwind-protect ...)\n"); |
| 428 | 6986 printing_bindings = 0; |
| 6987 } | |
| 6988 } | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
6989 if (printing_bindings) write_ascstring (stream, ")\n"); |
| 428 | 6990 } |
| 6991 | |
| 1292 | 6992 static Lisp_Object |
| 6993 backtrace_unevalled_args (Lisp_Object *args) | |
| 6994 { | |
| 6995 if (args) | |
| 6996 return *args; | |
| 6997 else | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
6998 return list1 (build_ascstring ("[internal]")); |
| 1292 | 6999 } |
| 7000 | |
| 428 | 7001 DEFUN ("backtrace", Fbacktrace, 0, 2, "", /* |
| 7002 Print a trace of Lisp function calls currently active. | |
| 438 | 7003 Optional arg STREAM specifies the output stream to send the backtrace to, |
| 444 | 7004 and defaults to the value of `standard-output'. |
| 7005 Optional second arg DETAILED non-nil means show places where currently | |
| 7006 active variable bindings, catches, condition-cases, and | |
| 7007 unwind-protects, as well as function calls, were made. | |
| 428 | 7008 */ |
| 7009 (stream, detailed)) | |
| 7010 { | |
| 7011 /* This function can GC */ | |
| 7012 struct backtrace *backlist = backtrace_list; | |
| 7013 struct catchtag *catches = catchlist; | |
| 7014 int speccount = specpdl_depth(); | |
| 7015 | |
| 7016 int old_nl = print_escape_newlines; | |
| 7017 int old_pr = print_readably; | |
| 7018 Lisp_Object old_level = Vprint_level; | |
| 7019 Lisp_Object oiq = Vinhibit_quit; | |
| 7020 struct gcpro gcpro1, gcpro2; | |
| 7021 | |
| 7022 /* We can't allow quits in here because that could cause the values | |
| 7023 of print_readably and print_escape_newlines to get screwed up. | |
| 7024 Normally we would use a record_unwind_protect but that would | |
| 7025 screw up the functioning of this function. */ | |
| 7026 Vinhibit_quit = Qt; | |
| 7027 | |
| 7028 entering_debugger = 0; | |
| 7029 | |
| 872 | 7030 if (!NILP (detailed)) |
| 7031 Vprint_level = make_int (50); | |
| 7032 else | |
| 7033 Vprint_level = make_int (3); | |
| 428 | 7034 print_readably = 0; |
| 7035 print_escape_newlines = 1; | |
| 7036 | |
| 7037 GCPRO2 (stream, old_level); | |
| 7038 | |
| 1261 | 7039 stream = canonicalize_printcharfun (stream); |
| 428 | 7040 |
| 7041 for (;;) | |
| 7042 { | |
| 7043 if (!NILP (detailed) && catches && catches->backlist == backlist) | |
| 7044 { | |
| 7045 int catchpdl = catches->pdlcount; | |
| 438 | 7046 if (speccount > catchpdl |
| 7047 && specpdl[catchpdl].func == condition_case_unwind) | |
| 428 | 7048 /* This is a condition-case catchpoint */ |
| 7049 catchpdl = catchpdl + 1; | |
| 7050 | |
| 7051 backtrace_specials (speccount, catchpdl, stream); | |
| 7052 | |
| 7053 speccount = catches->pdlcount; | |
| 7054 if (catchpdl == speccount) | |
| 7055 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7056 write_ascstring (stream, " # (catch "); |
| 428 | 7057 Fprin1 (catches->tag, stream); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7058 write_ascstring (stream, " ...)\n"); |
| 428 | 7059 } |
| 7060 else | |
| 7061 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7062 write_ascstring (stream, " # (condition-case ... . "); |
| 428 | 7063 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
|
7064 write_ascstring (stream, ")\n"); |
| 428 | 7065 } |
| 7066 catches = catches->next; | |
| 7067 } | |
| 7068 else if (!backlist) | |
| 7069 break; | |
| 7070 else | |
| 7071 { | |
| 7072 if (!NILP (detailed) && backlist->pdlcount < speccount) | |
| 7073 { | |
| 7074 backtrace_specials (speccount, backlist->pdlcount, stream); | |
| 7075 speccount = backlist->pdlcount; | |
| 7076 } | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7077 write_ascstring (stream, backlist->debug_on_exit ? "* " : " "); |
| 428 | 7078 if (backlist->nargs == UNEVALLED) |
| 7079 { | |
| 1292 | 7080 Fprin1 (Fcons (*backlist->function, |
| 7081 backtrace_unevalled_args (backlist->args)), | |
| 7082 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"); /* from FSFmacs 19.30 */ |
| 428 | 7084 } |
| 7085 else | |
| 7086 { | |
| 7087 Lisp_Object tem = *backlist->function; | |
| 7088 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
|
7089 write_ascstring (stream, "("); |
| 428 | 7090 if (backlist->nargs == MANY) |
| 7091 { | |
| 7092 int i; | |
| 7093 Lisp_Object tail = Qnil; | |
| 7094 struct gcpro ngcpro1; | |
| 7095 | |
| 7096 NGCPRO1 (tail); | |
| 7097 for (tail = *backlist->args, i = 0; | |
| 7098 !NILP (tail); | |
| 7099 tail = Fcdr (tail), i++) | |
| 7100 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7101 if (i != 0) write_ascstring (stream, " "); |
| 428 | 7102 Fprin1 (Fcar (tail), stream); |
| 7103 } | |
| 7104 NUNGCPRO; | |
| 7105 } | |
| 7106 else | |
| 7107 { | |
| 7108 int i; | |
| 7109 for (i = 0; i < backlist->nargs; i++) | |
| 7110 { | |
| 826 | 7111 if (!i && EQ (tem, Qbyte_code)) |
| 7112 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7113 write_ascstring (stream, "\"...\""); |
| 826 | 7114 continue; |
| 7115 } | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7116 if (i != 0) write_ascstring (stream, " "); |
| 428 | 7117 Fprin1 (backlist->args[i], stream); |
| 7118 } | |
| 7119 } | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7120 write_ascstring (stream, ")\n"); |
| 428 | 7121 } |
| 7122 backlist = backlist->next; | |
| 7123 } | |
| 7124 } | |
| 7125 Vprint_level = old_level; | |
| 7126 print_readably = old_pr; | |
| 7127 print_escape_newlines = old_nl; | |
| 7128 UNGCPRO; | |
| 7129 Vinhibit_quit = oiq; | |
| 7130 return Qnil; | |
| 7131 } | |
| 7132 | |
| 7133 | |
| 444 | 7134 DEFUN ("backtrace-frame", Fbacktrace_frame, 1, 1, 0, /* |
| 7135 Return the function and arguments NFRAMES up from current execution point. | |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
7136 If that frame has not evaluated the arguments yet (or involves a special |
|
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
7137 operator), the value is (nil FUNCTION ARG-FORMS...). |
| 428 | 7138 If that frame has evaluated its arguments and called its function already, |
| 7139 the value is (t FUNCTION ARG-VALUES...). | |
| 7140 A &rest arg is represented as the tail of the list ARG-VALUES. | |
| 7141 FUNCTION is whatever was supplied as car of evaluated list, | |
| 7142 or a lambda expression for macro calls. | |
| 444 | 7143 If NFRAMES is more than the number of frames, the value is nil. |
| 428 | 7144 */ |
| 7145 (nframes)) | |
| 7146 { | |
| 7147 REGISTER struct backtrace *backlist = backtrace_list; | |
| 7148 REGISTER int i; | |
| 7149 Lisp_Object tem; | |
| 7150 | |
| 7151 CHECK_NATNUM (nframes); | |
| 7152 | |
| 7153 /* Find the frame requested. */ | |
| 7154 for (i = XINT (nframes); backlist && (i-- > 0);) | |
| 7155 backlist = backlist->next; | |
| 7156 | |
| 7157 if (!backlist) | |
| 7158 return Qnil; | |
| 7159 if (backlist->nargs == UNEVALLED) | |
| 1292 | 7160 return Fcons (Qnil, Fcons (*backlist->function, |
| 7161 backtrace_unevalled_args (backlist->args))); | |
| 428 | 7162 else |
| 7163 { | |
| 7164 if (backlist->nargs == MANY) | |
| 7165 tem = *backlist->args; | |
| 7166 else | |
| 7167 tem = Flist (backlist->nargs, backlist->args); | |
| 7168 | |
| 7169 return Fcons (Qt, Fcons (*backlist->function, tem)); | |
| 7170 } | |
| 7171 } | |
| 7172 | |
| 7173 | |
| 7174 /************************************************************************/ | |
| 7175 /* Warnings */ | |
| 7176 /************************************************************************/ | |
| 7177 | |
| 1123 | 7178 static int |
| 7179 warning_will_be_discarded (Lisp_Object level) | |
| 7180 { | |
| 7181 /* Don't even generate debug warnings if they're going to be discarded, | |
| 7182 to avoid excessive consing. */ | |
| 7183 return (EQ (level, Qdebug) && !NILP (Vlog_warning_minimum_level) && | |
| 7184 !EQ (Vlog_warning_minimum_level, Qdebug)); | |
| 7185 } | |
| 7186 | |
| 428 | 7187 void |
| 1204 | 7188 warn_when_safe_lispobj (Lisp_Object class_, Lisp_Object level, |
| 428 | 7189 Lisp_Object obj) |
| 7190 { | |
| 1123 | 7191 if (warning_will_be_discarded (level)) |
| 793 | 7192 return; |
| 1123 | 7193 |
| 1204 | 7194 obj = list1 (list3 (class_, level, obj)); |
| 428 | 7195 if (NILP (Vpending_warnings)) |
| 7196 Vpending_warnings = Vpending_warnings_tail = obj; | |
| 7197 else | |
| 7198 { | |
| 7199 Fsetcdr (Vpending_warnings_tail, obj); | |
| 7200 Vpending_warnings_tail = obj; | |
| 7201 } | |
| 7202 } | |
| 7203 | |
| 7204 /* #### This should probably accept Lisp objects; but then we have | |
| 7205 to make sure that Feval() isn't called, since it might not be safe. | |
| 7206 | |
| 7207 An alternative approach is to just pass some non-string type of | |
| 7208 Lisp_Object to warn_when_safe_lispobj(); `prin1-to-string' will | |
| 7209 automatically be called when it is safe to do so. */ | |
| 7210 | |
| 7211 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7212 warn_when_safe (Lisp_Object class_, Lisp_Object level, const Ascbyte *fmt, ...) |
| 428 | 7213 { |
| 7214 Lisp_Object obj; | |
| 7215 va_list args; | |
| 7216 | |
| 1123 | 7217 if (warning_will_be_discarded (level)) |
| 793 | 7218 return; |
| 1123 | 7219 |
| 428 | 7220 va_start (args, fmt); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
7221 obj = emacs_vsprintf_string (GETTEXT (fmt), args); |
| 428 | 7222 va_end (args); |
| 7223 | |
| 1204 | 7224 warn_when_safe_lispobj (class_, level, obj); |
| 428 | 7225 } |
| 7226 | |
| 7227 | |
| 7228 | |
| 7229 | |
| 7230 /************************************************************************/ | |
| 7231 /* Initialization */ | |
| 7232 /************************************************************************/ | |
| 7233 | |
| 7234 void | |
| 7235 syms_of_eval (void) | |
| 7236 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
7237 INIT_LISP_OBJECT (subr); |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
7238 INIT_LISP_OBJECT (multiple_value); |
| 442 | 7239 |
| 563 | 7240 DEFSYMBOL (Qinhibit_quit); |
| 7241 DEFSYMBOL (Qautoload); | |
| 7242 DEFSYMBOL (Qdebug_on_error); | |
| 7243 DEFSYMBOL (Qstack_trace_on_error); | |
| 7244 DEFSYMBOL (Qdebug_on_signal); | |
| 7245 DEFSYMBOL (Qstack_trace_on_signal); | |
| 7246 DEFSYMBOL (Qdebugger); | |
| 7247 DEFSYMBOL (Qmacro); | |
| 428 | 7248 defsymbol (&Qand_rest, "&rest"); |
| 7249 defsymbol (&Qand_optional, "&optional"); | |
| 7250 /* Note that the process code also uses Qexit */ | |
| 563 | 7251 DEFSYMBOL (Qexit); |
| 7252 DEFSYMBOL (Qsetq); | |
| 7253 DEFSYMBOL (Qinteractive); | |
| 7254 DEFSYMBOL (Qcommandp); | |
| 7255 DEFSYMBOL (Qdefun); | |
| 7256 DEFSYMBOL (Qprogn); | |
| 7257 DEFSYMBOL (Qvalues); | |
| 7258 DEFSYMBOL (Qdisplay_warning); | |
| 7259 DEFSYMBOL (Qrun_hooks); | |
| 887 | 7260 DEFSYMBOL (Qfinalize_list); |
| 563 | 7261 DEFSYMBOL (Qif); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7262 DEFSYMBOL (Qthrow); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7263 DEFSYMBOL (Qobsolete_throw); |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
7264 DEFSYMBOL (Qmultiple_value_list_internal); |
| 428 | 7265 |
| 7266 DEFSUBR (For); | |
| 7267 DEFSUBR (Fand); | |
| 7268 DEFSUBR (Fif); | |
| 7269 DEFSUBR_MACRO (Fwhen); | |
| 7270 DEFSUBR_MACRO (Funless); | |
| 7271 DEFSUBR (Fcond); | |
| 7272 DEFSUBR (Fprogn); | |
| 7273 DEFSUBR (Fprog1); | |
| 7274 DEFSUBR (Fprog2); | |
| 7275 DEFSUBR (Fsetq); | |
| 7276 DEFSUBR (Fquote); | |
|
4744
17f7e9191c0b
Rationalise duplicated functionality, #'custom-quote, #'quote-maybe.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
7277 DEFSUBR (Fquote_maybe); |
| 428 | 7278 DEFSUBR (Ffunction); |
| 7279 DEFSUBR (Fdefun); | |
| 7280 DEFSUBR (Fdefmacro); | |
| 7281 DEFSUBR (Fdefvar); | |
| 7282 DEFSUBR (Fdefconst); | |
| 7283 DEFSUBR (Flet); | |
| 7284 DEFSUBR (FletX); | |
| 7285 DEFSUBR (Fwhile); | |
| 7286 DEFSUBR (Fmacroexpand_internal); | |
| 7287 DEFSUBR (Fcatch); | |
| 7288 DEFSUBR (Fthrow); | |
| 7289 DEFSUBR (Funwind_protect); | |
| 7290 DEFSUBR (Fcondition_case); | |
| 7291 DEFSUBR (Fcall_with_condition_handler); | |
| 7292 DEFSUBR (Fsignal); | |
| 7293 DEFSUBR (Finteractive_p); | |
| 7294 DEFSUBR (Fcommandp); | |
| 7295 DEFSUBR (Fcommand_execute); | |
| 7296 DEFSUBR (Fautoload); | |
| 7297 DEFSUBR (Feval); | |
| 7298 DEFSUBR (Fapply); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7299 DEFSUBR (Fmultiple_value_call); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7300 DEFSUBR (Fmultiple_value_list_internal); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7301 DEFSUBR (Fmultiple_value_prog1); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7302 DEFSUBR (Fvalues); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7303 DEFSUBR (Fvalues_list); |
| 428 | 7304 DEFSUBR (Ffuncall); |
| 7305 DEFSUBR (Ffunctionp); | |
| 7306 DEFSUBR (Ffunction_min_args); | |
| 7307 DEFSUBR (Ffunction_max_args); | |
| 7308 DEFSUBR (Frun_hooks); | |
| 7309 DEFSUBR (Frun_hook_with_args); | |
| 7310 DEFSUBR (Frun_hook_with_args_until_success); | |
| 7311 DEFSUBR (Frun_hook_with_args_until_failure); | |
| 7312 DEFSUBR (Fbacktrace_debug); | |
| 7313 DEFSUBR (Fbacktrace); | |
| 7314 DEFSUBR (Fbacktrace_frame); | |
| 7315 } | |
| 7316 | |
| 7317 void | |
| 814 | 7318 init_eval_semi_early (void) |
| 428 | 7319 { |
| 7320 specpdl_ptr = specpdl; | |
| 7321 specpdl_depth_counter = 0; | |
| 7322 catchlist = 0; | |
| 7323 Vcondition_handlers = Qnil; | |
| 7324 backtrace_list = 0; | |
| 7325 Vquit_flag = Qnil; | |
| 7326 debug_on_next_call = 0; | |
| 7327 lisp_eval_depth = 0; | |
| 7328 entering_debugger = 0; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7329 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7330 first_desired_multiple_value = 0; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7331 multiple_value_current_limit = 1; |
| 428 | 7332 } |
| 7333 | |
| 7334 void | |
| 7335 reinit_vars_of_eval (void) | |
| 7336 { | |
| 7337 preparing_for_armageddon = 0; | |
| 7338 in_warnings = 0; | |
| 7339 specpdl_size = 50; | |
| 7340 specpdl = xnew_array (struct specbinding, specpdl_size); | |
| 7341 /* XEmacs change: increase these values. */ | |
| 7342 max_specpdl_size = 3000; | |
| 442 | 7343 max_lisp_eval_depth = 1000; |
| 7344 #ifdef DEFEND_AGAINST_THROW_RECURSION | |
| 428 | 7345 throw_level = 0; |
| 7346 #endif | |
| 2367 | 7347 init_eval_semi_early (); |
| 428 | 7348 } |
| 7349 | |
| 7350 void | |
| 7351 vars_of_eval (void) | |
| 7352 { | |
| 7353 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size /* | |
| 7354 Limit on number of Lisp variable bindings & unwind-protects before error. | |
| 7355 */ ); | |
| 7356 | |
| 7357 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth /* | |
| 7358 Limit on depth in `eval', `apply' and `funcall' before error. | |
| 7359 This limit is to catch infinite recursions for you before they cause | |
| 7360 actual stack overflow in C, which would be fatal for Emacs. | |
| 7361 You can safely make it considerably larger than its default value, | |
| 7362 if that proves inconveniently small. | |
| 7363 */ ); | |
| 7364 | |
| 7365 DEFVAR_LISP ("quit-flag", &Vquit_flag /* | |
| 853 | 7366 t causes running Lisp code to abort, unless `inhibit-quit' is non-nil. |
| 7367 `critical' causes running Lisp code to abort regardless of `inhibit-quit'. | |
| 7368 Normally, you do not need to set this value yourself. It is set to | |
| 7369 t each time a Control-G is detected, and to `critical' each time a | |
| 7370 Shift-Control-G is detected. The XEmacs core C code is littered with | |
| 7371 calls to the QUIT; macro, which check the values of `quit-flag' and | |
| 2500 | 7372 `inhibit-quit' and ABORT (or more accurately, call (signal 'quit)) if |
| 853 | 7373 it's correct to do so. |
| 428 | 7374 */ ); |
| 7375 Vquit_flag = Qnil; | |
| 7376 | |
| 7377 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit /* | |
| 7378 Non-nil inhibits C-g quitting from happening immediately. | |
| 7379 Note that `quit-flag' will still be set by typing C-g, | |
| 7380 so a quit will be signalled as soon as `inhibit-quit' is nil. | |
| 7381 To prevent this happening, set `quit-flag' to nil | |
| 853 | 7382 before making `inhibit-quit' nil. |
| 7383 | |
| 7384 The value of `inhibit-quit' is ignored if a critical quit is | |
| 7385 requested by typing control-shift-G in a window-system frame; | |
| 7386 this is explained in more detail in `quit-flag'. | |
| 428 | 7387 */ ); |
| 7388 Vinhibit_quit = Qnil; | |
| 7389 | |
| 7390 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error /* | |
| 7391 *Non-nil means automatically display a backtrace buffer | |
| 7392 after any error that is not handled by a `condition-case'. | |
| 7393 If the value is a list, an error only means to display a backtrace | |
| 7394 if one of its condition symbols appears in the list. | |
| 7395 See also variable `stack-trace-on-signal'. | |
| 7396 */ ); | |
| 7397 Vstack_trace_on_error = Qnil; | |
| 7398 | |
| 7399 DEFVAR_LISP ("stack-trace-on-signal", &Vstack_trace_on_signal /* | |
| 7400 *Non-nil means automatically display a backtrace buffer | |
| 7401 after any error that is signalled, whether or not it is handled by | |
| 7402 a `condition-case'. | |
| 7403 If the value is a list, an error only means to display a backtrace | |
| 7404 if one of its condition symbols appears in the list. | |
| 7405 See also variable `stack-trace-on-error'. | |
| 7406 */ ); | |
| 7407 Vstack_trace_on_signal = Qnil; | |
| 7408 | |
| 7409 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors /* | |
| 7410 *List of errors for which the debugger should not be called. | |
| 7411 Each element may be a condition-name or a regexp that matches error messages. | |
| 7412 If any element applies to a given error, that error skips the debugger | |
| 7413 and just returns to top level. | |
| 7414 This overrides the variable `debug-on-error'. | |
| 7415 It does not apply to errors handled by `condition-case'. | |
| 7416 */ ); | |
| 7417 Vdebug_ignored_errors = Qnil; | |
| 7418 | |
| 7419 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error /* | |
| 7420 *Non-nil means enter debugger if an unhandled error is signalled. | |
| 7421 The debugger will not be entered if the error is handled by | |
| 7422 a `condition-case'. | |
| 7423 If the value is a list, an error only means to enter the debugger | |
| 7424 if one of its condition symbols appears in the list. | |
| 7425 This variable is overridden by `debug-ignored-errors'. | |
| 7426 See also variables `debug-on-quit' and `debug-on-signal'. | |
| 1123 | 7427 |
|
4657
f8d7d8202635
imported patch accept-process-output-docstring
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4642
diff
changeset
|
7428 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
|
7429 (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
|
7430 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
|
7431 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
|
7432 |
| 1123 | 7433 If this variable is set while XEmacs is running noninteractively (using |
| 7434 `-batch'), and XEmacs was configured with `--debug' (#define XEMACS_DEBUG | |
| 7435 in the C code), instead of trying to invoke the Lisp debugger (which | |
| 7436 obviously won't work), XEmacs will break out to a C debugger using | |
| 7437 \(force-debugging-signal t). This is useful because debugging | |
| 7438 noninteractive runs of XEmacs is often very difficult, since they typically | |
| 7439 happen as part of sometimes large and complex make suites (e.g. rebuilding | |
| 2500 | 7440 the XEmacs packages). NOTE: This runs ABORT()!!! (As well as and after |
| 1123 | 7441 executing INT 3 under MS Windows, which should invoke a debugger if it's |
| 7442 active.) This is guaranteed to kill XEmacs! (But in this situation, XEmacs | |
| 7443 is about to die anyway, and if no debugger is present, this will usefully | |
| 7444 dump core.) The most useful way to set this flag when debugging | |
| 7445 noninteractive runs, especially in makefiles, is using the environment | |
| 7446 variable XEMACSDEBUG, like this: | |
| 771 | 7447 |
| 7448 \(using csh) setenv XEMACSDEBUG '(setq debug-on-error t)' | |
| 7449 \(using bash) export XEMACSDEBUG='(setq debug-on-error t)' | |
| 428 | 7450 */ ); |
| 7451 Vdebug_on_error = Qnil; | |
| 7452 | |
| 7453 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal /* | |
| 7454 *Non-nil means enter debugger if an error is signalled. | |
| 7455 The debugger will be entered whether or not the error is handled by | |
| 7456 a `condition-case'. | |
| 7457 If the value is a list, an error only means to enter the debugger | |
| 7458 if one of its condition symbols appears in the list. | |
| 7459 See also variable `debug-on-quit'. | |
| 1123 | 7460 |
| 7461 This will attempt to enter a C debugger when XEmacs is run noninteractively | |
| 7462 and under the same conditions as described in `debug-on-error'. | |
| 428 | 7463 */ ); |
| 7464 Vdebug_on_signal = Qnil; | |
| 7465 | |
| 7466 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit /* | |
| 7467 *Non-nil means enter debugger if quit is signalled (C-G, for example). | |
| 7468 Does not apply if quit is handled by a `condition-case'. Entering the | |
| 7469 debugger can also be achieved at any time (for X11 console) by typing | |
| 7470 control-shift-G to signal a critical quit. | |
| 7471 */ ); | |
| 7472 debug_on_quit = 0; | |
| 7473 | |
| 7474 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call /* | |
| 7475 Non-nil means enter debugger before next `eval', `apply' or `funcall'. | |
| 7476 */ ); | |
| 7477 | |
| 1292 | 7478 DEFVAR_BOOL ("backtrace-with-interal-sections", |
| 7479 &backtrace_with_internal_sections /* | |
| 7480 Non-nil means backtraces will contain additional information indicating | |
| 7481 when particular sections of the C code have been entered, e.g. redisplay(), | |
| 7482 byte-char conversion, internal-external conversion, etc. This can be | |
| 7483 particularly useful when XEmacs crashes, in helping to pinpoint the problem. | |
| 7484 */ ); | |
| 7485 #ifdef ERROR_CHECK_STRUCTURES | |
| 7486 backtrace_with_internal_sections = 1; | |
| 7487 #else | |
| 7488 backtrace_with_internal_sections = 0; | |
| 7489 #endif | |
| 7490 | |
| 428 | 7491 DEFVAR_LISP ("debugger", &Vdebugger /* |
| 7492 Function to call to invoke debugger. | |
| 7493 If due to frame exit, args are `exit' and the value being returned; | |
| 7494 this function's value will be returned instead of that. | |
| 7495 If due to error, args are `error' and a list of the args to `signal'. | |
| 7496 If due to `apply' or `funcall' entry, one arg, `lambda'. | |
| 7497 If due to `eval' entry, one arg, t. | |
| 7498 */ ); | |
| 7499 Vdebugger = Qnil; | |
| 7500 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7501 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
|
7502 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
|
7503 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7504 This applies to `values', `values-list', `multiple-value-bind' and related |
|
4905
755ae5b97edb
Change "special form" to "special operator" in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
7505 macros and special operators. |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7506 */); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4657
diff
changeset
|
7507 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
|
7508 |
| 853 | 7509 staticpro (&Vcatch_everything_tag); |
| 7510 Vcatch_everything_tag = make_opaque (OPAQUE_CLEAR, 0); | |
| 7511 | |
| 428 | 7512 staticpro (&Vpending_warnings); |
| 7513 Vpending_warnings = Qnil; | |
| 1204 | 7514 dump_add_root_lisp_object (&Vpending_warnings_tail); |
| 428 | 7515 Vpending_warnings_tail = Qnil; |
| 7516 | |
| 793 | 7517 DEFVAR_LISP ("log-warning-minimum-level", &Vlog_warning_minimum_level); |
| 7518 Vlog_warning_minimum_level = Qinfo; | |
| 7519 | |
| 428 | 7520 staticpro (&Vautoload_queue); |
| 7521 Vautoload_queue = Qnil; | |
| 7522 | |
| 7523 staticpro (&Vcondition_handlers); | |
| 7524 | |
| 853 | 7525 staticpro (&Vdeletable_permanent_display_objects); |
| 7526 Vdeletable_permanent_display_objects = Qnil; | |
| 7527 | |
| 7528 staticpro (&Vmodifiable_buffers); | |
| 7529 Vmodifiable_buffers = Qnil; | |
| 7530 | |
| 7531 inhibit_flags = 0; | |
| 7532 } |