Mercurial > hg > xemacs-beta
annotate src/bytecode.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 | b5df3737028a |
| children | 7be849cb8828 |
| rev | line source |
|---|---|
| 428 | 1 /* Execution of byte code produced by bytecomp.el. |
| 2 Implementation of compiled-function objects. | |
| 3 Copyright (C) 1992, 1993 Free Software Foundation, Inc. | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
4 Copyright (C) 1995, 2002, 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: Mule 2.0, FSF 19.30. */ | |
| 24 | |
| 25 /* This file has been Mule-ized. */ | |
| 26 | |
| 27 | |
| 28 /* Authorship: | |
| 29 | |
| 30 FSF: long ago. | |
| 31 | |
| 32 hacked on by jwz@jwz.org 1991-06 | |
| 33 o added a compile-time switch to turn on simple sanity checking; | |
| 34 o put back the obsolete byte-codes for error-detection; | |
| 35 o added a new instruction, unbind_all, which I will use for | |
| 36 tail-recursion elimination; | |
| 37 o made temp_output_buffer_show be called with the right number | |
| 38 of args; | |
| 39 o made the new bytecodes be called with args in the right order; | |
| 40 o added metering support. | |
| 41 | |
| 42 by Hallvard: | |
| 43 o added relative jump instructions; | |
| 44 o all conditionals now only do QUIT if they jump. | |
| 45 | |
| 46 Ben Wing: some changes for Mule, 1995-06. | |
| 47 | |
| 48 Martin Buchholz: performance hacking, 1998-09. | |
| 49 See Internals Manual, Evaluation. | |
| 50 */ | |
| 51 | |
| 52 #include <config.h> | |
| 53 #include "lisp.h" | |
| 54 #include "backtrace.h" | |
| 55 #include "buffer.h" | |
| 56 #include "bytecode.h" | |
| 57 #include "opaque.h" | |
| 58 #include "syntax.h" | |
| 872 | 59 #include "window.h" |
| 428 | 60 |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
61 #define NUM_REMEMBERED_BYTE_OPS 100 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
62 |
| 3092 | 63 #ifdef NEW_GC |
| 64 static Lisp_Object | |
| 65 make_compiled_function_args (int totalargs) | |
| 66 { | |
| 67 Lisp_Compiled_Function_Args *args; | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
68 args = XCOMPILED_FUNCTION_ARGS |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
69 (ALLOC_SIZED_LISP_OBJECT |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
70 (FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Compiled_Function_Args, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
71 Lisp_Object, args, totalargs), |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
72 compiled_function_args)); |
| 3092 | 73 args->size = totalargs; |
| 74 return wrap_compiled_function_args (args); | |
| 75 } | |
| 76 | |
| 77 static Bytecount | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
78 size_compiled_function_args (Lisp_Object obj) |
| 3092 | 79 { |
| 80 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Compiled_Function_Args, | |
| 81 Lisp_Object, args, | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
82 XCOMPILED_FUNCTION_ARGS (obj)->size); |
| 3092 | 83 } |
| 84 | |
| 85 static const struct memory_description compiled_function_args_description[] = { | |
| 86 { XD_LONG, offsetof (Lisp_Compiled_Function_Args, size) }, | |
| 87 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Compiled_Function_Args, args), | |
| 88 XD_INDIRECT(0, 0) }, | |
| 89 { XD_END } | |
| 90 }; | |
| 91 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
92 DEFINE_DUMPABLE_SIZABLE_INTERNAL_LISP_OBJECT ("compiled-function-args", |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
93 compiled_function_args, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
94 0, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
95 compiled_function_args_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
96 size_compiled_function_args, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
97 Lisp_Compiled_Function_Args); |
| 3092 | 98 #endif /* NEW_GC */ |
| 99 | |
| 428 | 100 EXFUN (Ffetch_bytecode, 1); |
| 101 | |
| 102 Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code; | |
| 103 | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
104 |
| 428 | 105 enum Opcode /* Byte codes */ |
| 106 { | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
107 #define OPCODE(sym, val) B##sym = val, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
108 #include "bytecode-ops.h" |
| 428 | 109 }; |
| 110 typedef enum Opcode Opcode; | |
| 111 | |
| 112 Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr, | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
113 #ifdef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
114 Lisp_Object *stack_beg, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
115 Lisp_Object *stack_end, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
116 #endif /* ERROR_CHECK_BYTE_CODE */ |
| 442 | 117 const Opbyte *program_ptr, |
| 428 | 118 Opcode opcode); |
| 119 | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
120 #ifndef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
121 |
|
4974
fe0d3106cc36
fix compile problems in bytecode.c when no error-check-byte-code (issue 666)
Ben Wing <ben@xemacs.org>
parents:
4970
diff
changeset
|
122 /* Normally we would use `x' instead of `0' in the argument list, to avoid |
|
fe0d3106cc36
fix compile problems in bytecode.c when no error-check-byte-code (issue 666)
Ben Wing <ben@xemacs.org>
parents:
4970
diff
changeset
|
123 problems if `x' (an expression) has side effects, and warnings if `x' |
|
fe0d3106cc36
fix compile problems in bytecode.c when no error-check-byte-code (issue 666)
Ben Wing <ben@xemacs.org>
parents:
4970
diff
changeset
|
124 contains variables or parameters that are otherwise unused. But in |
|
fe0d3106cc36
fix compile problems in bytecode.c when no error-check-byte-code (issue 666)
Ben Wing <ben@xemacs.org>
parents:
4970
diff
changeset
|
125 this case `x' contains references to vars and params that exist only |
|
fe0d3106cc36
fix compile problems in bytecode.c when no error-check-byte-code (issue 666)
Ben Wing <ben@xemacs.org>
parents:
4970
diff
changeset
|
126 when ERROR_CHECK_BYTE_CODE, and leaving in `x' would result in compile |
|
fe0d3106cc36
fix compile problems in bytecode.c when no error-check-byte-code (issue 666)
Ben Wing <ben@xemacs.org>
parents:
4970
diff
changeset
|
127 errors. */ |
|
fe0d3106cc36
fix compile problems in bytecode.c when no error-check-byte-code (issue 666)
Ben Wing <ben@xemacs.org>
parents:
4970
diff
changeset
|
128 # define bytecode_assert(x) disabled_assert (0) |
|
fe0d3106cc36
fix compile problems in bytecode.c when no error-check-byte-code (issue 666)
Ben Wing <ben@xemacs.org>
parents:
4970
diff
changeset
|
129 # define bytecode_assert_with_message(x, msg) disabled_assert(0) |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
130 # define bytecode_abort_with_message(msg) abort_with_message (msg) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
131 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
132 #else /* ERROR_CHECK_BYTE_CODE */ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
133 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
134 # define bytecode_assert(x) \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
135 ((x) ? (void) 0 : assert_failed_with_remembered_ops (__FILE__, __LINE__, #x)) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
136 # define bytecode_assert_with_message(x, msg) \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
137 ((x) ? (void) 0 : assert_failed_with_remembered_ops (__FILE__, __LINE__, msg)) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
138 # define bytecode_abort_with_message(msg) \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
139 assert_failed_with_remembered_ops (__FILE__, __LINE__, msg) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
140 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
141 /* Table mapping opcodes to their names. This handles opcodes like |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
142 Bvarref+7, but it doesn't list any of the Bconstant+N opcodes; those |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
143 are handled specially. */ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
144 Ascbyte *opcode_name_table[256]; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
145 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
146 /* Circular queue remembering the most recent operations. */ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
147 Opcode remembered_ops[NUM_REMEMBERED_BYTE_OPS]; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
148 int remembered_op_next_pos, num_remembered; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
149 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
150 static void |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
151 remember_operation (Opcode op) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
152 { |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
153 remembered_ops[remembered_op_next_pos] = op; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
154 remembered_op_next_pos = |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
155 (remembered_op_next_pos + 1) % NUM_REMEMBERED_BYTE_OPS; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
156 if (num_remembered < NUM_REMEMBERED_BYTE_OPS) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
157 num_remembered++; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
158 } |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
159 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
160 static void |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
161 assert_failed_with_remembered_ops (const Ascbyte *file, int line, |
| 4970 | 162 const Ascbyte *msg_to_abort_with) |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
163 { |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
164 Ascbyte *msg = |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
165 alloca_array (Ascbyte, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
166 NUM_REMEMBERED_BYTE_OPS*50 + strlen (msg_to_abort_with)); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
167 int i; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
168 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
169 if (msg_to_abort_with) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
170 strcpy (msg, msg_to_abort_with); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
171 strcat (msg, "\n\nRecent bytecodes, oldest first:\n\n"); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
172 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
173 for (i = 0; i < num_remembered; i++) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
174 { |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
175 Ascbyte msg2[50]; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
176 int pos; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
177 Opcode op; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
178 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
179 sprintf (msg2, "%5d: ", i - num_remembered + 1); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
180 strcat (msg, msg2); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
181 pos = (remembered_op_next_pos + NUM_REMEMBERED_BYTE_OPS + |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
182 i - num_remembered) % NUM_REMEMBERED_BYTE_OPS; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
183 op = remembered_ops[pos]; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
184 if (op >= Bconstant) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
185 { |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
186 sprintf (msg2, "constant+%d", op - Bconstant); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
187 strcat (msg, msg2); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
188 } |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
189 else |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
190 { |
| 4970 | 191 const Ascbyte *opname = opcode_name_table[op]; |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
192 if (!opname) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
193 { |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
194 stderr_out ("Internal error! NULL pointer in opcode_name_table, opcode %d\n", op); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
195 strcat (msg, "NULL"); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
196 } |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
197 else |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
198 strcat (msg, opname); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
199 } |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
200 sprintf (msg2, " (%d)\n", op); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
201 strcat (msg, msg2); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
202 } |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
203 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
204 assert_failed (file, line, msg); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
205 } |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
206 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
207 #endif /* ERROR_CHECK_BYTE_CODE */ |
| 428 | 208 |
| 209 | |
| 210 #ifdef BYTE_CODE_METER | |
| 211 | |
| 212 Lisp_Object Vbyte_code_meter, Qbyte_code_meter; | |
| 213 int byte_metering_on; | |
| 214 | |
| 215 static void | |
| 216 meter_code (Opcode prev_opcode, Opcode this_opcode) | |
| 217 { | |
| 218 if (byte_metering_on) | |
| 219 { | |
| 220 Lisp_Object *p = XVECTOR_DATA (XVECTOR_DATA (Vbyte_code_meter)[this_opcode]); | |
| 221 p[0] = INT_PLUS1 (p[0]); | |
| 222 if (prev_opcode) | |
| 223 p[prev_opcode] = INT_PLUS1 (p[prev_opcode]); | |
| 224 } | |
| 225 } | |
| 226 | |
| 227 #endif /* BYTE_CODE_METER */ | |
| 228 | |
| 229 | |
| 230 static Lisp_Object | |
| 231 bytecode_negate (Lisp_Object obj) | |
| 232 { | |
| 233 retry: | |
| 234 | |
| 1983 | 235 if (INTP (obj)) return make_integer (- XINT (obj)); |
| 428 | 236 if (FLOATP (obj)) return make_float (- XFLOAT_DATA (obj)); |
| 1983 | 237 if (CHARP (obj)) return make_integer (- ((int) XCHAR (obj))); |
| 238 if (MARKERP (obj)) return make_integer (- ((int) marker_position (obj))); | |
| 239 #ifdef HAVE_BIGNUM | |
| 240 if (BIGNUMP (obj)) BIGNUM_ARITH_RETURN (obj, neg); | |
| 241 #endif | |
| 242 #ifdef HAVE_RATIO | |
| 243 if (RATIOP (obj)) RATIO_ARITH_RETURN (obj, neg); | |
| 244 #endif | |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
245 #ifdef HAVE_BIGFLOAT |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
246 if (BIGFLOATP (obj)) BIGFLOAT_ARITH_RETURN (obj, neg); |
| 1983 | 247 #endif |
| 428 | 248 |
| 249 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj); | |
| 250 goto retry; | |
| 251 } | |
| 252 | |
| 253 static Lisp_Object | |
| 254 bytecode_nreverse (Lisp_Object list) | |
| 255 { | |
| 256 REGISTER Lisp_Object prev = Qnil; | |
| 257 REGISTER Lisp_Object tail = list; | |
| 258 | |
| 259 while (!NILP (tail)) | |
| 260 { | |
| 261 REGISTER Lisp_Object next; | |
| 262 CHECK_CONS (tail); | |
| 263 next = XCDR (tail); | |
| 264 XCDR (tail) = prev; | |
| 265 prev = tail; | |
| 266 tail = next; | |
| 267 } | |
| 268 return prev; | |
| 269 } | |
| 270 | |
| 271 | |
| 272 /* We have our own two-argument versions of various arithmetic ops. | |
| 273 Only two-argument arithmetic operations have their own byte codes. */ | |
|
4910
6bc1f3f6cf0d
Make canoncase visible to Lisp; use it with chars in internal_equalp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4906
diff
changeset
|
274 int |
| 428 | 275 bytecode_arithcompare (Lisp_Object obj1, Lisp_Object obj2) |
| 276 { | |
| 1983 | 277 #ifdef WITH_NUMBER_TYPES |
| 278 switch (promote_args (&obj1, &obj2)) | |
| 279 { | |
| 280 case FIXNUM_T: | |
| 281 { | |
| 282 EMACS_INT ival1 = XREALINT (obj1), ival2 = XREALINT (obj2); | |
| 283 return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0; | |
| 284 } | |
| 285 #ifdef HAVE_BIGNUM | |
| 286 case BIGNUM_T: | |
| 287 return bignum_cmp (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2)); | |
| 288 #endif | |
| 289 #ifdef HAVE_RATIO | |
| 290 case RATIO_T: | |
| 291 return ratio_cmp (XRATIO_DATA (obj1), XRATIO_DATA (obj2)); | |
| 292 #endif | |
| 1995 | 293 #ifdef HAVE_BIGFLOAT |
| 294 case BIGFLOAT_T: | |
| 295 return bigfloat_cmp (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2)); | |
| 296 #endif | |
| 297 default: /* FLOAT_T */ | |
| 1983 | 298 { |
| 299 double dval1 = XFLOAT_DATA (obj1), dval2 = XFLOAT_DATA (obj2); | |
| 300 return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0; | |
| 301 } | |
| 302 } | |
| 303 #else /* !WITH_NUMBER_TYPES */ | |
| 428 | 304 retry: |
| 305 | |
| 306 { | |
| 307 EMACS_INT ival1, ival2; | |
| 308 | |
| 309 if (INTP (obj1)) ival1 = XINT (obj1); | |
| 310 else if (CHARP (obj1)) ival1 = XCHAR (obj1); | |
| 311 else if (MARKERP (obj1)) ival1 = marker_position (obj1); | |
| 312 else goto arithcompare_float; | |
| 313 | |
| 314 if (INTP (obj2)) ival2 = XINT (obj2); | |
| 315 else if (CHARP (obj2)) ival2 = XCHAR (obj2); | |
| 316 else if (MARKERP (obj2)) ival2 = marker_position (obj2); | |
| 317 else goto arithcompare_float; | |
| 318 | |
| 319 return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0; | |
| 320 } | |
| 321 | |
| 322 arithcompare_float: | |
| 323 | |
| 324 { | |
| 325 double dval1, dval2; | |
| 326 | |
| 327 if (FLOATP (obj1)) dval1 = XFLOAT_DATA (obj1); | |
| 328 else if (INTP (obj1)) dval1 = (double) XINT (obj1); | |
| 329 else if (CHARP (obj1)) dval1 = (double) XCHAR (obj1); | |
| 330 else if (MARKERP (obj1)) dval1 = (double) marker_position (obj1); | |
| 331 else | |
| 332 { | |
| 333 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1); | |
| 334 goto retry; | |
| 335 } | |
| 336 | |
| 337 if (FLOATP (obj2)) dval2 = XFLOAT_DATA (obj2); | |
| 338 else if (INTP (obj2)) dval2 = (double) XINT (obj2); | |
| 339 else if (CHARP (obj2)) dval2 = (double) XCHAR (obj2); | |
| 340 else if (MARKERP (obj2)) dval2 = (double) marker_position (obj2); | |
| 341 else | |
| 342 { | |
| 343 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2); | |
| 344 goto retry; | |
| 345 } | |
| 346 | |
| 347 return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0; | |
| 348 } | |
| 1983 | 349 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 350 } |
| 351 | |
| 352 static Lisp_Object | |
| 353 bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode) | |
| 354 { | |
| 1983 | 355 #ifdef WITH_NUMBER_TYPES |
| 356 switch (promote_args (&obj1, &obj2)) | |
| 357 { | |
| 358 case FIXNUM_T: | |
| 359 { | |
| 360 EMACS_INT ival1 = XREALINT (obj1), ival2 = XREALINT (obj2); | |
| 361 switch (opcode) | |
| 362 { | |
| 363 case Bplus: ival1 += ival2; break; | |
| 364 case Bdiff: ival1 -= ival2; break; | |
| 365 case Bmult: | |
| 366 #ifdef HAVE_BIGNUM | |
| 367 /* Due to potential overflow, we compute using bignums */ | |
| 368 bignum_set_long (scratch_bignum, ival1); | |
| 369 bignum_set_long (scratch_bignum2, ival2); | |
| 370 bignum_mul (scratch_bignum, scratch_bignum, scratch_bignum2); | |
| 371 return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); | |
| 372 #else | |
| 373 ival1 *= ival2; break; | |
| 374 #endif | |
| 375 case Bquo: | |
|
4717
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
376 if (ival2 == 0) |
|
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
377 signal_error_2 (Qarith_error, "division by zero", obj1, obj2); |
| 1983 | 378 ival1 /= ival2; |
| 379 break; | |
| 380 case Bmax: if (ival1 < ival2) ival1 = ival2; break; | |
| 381 case Bmin: if (ival1 > ival2) ival1 = ival2; break; | |
| 382 } | |
| 383 return make_integer (ival1); | |
| 384 } | |
| 385 #ifdef HAVE_BIGNUM | |
| 386 case BIGNUM_T: | |
| 387 switch (opcode) | |
| 388 { | |
| 389 case Bplus: | |
| 390 bignum_add (scratch_bignum, XBIGNUM_DATA (obj1), | |
| 391 XBIGNUM_DATA (obj2)); | |
| 392 break; | |
| 393 case Bdiff: | |
| 394 bignum_sub (scratch_bignum, XBIGNUM_DATA (obj1), | |
| 395 XBIGNUM_DATA (obj2)); | |
| 396 break; | |
| 397 case Bmult: | |
| 398 bignum_mul (scratch_bignum, XBIGNUM_DATA (obj1), | |
| 399 XBIGNUM_DATA (obj2)); | |
| 400 break; | |
| 401 case Bquo: | |
| 402 if (bignum_sign (XBIGNUM_DATA (obj2)) == 0) | |
|
4717
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
403 signal_error_2 (Qarith_error, "division by zero", obj1, obj2); |
| 1983 | 404 bignum_div (scratch_bignum, XBIGNUM_DATA (obj1), |
| 405 XBIGNUM_DATA (obj2)); | |
| 406 break; | |
| 407 case Bmax: | |
| 408 return bignum_gt (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2)) | |
| 409 ? obj1 : obj2; | |
| 410 case Bmin: | |
| 411 return bignum_lt (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2)) | |
| 412 ? obj1 : obj2; | |
| 413 } | |
| 414 return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); | |
| 415 #endif | |
| 416 #ifdef HAVE_RATIO | |
| 417 case RATIO_T: | |
| 418 switch (opcode) | |
| 419 { | |
| 420 case Bplus: | |
| 421 ratio_add (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2)); | |
| 422 break; | |
| 423 case Bdiff: | |
| 424 ratio_sub (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2)); | |
| 425 break; | |
| 426 case Bmult: | |
| 427 ratio_mul (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2)); | |
| 428 break; | |
| 429 case Bquo: | |
| 430 if (ratio_sign (XRATIO_DATA (obj2)) == 0) | |
|
4717
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
431 signal_error_2 (Qarith_error, "division by zero", obj1, obj2); |
| 1983 | 432 ratio_div (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2)); |
| 433 break; | |
| 434 case Bmax: | |
| 435 return ratio_gt (XRATIO_DATA (obj1), XRATIO_DATA (obj2)) | |
| 436 ? obj1 : obj2; | |
| 437 case Bmin: | |
| 438 return ratio_lt (XRATIO_DATA (obj1), XRATIO_DATA (obj2)) | |
| 439 ? obj1 : obj2; | |
| 440 } | |
| 441 return make_ratio_rt (scratch_ratio); | |
| 442 #endif | |
| 443 #ifdef HAVE_BIGFLOAT | |
| 444 case BIGFLOAT_T: | |
| 445 bigfloat_set_prec (scratch_bigfloat, max (XBIGFLOAT_GET_PREC (obj1), | |
| 446 XBIGFLOAT_GET_PREC (obj2))); | |
| 447 switch (opcode) | |
| 448 { | |
| 449 case Bplus: | |
| 450 bigfloat_add (scratch_bigfloat, XBIGFLOAT_DATA (obj1), | |
| 451 XBIGFLOAT_DATA (obj2)); | |
| 452 break; | |
| 453 case Bdiff: | |
| 454 bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (obj1), | |
| 455 XBIGFLOAT_DATA (obj2)); | |
| 456 break; | |
| 457 case Bmult: | |
| 458 bigfloat_mul (scratch_bigfloat, XBIGFLOAT_DATA (obj1), | |
| 459 XBIGFLOAT_DATA (obj2)); | |
| 460 break; | |
| 461 case Bquo: | |
| 462 if (bigfloat_sign (XBIGFLOAT_DATA (obj2)) == 0) | |
|
4717
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
463 signal_error_2 (Qarith_error, "division by zero", obj1, obj2); |
| 1983 | 464 bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (obj1), |
| 465 XBIGFLOAT_DATA (obj2)); | |
| 466 break; | |
| 467 case Bmax: | |
| 468 return bigfloat_gt (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2)) | |
| 469 ? obj1 : obj2; | |
| 470 case Bmin: | |
| 471 return bigfloat_lt (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2)) | |
| 472 ? obj1 : obj2; | |
| 473 } | |
| 474 return make_bigfloat_bf (scratch_bigfloat); | |
| 475 #endif | |
| 1995 | 476 default: /* FLOAT_T */ |
| 477 { | |
| 478 double dval1 = XFLOAT_DATA (obj1), dval2 = XFLOAT_DATA (obj2); | |
| 479 switch (opcode) | |
| 480 { | |
| 481 case Bplus: dval1 += dval2; break; | |
| 482 case Bdiff: dval1 -= dval2; break; | |
| 483 case Bmult: dval1 *= dval2; break; | |
| 484 case Bquo: | |
|
4717
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
485 if (dval2 == 0.0) |
|
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
486 signal_error_2 (Qarith_error, "division by zero", obj1, obj2); |
| 1995 | 487 dval1 /= dval2; |
| 488 break; | |
| 489 case Bmax: if (dval1 < dval2) dval1 = dval2; break; | |
| 490 case Bmin: if (dval1 > dval2) dval1 = dval2; break; | |
| 491 } | |
| 492 return make_float (dval1); | |
| 493 } | |
| 1983 | 494 } |
| 495 #else /* !WITH_NUMBER_TYPES */ | |
| 428 | 496 EMACS_INT ival1, ival2; |
| 497 int float_p; | |
| 498 | |
| 499 retry: | |
| 500 | |
| 501 float_p = 0; | |
| 502 | |
| 503 if (INTP (obj1)) ival1 = XINT (obj1); | |
| 504 else if (CHARP (obj1)) ival1 = XCHAR (obj1); | |
| 505 else if (MARKERP (obj1)) ival1 = marker_position (obj1); | |
| 506 else if (FLOATP (obj1)) ival1 = 0, float_p = 1; | |
| 507 else | |
| 508 { | |
| 509 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1); | |
| 510 goto retry; | |
| 511 } | |
| 512 | |
| 513 if (INTP (obj2)) ival2 = XINT (obj2); | |
| 514 else if (CHARP (obj2)) ival2 = XCHAR (obj2); | |
| 515 else if (MARKERP (obj2)) ival2 = marker_position (obj2); | |
| 516 else if (FLOATP (obj2)) ival2 = 0, float_p = 1; | |
| 517 else | |
| 518 { | |
| 519 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2); | |
| 520 goto retry; | |
| 521 } | |
| 522 | |
| 523 if (!float_p) | |
| 524 { | |
| 525 switch (opcode) | |
| 526 { | |
| 527 case Bplus: ival1 += ival2; break; | |
| 528 case Bdiff: ival1 -= ival2; break; | |
| 529 case Bmult: ival1 *= ival2; break; | |
| 530 case Bquo: | |
|
4717
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
531 if (ival2 == 0) |
|
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
532 signal_error_2 (Qarith_error, "division by zero", obj1, obj2); |
| 428 | 533 ival1 /= ival2; |
| 534 break; | |
| 535 case Bmax: if (ival1 < ival2) ival1 = ival2; break; | |
| 536 case Bmin: if (ival1 > ival2) ival1 = ival2; break; | |
| 537 } | |
| 538 return make_int (ival1); | |
| 539 } | |
| 540 else | |
| 541 { | |
| 542 double dval1 = FLOATP (obj1) ? XFLOAT_DATA (obj1) : (double) ival1; | |
| 543 double dval2 = FLOATP (obj2) ? XFLOAT_DATA (obj2) : (double) ival2; | |
| 544 switch (opcode) | |
| 545 { | |
| 546 case Bplus: dval1 += dval2; break; | |
| 547 case Bdiff: dval1 -= dval2; break; | |
| 548 case Bmult: dval1 *= dval2; break; | |
| 549 case Bquo: | |
|
4717
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
550 if (dval2 == 0) |
|
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
551 signal_error_2 (Qarith_error, "division by zero", obj1, obj2); |
| 428 | 552 dval1 /= dval2; |
| 553 break; | |
| 554 case Bmax: if (dval1 < dval2) dval1 = dval2; break; | |
| 555 case Bmin: if (dval1 > dval2) dval1 = dval2; break; | |
| 556 } | |
| 557 return make_float (dval1); | |
| 558 } | |
| 1983 | 559 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 560 } |
| 561 | |
| 562 | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
563 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
564 /*********************** The instruction array *********************/ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
565 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
566 /* Check that there are at least LEN elements left in the end of the |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
567 instruction array before fetching them. Note that we allow for |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
568 PROGRAM_PTR == PROGRAM_END after the fetch -- that means there are |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
569 no more elements to fetch next time around, but we might exit before |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
570 next time comes. |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
571 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
572 When checking the destination if jumps, however, we don't allow |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
573 PROGRAM_PTR to equal PROGRAM_END, since we will always be fetching |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
574 another instruction after the jump. */ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
575 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
576 #define CHECK_OPCODE_SPACE(len) \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
577 bytecode_assert (program_ptr + len <= program_end) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
578 |
| 428 | 579 /* Read next uint8 from the instruction stream. */ |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
580 #define READ_UINT_1 \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
581 (CHECK_OPCODE_SPACE (1), (unsigned int) (unsigned char) *program_ptr++) |
| 428 | 582 |
| 583 /* Read next uint16 from the instruction stream. */ | |
| 584 #define READ_UINT_2 \ | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
585 (CHECK_OPCODE_SPACE (2), \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
586 program_ptr += 2, \ |
| 428 | 587 (((unsigned int) (unsigned char) program_ptr[-1]) * 256 + \ |
| 588 ((unsigned int) (unsigned char) program_ptr[-2]))) | |
| 589 | |
| 590 /* Read next int8 from the instruction stream. */ | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
591 #define READ_INT_1 \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
592 (CHECK_OPCODE_SPACE (1), (int) (signed char) *program_ptr++) |
| 428 | 593 |
| 594 /* Read next int16 from the instruction stream. */ | |
| 595 #define READ_INT_2 \ | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
596 (CHECK_OPCODE_SPACE (2), \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
597 program_ptr += 2, \ |
| 428 | 598 (((int) ( signed char) program_ptr[-1]) * 256 + \ |
| 599 ((int) (unsigned char) program_ptr[-2]))) | |
| 600 | |
| 601 /* Read next int8 from instruction stream; don't advance program_pointer */ | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
602 #define PEEK_INT_1 \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
603 (CHECK_OPCODE_SPACE (1), (int) (signed char) program_ptr[0]) |
| 428 | 604 |
| 605 /* Read next int16 from instruction stream; don't advance program_pointer */ | |
| 606 #define PEEK_INT_2 \ | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
607 (CHECK_OPCODE_SPACE (2), \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
608 (((int) ( signed char) program_ptr[1]) * 256) | \ |
| 428 | 609 ((int) (unsigned char) program_ptr[0])) |
| 610 | |
| 611 /* Do relative jumps from the current location. | |
| 612 We only do a QUIT if we jump backwards, for efficiency. | |
| 613 No infloops without backward jumps! */ | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
614 #define JUMP_RELATIVE(jump) do { \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
615 int _JR_jump = (jump); \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
616 if (_JR_jump < 0) QUIT; \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
617 /* Check that where we're going to is in range. Note that we don't use \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
618 CHECK_OPCODE_SPACE() -- that only checks the end, and it allows \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
619 program_ptr == program_end, which we don't allow. */ \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
620 bytecode_assert (program_ptr + _JR_jump >= program && \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
621 program_ptr + _JR_jump < program_end); \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
622 program_ptr += _JR_jump; \ |
| 428 | 623 } while (0) |
| 624 | |
| 625 #define JUMP JUMP_RELATIVE (PEEK_INT_2) | |
| 626 #define JUMPR JUMP_RELATIVE (PEEK_INT_1) | |
| 627 | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
628 #define JUMP_NEXT (CHECK_OPCODE_SPACE (2), (void) (program_ptr += 2)) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
629 #define JUMPR_NEXT (CHECK_OPCODE_SPACE (1), (void) (program_ptr += 1)) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
630 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
631 /*********************** The stack array *********************/ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
632 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
633 /* NOTE: The stack array doesn't work quite like you'd expect. |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
634 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
635 STACK_PTR points to the value on the top of the stack. Popping a value |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
636 fetches the value from the STACK_PTR and then decrements it. Pushing a |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
637 value first increments it, then writes the new value. STACK_PTR - |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
638 STACK_BEG is the number of elements on the stack. |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
639 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
640 This means that when STACK_PTR == STACK_BEG, the stack is empty, and |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
641 the space at STACK_BEG is never written to -- the first push will write |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
642 into the space directly after STACK_BEG. This is why the call to |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
643 alloca_array() below has a count of `stack_depth + 1', and why |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
644 we GCPRO1 (stack_ptr[1]) -- the value at stack_ptr[0] is unused and |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
645 uninitialized. |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
646 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
647 Also, STACK_END actually points to the last usable storage location, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
648 and does not point past the end, like you'd expect. */ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
649 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
650 #define CHECK_STACKPTR_OFFSET(len) \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
651 bytecode_assert (stack_ptr + (len) >= stack_beg && \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
652 stack_ptr + (len) <= stack_end) |
| 428 | 653 |
| 654 /* Push x onto the execution stack. */ | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
655 #define PUSH(x) (CHECK_STACKPTR_OFFSET (1), *++stack_ptr = (x)) |
| 428 | 656 |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
657 /* Pop a value, which may be multiple, off the execution stack. */ |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
658 #define POP_WITH_MULTIPLE_VALUES (CHECK_STACKPTR_OFFSET (-1), *stack_ptr--) |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
659 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
660 /* Pop a value off the execution stack, treating multiple values as single. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
661 #define POP (IGNORE_MULTIPLE_VALUES (POP_WITH_MULTIPLE_VALUES)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
662 |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
663 /* ..._UNSAFE() means it evaluates its argument more than once. */ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
664 #define DISCARD_PRESERVING_MULTIPLE_VALUES_UNSAFE(n) \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
665 (CHECK_STACKPTR_OFFSET (-(n)), stack_ptr -= (n)) |
| 428 | 666 |
| 667 /* Discard n values from the execution stack. */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
668 #define DISCARD(n) do { \ |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
669 int _discard_n = (n); \ |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
670 if (1 != multiple_value_current_limit) \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
671 { \ |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
672 int i; \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
673 for (i = 0; i < _discard_n; i++) \ |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
674 { \ |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
675 CHECK_STACKPTR_OFFSET (-1); \ |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
676 *stack_ptr = ignore_multiple_values (*stack_ptr); \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
677 stack_ptr--; \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
678 } \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
679 } \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
680 else \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
681 { \ |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
682 CHECK_STACKPTR_OFFSET (-_discard_n); \ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
683 stack_ptr -= _discard_n; \ |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
684 } \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
685 } while (0) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
686 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
687 /* Get the value, which may be multiple, at the top of the execution stack; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
688 and leave it there. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
689 #define TOP_WITH_MULTIPLE_VALUES (*stack_ptr) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
690 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
691 #define TOP_ADDRESS (stack_ptr) |
| 428 | 692 |
| 693 /* Get the value which is at the top of the execution stack, | |
| 694 but don't pop it. */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
695 #define TOP (IGNORE_MULTIPLE_VALUES (TOP_WITH_MULTIPLE_VALUES)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
696 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
697 #define TOP_LVALUE (*stack_ptr) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
698 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
699 |
| 428 | 700 |
| 1920 | 701 /* See comment before the big switch in execute_optimized_program(). */ |
| 1884 | 702 #define GCPRO_STACK (gcpro1.nvars = stack_ptr - stack_beg) |
| 703 | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
704 |
| 428 | 705 /* The actual interpreter for byte code. |
| 706 This function has been seriously optimized for performance. | |
| 707 Don't change the constructs unless you are willing to do | |
| 708 real benchmarking and profiling work -- martin */ | |
| 709 | |
| 710 | |
| 814 | 711 Lisp_Object |
| 442 | 712 execute_optimized_program (const Opbyte *program, |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
713 #ifdef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
714 Elemcount program_length, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
715 #endif |
| 428 | 716 int stack_depth, |
| 717 Lisp_Object *constants_data) | |
| 718 { | |
| 719 /* This function can GC */ | |
| 442 | 720 REGISTER const Opbyte *program_ptr = (Opbyte *) program; |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
721 #ifdef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
722 const Opbyte *program_end = program_ptr + program_length; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
723 #endif |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
724 /* See comment above explaining the `+ 1' */ |
| 1884 | 725 Lisp_Object *stack_beg = alloca_array (Lisp_Object, stack_depth + 1); |
| 726 REGISTER Lisp_Object *stack_ptr = stack_beg; | |
| 428 | 727 int speccount = specpdl_depth (); |
| 728 struct gcpro gcpro1; | |
| 729 | |
| 730 #ifdef BYTE_CODE_METER | |
| 4925 | 731 Opcode this_opcode = (Opcode) 0; |
| 428 | 732 Opcode prev_opcode; |
| 733 #endif | |
| 734 | |
| 735 #ifdef ERROR_CHECK_BYTE_CODE | |
| 736 Lisp_Object *stack_end = stack_beg + stack_depth; | |
| 737 #endif | |
| 738 | |
| 1920 | 739 /* We used to GCPRO the whole interpreter stack before entering this while |
| 740 loop (21.5.14 and before), but that interferes with collection of weakly | |
| 741 referenced objects. Although strictly speaking there's no promise that | |
| 742 weak references will disappear by any given point in time, they should | |
| 743 be collected at the first opportunity. Waiting until exit from the | |
| 744 function caused test failures because "stale" objects "above" the top of | |
| 745 the stack were still GCPROed, and they were not getting collected until | |
| 746 after exit from the (byte-compiled) test! | |
| 747 | |
| 748 Now the idea is to dynamically adjust the array of GCPROed objects to | |
| 749 include only the "active" region of the stack. | |
| 750 | |
| 751 We use the "GCPRO1 the array base and set the nvars member" method. It | |
| 752 would be slightly inefficient but correct to use GCPRO1_ARRAY here. It | |
| 753 would just redundantly set nvars. | |
| 754 #### Maybe it would be clearer to use GCPRO1_ARRAY and do GCPRO_STACK | |
| 755 after the switch? | |
| 756 | |
| 757 GCPRO_STACK is something of a misnomer, because it suggests that a | |
| 758 struct gcpro is initialized each time. This is false; only the nvars | |
| 759 member of a single struct gcpro is being adjusted. This works because | |
| 760 each time a new object is assigned to a stack location, the old object | |
| 761 loses its reference and is effectively UNGCPROed, and the new object is | |
| 762 automatically GCPROed as long as nvars is correct. Only when we | |
| 763 return from the interpreter do we need to finalize the struct gcpro | |
| 764 itself, and that's done at case Breturn. | |
| 765 */ | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
766 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
767 /* See comment above explaining the `[1]' */ |
| 428 | 768 GCPRO1 (stack_ptr[1]); |
| 1758 | 769 |
| 428 | 770 while (1) |
| 771 { | |
| 772 REGISTER Opcode opcode = (Opcode) READ_UINT_1; | |
| 1920 | 773 |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
774 #ifdef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
775 remember_operation (opcode); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
776 #endif |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
777 |
| 1920 | 778 GCPRO_STACK; /* Get nvars right before maybe signaling. */ |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
779 /* #### NOTE: This code should probably never get triggered, since we |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
780 now catch the problems earlier, farther down, before we ever set |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
781 a bad value for STACK_PTR. */ |
| 428 | 782 #ifdef ERROR_CHECK_BYTE_CODE |
| 783 if (stack_ptr > stack_end) | |
| 563 | 784 stack_overflow ("byte code stack overflow", Qunbound); |
| 428 | 785 if (stack_ptr < stack_beg) |
| 563 | 786 stack_overflow ("byte code stack underflow", Qunbound); |
| 428 | 787 #endif |
| 788 | |
| 789 #ifdef BYTE_CODE_METER | |
| 790 prev_opcode = this_opcode; | |
| 791 this_opcode = opcode; | |
| 792 meter_code (prev_opcode, this_opcode); | |
| 793 #endif | |
| 794 | |
| 795 switch (opcode) | |
| 796 { | |
| 797 REGISTER int n; | |
| 798 | |
| 799 default: | |
| 800 if (opcode >= Bconstant) | |
| 801 PUSH (constants_data[opcode - Bconstant]); | |
| 802 else | |
| 1884 | 803 { |
| 804 /* We're not sure what these do, so better safe than sorry. */ | |
| 805 /* GCPRO_STACK; */ | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
806 stack_ptr = execute_rare_opcode (stack_ptr, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
807 #ifdef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
808 stack_beg, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
809 stack_end, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
810 #endif /* ERROR_CHECK_BYTE_CODE */ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
811 program_ptr, opcode); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
812 CHECK_STACKPTR_OFFSET (0); |
| 1884 | 813 } |
| 428 | 814 break; |
| 815 | |
| 816 case Bvarref: | |
| 817 case Bvarref+1: | |
| 818 case Bvarref+2: | |
| 819 case Bvarref+3: | |
| 820 case Bvarref+4: | |
| 821 case Bvarref+5: n = opcode - Bvarref; goto do_varref; | |
| 822 case Bvarref+7: n = READ_UINT_2; goto do_varref; | |
| 823 case Bvarref+6: n = READ_UINT_1; /* most common */ | |
| 824 do_varref: | |
| 825 { | |
| 826 Lisp_Object symbol = constants_data[n]; | |
| 827 Lisp_Object value = XSYMBOL (symbol)->value; | |
| 828 if (SYMBOL_VALUE_MAGIC_P (value)) | |
| 1920 | 829 /* I GCPRO_STACKed Fsymbol_value elsewhere, but I dunno why. */ |
| 830 /* GCPRO_STACK; */ | |
| 428 | 831 value = Fsymbol_value (symbol); |
| 832 PUSH (value); | |
| 833 break; | |
| 834 } | |
| 835 | |
| 836 case Bvarset: | |
| 837 case Bvarset+1: | |
| 838 case Bvarset+2: | |
| 839 case Bvarset+3: | |
| 840 case Bvarset+4: | |
| 841 case Bvarset+5: n = opcode - Bvarset; goto do_varset; | |
| 842 case Bvarset+7: n = READ_UINT_2; goto do_varset; | |
| 843 case Bvarset+6: n = READ_UINT_1; /* most common */ | |
| 844 do_varset: | |
| 845 { | |
| 846 Lisp_Object symbol = constants_data[n]; | |
| 440 | 847 Lisp_Symbol *symbol_ptr = XSYMBOL (symbol); |
| 428 | 848 Lisp_Object old_value = symbol_ptr->value; |
| 849 Lisp_Object new_value = POP; | |
| 1661 | 850 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value)) |
| 428 | 851 symbol_ptr->value = new_value; |
| 1884 | 852 else { |
| 853 /* Fset may call magic handlers */ | |
| 854 /* GCPRO_STACK; */ | |
| 428 | 855 Fset (symbol, new_value); |
| 1884 | 856 } |
| 857 | |
| 428 | 858 break; |
| 859 } | |
| 860 | |
| 861 case Bvarbind: | |
| 862 case Bvarbind+1: | |
| 863 case Bvarbind+2: | |
| 864 case Bvarbind+3: | |
| 865 case Bvarbind+4: | |
| 866 case Bvarbind+5: n = opcode - Bvarbind; goto do_varbind; | |
| 867 case Bvarbind+7: n = READ_UINT_2; goto do_varbind; | |
| 868 case Bvarbind+6: n = READ_UINT_1; /* most common */ | |
| 869 do_varbind: | |
| 870 { | |
| 871 Lisp_Object symbol = constants_data[n]; | |
| 440 | 872 Lisp_Symbol *symbol_ptr = XSYMBOL (symbol); |
| 428 | 873 Lisp_Object old_value = symbol_ptr->value; |
| 874 Lisp_Object new_value = POP; | |
| 875 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value)) | |
| 876 { | |
| 877 specpdl_ptr->symbol = symbol; | |
| 878 specpdl_ptr->old_value = old_value; | |
| 879 specpdl_ptr->func = 0; | |
| 880 specpdl_ptr++; | |
| 881 specpdl_depth_counter++; | |
| 882 | |
| 883 symbol_ptr->value = new_value; | |
| 853 | 884 |
| 885 #ifdef ERROR_CHECK_CATCH | |
| 886 check_specbind_stack_sanity (); | |
| 887 #endif | |
| 428 | 888 } |
| 889 else | |
| 1884 | 890 { |
| 891 /* does an Fset, may call magic handlers */ | |
| 892 /* GCPRO_STACK; */ | |
| 893 specbind_magic (symbol, new_value); | |
| 894 } | |
| 428 | 895 break; |
| 896 } | |
| 897 | |
| 898 case Bcall: | |
| 899 case Bcall+1: | |
| 900 case Bcall+2: | |
| 901 case Bcall+3: | |
| 902 case Bcall+4: | |
| 903 case Bcall+5: | |
| 904 case Bcall+6: | |
| 905 case Bcall+7: | |
| 906 n = (opcode < Bcall+6 ? opcode - Bcall : | |
| 907 opcode == Bcall+6 ? READ_UINT_1 : READ_UINT_2); | |
| 1920 | 908 /* #### Shouldn't this be just before the Ffuncall? |
| 909 Neither Fget nor Fput can GC. */ | |
| 1884 | 910 /* GCPRO_STACK; */ |
| 428 | 911 DISCARD (n); |
| 912 #ifdef BYTE_CODE_METER | |
| 913 if (byte_metering_on && SYMBOLP (TOP)) | |
| 914 { | |
| 915 Lisp_Object val = Fget (TOP, Qbyte_code_meter, Qnil); | |
| 916 if (INTP (val)) | |
| 917 Fput (TOP, Qbyte_code_meter, make_int (XINT (val) + 1)); | |
| 918 } | |
| 919 #endif | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
920 TOP_LVALUE = TOP; /* Ignore multiple values. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
921 TOP_LVALUE = Ffuncall (n + 1, TOP_ADDRESS); |
| 428 | 922 break; |
| 923 | |
| 924 case Bunbind: | |
| 925 case Bunbind+1: | |
| 926 case Bunbind+2: | |
| 927 case Bunbind+3: | |
| 928 case Bunbind+4: | |
| 929 case Bunbind+5: | |
| 930 case Bunbind+6: | |
| 931 case Bunbind+7: | |
| 932 UNBIND_TO (specpdl_depth() - | |
| 933 (opcode < Bunbind+6 ? opcode-Bunbind : | |
| 934 opcode == Bunbind+6 ? READ_UINT_1 : READ_UINT_2)); | |
| 935 break; | |
| 936 | |
| 937 | |
| 938 case Bgoto: | |
| 939 JUMP; | |
| 940 break; | |
| 941 | |
| 942 case Bgotoifnil: | |
| 943 if (NILP (POP)) | |
| 944 JUMP; | |
| 945 else | |
| 946 JUMP_NEXT; | |
| 947 break; | |
| 948 | |
| 949 case Bgotoifnonnil: | |
| 950 if (!NILP (POP)) | |
| 951 JUMP; | |
| 952 else | |
| 953 JUMP_NEXT; | |
| 954 break; | |
| 955 | |
| 956 case Bgotoifnilelsepop: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
957 /* Discard any multiple value: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
958 if (NILP (TOP_LVALUE = TOP)) |
| 428 | 959 JUMP; |
| 960 else | |
| 961 { | |
| 962 DISCARD (1); | |
| 963 JUMP_NEXT; | |
| 964 } | |
| 965 break; | |
| 966 | |
| 967 case Bgotoifnonnilelsepop: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
968 /* Discard any multiple value: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
969 if (!NILP (TOP_LVALUE = TOP)) |
| 428 | 970 JUMP; |
| 971 else | |
| 972 { | |
| 973 DISCARD (1); | |
| 974 JUMP_NEXT; | |
| 975 } | |
| 976 break; | |
| 977 | |
| 978 | |
| 979 case BRgoto: | |
| 980 JUMPR; | |
| 981 break; | |
| 982 | |
| 983 case BRgotoifnil: | |
| 984 if (NILP (POP)) | |
| 985 JUMPR; | |
| 986 else | |
| 987 JUMPR_NEXT; | |
| 988 break; | |
| 989 | |
| 990 case BRgotoifnonnil: | |
| 991 if (!NILP (POP)) | |
| 992 JUMPR; | |
| 993 else | |
| 994 JUMPR_NEXT; | |
| 995 break; | |
| 996 | |
| 997 case BRgotoifnilelsepop: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
998 if (NILP (TOP_LVALUE = TOP)) |
| 428 | 999 JUMPR; |
| 1000 else | |
| 1001 { | |
| 1002 DISCARD (1); | |
| 1003 JUMPR_NEXT; | |
| 1004 } | |
| 1005 break; | |
| 1006 | |
| 1007 case BRgotoifnonnilelsepop: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1008 if (!NILP (TOP_LVALUE = TOP)) |
| 428 | 1009 JUMPR; |
| 1010 else | |
| 1011 { | |
| 1012 DISCARD (1); | |
| 1013 JUMPR_NEXT; | |
| 1014 } | |
| 1015 break; | |
| 1016 | |
| 1017 case Breturn: | |
| 1018 UNGCPRO; | |
| 1019 #ifdef ERROR_CHECK_BYTE_CODE | |
| 1020 /* Binds and unbinds are supposed to be compiled balanced. */ | |
| 1021 if (specpdl_depth() != speccount) | |
| 563 | 1022 invalid_byte_code ("unbalanced specbinding stack", Qunbound); |
| 428 | 1023 #endif |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1024 return TOP_WITH_MULTIPLE_VALUES; |
| 428 | 1025 |
| 1026 case Bdiscard: | |
| 1027 DISCARD (1); | |
| 1028 break; | |
| 1029 | |
| 1030 case Bdup: | |
| 1031 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1032 Lisp_Object arg = TOP_WITH_MULTIPLE_VALUES; |
| 428 | 1033 PUSH (arg); |
| 1034 break; | |
| 1035 } | |
| 1036 | |
| 1037 case Bconstant2: | |
| 1038 PUSH (constants_data[READ_UINT_2]); | |
| 1039 break; | |
| 1040 | |
| 1041 case Bcar: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1042 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1043 /* Fcar can GC via wrong_type_argument. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1044 /* GCPRO_STACK; */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1045 Lisp_Object arg = TOP; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1046 TOP_LVALUE = CONSP (arg) ? XCAR (arg) : Fcar (arg); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1047 break; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1048 } |
| 428 | 1049 |
| 1050 case Bcdr: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1051 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1052 /* Fcdr can GC via wrong_type_argument. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1053 /* GCPRO_STACK; */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1054 Lisp_Object arg = TOP; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1055 TOP_LVALUE = CONSP (arg) ? XCDR (arg) : Fcdr (arg); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1056 break; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1057 } |
| 428 | 1058 |
| 1059 case Bunbind_all: | |
| 1060 /* To unbind back to the beginning of this frame. Not used yet, | |
| 1061 but will be needed for tail-recursion elimination. */ | |
| 771 | 1062 unbind_to (speccount); |
| 428 | 1063 break; |
| 1064 | |
| 1065 case Bnth: | |
| 1066 { | |
| 1067 Lisp_Object arg = POP; | |
| 1920 | 1068 /* Fcar and Fnthcdr can GC via wrong_type_argument. */ |
| 1069 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1070 TOP_LVALUE = Fcar (Fnthcdr (TOP, arg)); |
| 428 | 1071 break; |
| 1072 } | |
| 1073 | |
| 1074 case Bsymbolp: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1075 TOP_LVALUE = SYMBOLP (TOP) ? Qt : Qnil; |
| 428 | 1076 break; |
| 1077 | |
| 1078 case Bconsp: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1079 TOP_LVALUE = CONSP (TOP) ? Qt : Qnil; |
| 428 | 1080 break; |
| 1081 | |
| 1082 case Bstringp: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1083 TOP_LVALUE = STRINGP (TOP) ? Qt : Qnil; |
| 428 | 1084 break; |
| 1085 | |
| 1086 case Blistp: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1087 TOP_LVALUE = LISTP (TOP) ? Qt : Qnil; |
| 428 | 1088 break; |
| 1089 | |
| 1090 case Bnumberp: | |
| 1983 | 1091 #ifdef WITH_NUMBER_TYPES |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1092 TOP_LVALUE = NUMBERP (TOP) ? Qt : Qnil; |
| 1983 | 1093 #else |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1094 TOP_LVALUE = INT_OR_FLOATP (TOP) ? Qt : Qnil; |
| 1983 | 1095 #endif |
| 428 | 1096 break; |
| 1097 | |
|
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4775
diff
changeset
|
1098 case Bfixnump: |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1099 TOP_LVALUE = INTP (TOP) ? Qt : Qnil; |
| 428 | 1100 break; |
| 1101 | |
| 1102 case Beq: | |
| 1103 { | |
| 1104 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1105 TOP_LVALUE = EQ_WITH_EBOLA_NOTICE (TOP, arg) ? Qt : Qnil; |
| 428 | 1106 break; |
| 1107 } | |
| 1108 | |
| 1109 case Bnot: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1110 TOP_LVALUE = NILP (TOP) ? Qt : Qnil; |
| 428 | 1111 break; |
| 1112 | |
| 1113 case Bcons: | |
| 1114 { | |
| 1115 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1116 TOP_LVALUE = Fcons (TOP, arg); |
| 428 | 1117 break; |
| 1118 } | |
| 1119 | |
| 1120 case Blist1: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1121 TOP_LVALUE = Fcons (TOP, Qnil); |
| 428 | 1122 break; |
| 1123 | |
| 1124 | |
| 1125 case BlistN: | |
| 1126 n = READ_UINT_1; | |
| 1127 goto do_list; | |
| 1128 | |
| 1129 case Blist2: | |
| 1130 case Blist3: | |
| 1131 case Blist4: | |
| 1132 /* common case */ | |
| 1133 n = opcode - (Blist1 - 1); | |
| 1134 do_list: | |
| 1135 { | |
| 1136 Lisp_Object list = Qnil; | |
| 1137 list_loop: | |
| 1138 list = Fcons (TOP, list); | |
| 1139 if (--n) | |
| 1140 { | |
| 1141 DISCARD (1); | |
| 1142 goto list_loop; | |
| 1143 } | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1144 TOP_LVALUE = list; |
| 428 | 1145 break; |
| 1146 } | |
| 1147 | |
| 1148 | |
| 1149 case Bconcat2: | |
| 1150 case Bconcat3: | |
| 1151 case Bconcat4: | |
| 1152 n = opcode - (Bconcat2 - 2); | |
| 1153 goto do_concat; | |
| 1154 | |
| 1155 case BconcatN: | |
| 1156 /* common case */ | |
| 1157 n = READ_UINT_1; | |
| 1158 do_concat: | |
| 1159 DISCARD (n - 1); | |
| 1920 | 1160 /* Apparently `concat' can GC; Fconcat GCPROs its arguments. */ |
| 1161 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1162 TOP_LVALUE = TOP; /* Ignore multiple values. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1163 TOP_LVALUE = Fconcat (n, TOP_ADDRESS); |
| 428 | 1164 break; |
| 1165 | |
| 1166 | |
| 1167 case Blength: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1168 TOP_LVALUE = Flength (TOP); |
| 428 | 1169 break; |
| 1170 | |
| 1171 case Baset: | |
| 1172 { | |
| 1173 Lisp_Object arg2 = POP; | |
| 1174 Lisp_Object arg1 = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1175 TOP_LVALUE = Faset (TOP, arg1, arg2); |
| 428 | 1176 break; |
| 1177 } | |
| 1178 | |
| 1179 case Bsymbol_value: | |
| 1920 | 1180 /* Why does this need GCPRO_STACK? If not, remove others, too. */ |
| 1884 | 1181 /* GCPRO_STACK; */ |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1182 TOP_LVALUE = Fsymbol_value (TOP); |
| 428 | 1183 break; |
| 1184 | |
| 1185 case Bsymbol_function: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1186 TOP_LVALUE = Fsymbol_function (TOP); |
| 428 | 1187 break; |
| 1188 | |
| 1189 case Bget: | |
| 1190 { | |
| 1191 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1192 TOP_LVALUE = Fget (TOP, arg, Qnil); |
| 428 | 1193 break; |
| 1194 } | |
| 1195 | |
| 1196 case Bsub1: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1197 { |
| 1983 | 1198 #ifdef HAVE_BIGNUM |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1199 TOP_LVALUE = Fsub1 (TOP); |
| 1983 | 1200 #else |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1201 Lisp_Object arg = TOP; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1202 TOP_LVALUE = INTP (arg) ? INT_MINUS1 (arg) : Fsub1 (arg); |
| 1983 | 1203 #endif |
| 428 | 1204 break; |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1205 } |
| 428 | 1206 case Badd1: |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1207 { |
| 1983 | 1208 #ifdef HAVE_BIGNUM |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1209 TOP_LVALUE = Fadd1 (TOP); |
| 1983 | 1210 #else |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1211 Lisp_Object arg = TOP; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1212 TOP_LVALUE = INTP (arg) ? INT_PLUS1 (arg) : Fadd1 (arg); |
| 1983 | 1213 #endif |
| 428 | 1214 break; |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1215 } |
| 428 | 1216 |
| 1217 case Beqlsign: | |
| 1218 { | |
| 1219 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1220 TOP_LVALUE = bytecode_arithcompare (TOP, arg) == 0 ? Qt : Qnil; |
| 428 | 1221 break; |
| 1222 } | |
| 1223 | |
| 1224 case Bgtr: | |
| 1225 { | |
| 1226 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1227 TOP_LVALUE = bytecode_arithcompare (TOP, arg) > 0 ? Qt : Qnil; |
| 428 | 1228 break; |
| 1229 } | |
| 1230 | |
| 1231 case Blss: | |
| 1232 { | |
| 1233 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1234 TOP_LVALUE = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil; |
| 428 | 1235 break; |
| 1236 } | |
| 1237 | |
| 1238 case Bleq: | |
| 1239 { | |
| 1240 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1241 TOP_LVALUE = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil; |
| 428 | 1242 break; |
| 1243 } | |
| 1244 | |
| 1245 case Bgeq: | |
| 1246 { | |
| 1247 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1248 TOP_LVALUE = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil; |
| 428 | 1249 break; |
| 1250 } | |
| 1251 | |
| 1252 | |
| 1253 case Bnegate: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1254 TOP_LVALUE = bytecode_negate (TOP); |
| 428 | 1255 break; |
| 1256 | |
| 1257 case Bnconc: | |
| 1258 DISCARD (1); | |
| 1920 | 1259 /* nconc2 GCPROs before calling this. */ |
| 1260 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1261 TOP_LVALUE = TOP; /* Ignore multiple values. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1262 TOP_LVALUE = bytecode_nconc2 (TOP_ADDRESS); |
| 428 | 1263 break; |
| 1264 | |
| 1265 case Bplus: | |
| 1266 { | |
| 1267 Lisp_Object arg2 = POP; | |
| 1268 Lisp_Object arg1 = TOP; | |
| 1983 | 1269 #ifdef HAVE_BIGNUM |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1270 TOP_LVALUE = bytecode_arithop (arg1, arg2, opcode); |
| 1983 | 1271 #else |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1272 TOP_LVALUE = INTP (arg1) && INTP (arg2) ? |
| 428 | 1273 INT_PLUS (arg1, arg2) : |
| 1274 bytecode_arithop (arg1, arg2, opcode); | |
| 1983 | 1275 #endif |
| 428 | 1276 break; |
| 1277 } | |
| 1278 | |
| 1279 case Bdiff: | |
| 1280 { | |
| 1281 Lisp_Object arg2 = POP; | |
| 1282 Lisp_Object arg1 = TOP; | |
| 1983 | 1283 #ifdef HAVE_BIGNUM |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1284 TOP_LVALUE = bytecode_arithop (arg1, arg2, opcode); |
| 1983 | 1285 #else |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1286 TOP_LVALUE = INTP (arg1) && INTP (arg2) ? |
| 428 | 1287 INT_MINUS (arg1, arg2) : |
| 1288 bytecode_arithop (arg1, arg2, opcode); | |
| 1983 | 1289 #endif |
| 428 | 1290 break; |
| 1291 } | |
| 1292 | |
| 1293 case Bmult: | |
| 1294 case Bquo: | |
| 1295 case Bmax: | |
| 1296 case Bmin: | |
| 1297 { | |
| 1298 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1299 TOP_LVALUE = bytecode_arithop (TOP, arg, opcode); |
| 428 | 1300 break; |
| 1301 } | |
| 1302 | |
| 1303 case Bpoint: | |
| 1304 PUSH (make_int (BUF_PT (current_buffer))); | |
| 1305 break; | |
| 1306 | |
| 1307 case Binsert: | |
| 1920 | 1308 /* Says it can GC. */ |
| 1309 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1310 TOP_LVALUE = TOP; /* Ignore multiple values. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1311 TOP_LVALUE = Finsert (1, TOP_ADDRESS); |
| 428 | 1312 break; |
| 1313 | |
| 1314 case BinsertN: | |
| 1315 n = READ_UINT_1; | |
| 1316 DISCARD (n - 1); | |
| 1920 | 1317 /* See Binsert. */ |
| 1318 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1319 TOP_LVALUE = TOP; /* Ignore multiple values. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1320 TOP_LVALUE = Finsert (n, TOP_ADDRESS); |
| 428 | 1321 break; |
| 1322 | |
| 1323 case Baref: | |
| 1324 { | |
| 1325 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1326 TOP_LVALUE = Faref (TOP, arg); |
| 428 | 1327 break; |
| 1328 } | |
| 1329 | |
| 1330 case Bmemq: | |
| 1331 { | |
| 1332 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1333 TOP_LVALUE = Fmemq (TOP, arg); |
| 428 | 1334 break; |
| 1335 } | |
| 1336 | |
| 1337 case Bset: | |
| 1338 { | |
| 1339 Lisp_Object arg = POP; | |
| 1884 | 1340 /* Fset may call magic handlers */ |
| 1341 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1342 TOP_LVALUE = Fset (TOP, arg); |
| 428 | 1343 break; |
| 1344 } | |
| 1345 | |
| 1346 case Bequal: | |
| 1347 { | |
| 1348 Lisp_Object arg = POP; | |
| 1920 | 1349 /* Can QUIT, so can GC, right? */ |
| 1350 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1351 TOP_LVALUE = Fequal (TOP, arg); |
| 428 | 1352 break; |
| 1353 } | |
| 1354 | |
| 1355 case Bnthcdr: | |
| 1356 { | |
| 1357 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1358 TOP_LVALUE = Fnthcdr (TOP, arg); |
| 428 | 1359 break; |
| 1360 } | |
| 1361 | |
| 1362 case Belt: | |
| 1363 { | |
| 1364 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1365 TOP_LVALUE = Felt (TOP, arg); |
| 428 | 1366 break; |
| 1367 } | |
| 1368 | |
| 1369 case Bmember: | |
| 1370 { | |
| 1371 Lisp_Object arg = POP; | |
| 1920 | 1372 /* Can QUIT, so can GC, right? */ |
| 1373 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1374 TOP_LVALUE = Fmember (TOP, arg); |
| 428 | 1375 break; |
| 1376 } | |
| 1377 | |
| 1378 case Bgoto_char: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1379 TOP_LVALUE = Fgoto_char (TOP, Qnil); |
| 428 | 1380 break; |
| 1381 | |
| 1382 case Bcurrent_buffer: | |
| 1383 { | |
| 793 | 1384 Lisp_Object buffer = wrap_buffer (current_buffer); |
| 1385 | |
| 428 | 1386 PUSH (buffer); |
| 1387 break; | |
| 1388 } | |
| 1389 | |
| 1390 case Bset_buffer: | |
| 1884 | 1391 /* #### WAG: set-buffer may cause Fset's of buffer locals |
| 1392 Didn't prevent crash. :-( */ | |
| 1393 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1394 TOP_LVALUE = Fset_buffer (TOP); |
| 428 | 1395 break; |
| 1396 | |
| 1397 case Bpoint_max: | |
| 1398 PUSH (make_int (BUF_ZV (current_buffer))); | |
| 1399 break; | |
| 1400 | |
| 1401 case Bpoint_min: | |
| 1402 PUSH (make_int (BUF_BEGV (current_buffer))); | |
| 1403 break; | |
| 1404 | |
| 1405 case Bskip_chars_forward: | |
| 1406 { | |
| 1407 Lisp_Object arg = POP; | |
| 1920 | 1408 /* Can QUIT, so can GC, right? */ |
| 1409 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1410 TOP_LVALUE = Fskip_chars_forward (TOP, arg, Qnil); |
| 428 | 1411 break; |
| 1412 } | |
| 1413 | |
| 1414 case Bassq: | |
| 1415 { | |
| 1416 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1417 TOP_LVALUE = Fassq (TOP, arg); |
| 428 | 1418 break; |
| 1419 } | |
| 1420 | |
| 1421 case Bsetcar: | |
| 1422 { | |
| 1423 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1424 TOP_LVALUE = Fsetcar (TOP, arg); |
| 428 | 1425 break; |
| 1426 } | |
| 1427 | |
| 1428 case Bsetcdr: | |
| 1429 { | |
| 1430 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1431 TOP_LVALUE = Fsetcdr (TOP, arg); |
| 428 | 1432 break; |
| 1433 } | |
| 1434 | |
| 1435 case Bnreverse: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1436 TOP_LVALUE = bytecode_nreverse (TOP); |
| 428 | 1437 break; |
| 1438 | |
| 1439 case Bcar_safe: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1440 TOP_LVALUE = CONSP (TOP) ? XCAR (TOP) : Qnil; |
| 428 | 1441 break; |
| 1442 | |
| 1443 case Bcdr_safe: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1444 TOP_LVALUE = CONSP (TOP) ? XCDR (TOP) : Qnil; |
| 428 | 1445 break; |
| 1446 | |
| 1447 } | |
| 1448 } | |
| 1449 } | |
| 1450 | |
| 1451 /* It makes a worthwhile performance difference (5%) to shunt | |
| 1452 lesser-used opcodes off to a subroutine, to keep the switch in | |
| 1453 execute_optimized_program small. If you REALLY care about | |
| 1454 performance, you want to keep your heavily executed code away from | |
| 1455 rarely executed code, to minimize cache misses. | |
| 1456 | |
| 1457 Don't make this function static, since then the compiler might inline it. */ | |
| 1458 Lisp_Object * | |
| 1459 execute_rare_opcode (Lisp_Object *stack_ptr, | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
1460 #ifdef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
1461 Lisp_Object *stack_beg, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
1462 Lisp_Object *stack_end, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
1463 #endif /* ERROR_CHECK_BYTE_CODE */ |
| 2286 | 1464 const Opbyte *UNUSED (program_ptr), |
| 428 | 1465 Opcode opcode) |
| 1466 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1467 REGISTER int n; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1468 |
| 428 | 1469 switch (opcode) |
| 1470 { | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
1471 |
| 428 | 1472 case Bsave_excursion: |
| 1473 record_unwind_protect (save_excursion_restore, | |
| 1474 save_excursion_save ()); | |
| 1475 break; | |
| 1476 | |
|
4775
1d61580e0cf7
Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4717
diff
changeset
|
1477 /* This bytecode will eventually go away, once we no longer encounter |
|
1d61580e0cf7
Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4717
diff
changeset
|
1478 byte code from 21.4. In 21.5.10 and newer, save-window-excursion is |
|
1d61580e0cf7
Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4717
diff
changeset
|
1479 a macro. */ |
| 428 | 1480 case Bsave_window_excursion: |
| 1481 { | |
| 1482 int count = specpdl_depth (); | |
|
4775
1d61580e0cf7
Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4717
diff
changeset
|
1483 record_unwind_protect (Feval, |
|
1d61580e0cf7
Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4717
diff
changeset
|
1484 list2 (Qset_window_configuration, |
|
1d61580e0cf7
Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4717
diff
changeset
|
1485 call0 (Qcurrent_window_configuration))); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1486 TOP_LVALUE = Fprogn (TOP); |
| 771 | 1487 unbind_to (count); |
| 428 | 1488 break; |
| 1489 } | |
| 1490 | |
| 1491 case Bsave_restriction: | |
| 1492 record_unwind_protect (save_restriction_restore, | |
| 844 | 1493 save_restriction_save (current_buffer)); |
| 428 | 1494 break; |
| 1495 | |
| 1496 case Bcatch: | |
| 1497 { | |
| 1498 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1499 TOP_LVALUE = internal_catch (TOP, Feval, arg, 0, 0, 0); |
| 428 | 1500 break; |
| 1501 } | |
| 1502 | |
| 1503 case Bskip_chars_backward: | |
| 1504 { | |
| 1505 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1506 TOP_LVALUE = Fskip_chars_backward (TOP, arg, Qnil); |
| 428 | 1507 break; |
| 1508 } | |
| 1509 | |
| 1510 case Bunwind_protect: | |
| 1511 record_unwind_protect (Fprogn, POP); | |
| 1512 break; | |
| 1513 | |
| 1514 case Bcondition_case: | |
| 1515 { | |
| 1516 Lisp_Object arg2 = POP; /* handlers */ | |
| 1517 Lisp_Object arg1 = POP; /* bodyform */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1518 TOP_LVALUE = condition_case_3 (arg1, TOP, arg2); |
| 428 | 1519 break; |
| 1520 } | |
| 1521 | |
| 1522 case Bset_marker: | |
| 1523 { | |
| 1524 Lisp_Object arg2 = POP; | |
| 1525 Lisp_Object arg1 = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1526 TOP_LVALUE = Fset_marker (TOP, arg1, arg2); |
| 428 | 1527 break; |
| 1528 } | |
| 1529 | |
| 1530 case Brem: | |
| 1531 { | |
| 1532 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1533 TOP_LVALUE = Frem (TOP, arg); |
| 428 | 1534 break; |
| 1535 } | |
| 1536 | |
| 1537 case Bmatch_beginning: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1538 TOP_LVALUE = Fmatch_beginning (TOP); |
| 428 | 1539 break; |
| 1540 | |
| 1541 case Bmatch_end: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1542 TOP_LVALUE = Fmatch_end (TOP); |
| 428 | 1543 break; |
| 1544 | |
| 1545 case Bupcase: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1546 TOP_LVALUE = Fupcase (TOP, Qnil); |
| 428 | 1547 break; |
| 1548 | |
| 1549 case Bdowncase: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1550 TOP_LVALUE = Fdowncase (TOP, Qnil); |
| 428 | 1551 break; |
| 1552 | |
| 1553 case Bfset: | |
| 1554 { | |
| 1555 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1556 TOP_LVALUE = Ffset (TOP, arg); |
| 428 | 1557 break; |
| 1558 } | |
| 1559 | |
| 1560 case Bstring_equal: | |
| 1561 { | |
| 1562 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1563 TOP_LVALUE = Fstring_equal (TOP, arg); |
| 428 | 1564 break; |
| 1565 } | |
| 1566 | |
| 1567 case Bstring_lessp: | |
| 1568 { | |
| 1569 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1570 TOP_LVALUE = Fstring_lessp (TOP, arg); |
| 428 | 1571 break; |
| 1572 } | |
| 1573 | |
| 1574 case Bsubstring: | |
| 1575 { | |
| 1576 Lisp_Object arg2 = POP; | |
| 1577 Lisp_Object arg1 = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1578 TOP_LVALUE = Fsubstring (TOP, arg1, arg2); |
| 428 | 1579 break; |
| 1580 } | |
| 1581 | |
| 1582 case Bcurrent_column: | |
| 1583 PUSH (make_int (current_column (current_buffer))); | |
| 1584 break; | |
| 1585 | |
| 1586 case Bchar_after: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1587 TOP_LVALUE = Fchar_after (TOP, Qnil); |
| 428 | 1588 break; |
| 1589 | |
| 1590 case Bindent_to: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1591 TOP_LVALUE = Findent_to (TOP, Qnil, Qnil); |
| 428 | 1592 break; |
| 1593 | |
| 1594 case Bwiden: | |
| 1595 PUSH (Fwiden (Qnil)); | |
| 1596 break; | |
| 1597 | |
| 1598 case Bfollowing_char: | |
| 1599 PUSH (Ffollowing_char (Qnil)); | |
| 1600 break; | |
| 1601 | |
| 1602 case Bpreceding_char: | |
| 1603 PUSH (Fpreceding_char (Qnil)); | |
| 1604 break; | |
| 1605 | |
| 1606 case Beolp: | |
| 1607 PUSH (Feolp (Qnil)); | |
| 1608 break; | |
| 1609 | |
| 1610 case Beobp: | |
| 1611 PUSH (Feobp (Qnil)); | |
| 1612 break; | |
| 1613 | |
| 1614 case Bbolp: | |
| 1615 PUSH (Fbolp (Qnil)); | |
| 1616 break; | |
| 1617 | |
| 1618 case Bbobp: | |
| 1619 PUSH (Fbobp (Qnil)); | |
| 1620 break; | |
| 1621 | |
| 1622 case Bsave_current_buffer: | |
| 1623 record_unwind_protect (save_current_buffer_restore, | |
| 1624 Fcurrent_buffer ()); | |
| 1625 break; | |
| 1626 | |
| 1627 case Binteractive_p: | |
| 1628 PUSH (Finteractive_p ()); | |
| 1629 break; | |
| 1630 | |
| 1631 case Bforward_char: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1632 TOP_LVALUE = Fforward_char (TOP, Qnil); |
| 428 | 1633 break; |
| 1634 | |
| 1635 case Bforward_word: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1636 TOP_LVALUE = Fforward_word (TOP, Qnil); |
| 428 | 1637 break; |
| 1638 | |
| 1639 case Bforward_line: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1640 TOP_LVALUE = Fforward_line (TOP, Qnil); |
| 428 | 1641 break; |
| 1642 | |
| 1643 case Bchar_syntax: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1644 TOP_LVALUE = Fchar_syntax (TOP, Qnil); |
| 428 | 1645 break; |
| 1646 | |
| 1647 case Bbuffer_substring: | |
| 1648 { | |
| 1649 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1650 TOP_LVALUE = Fbuffer_substring (TOP, arg, Qnil); |
| 428 | 1651 break; |
| 1652 } | |
| 1653 | |
| 1654 case Bdelete_region: | |
| 1655 { | |
| 1656 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1657 TOP_LVALUE = Fdelete_region (TOP, arg, Qnil); |
| 428 | 1658 break; |
| 1659 } | |
| 1660 | |
| 1661 case Bnarrow_to_region: | |
| 1662 { | |
| 1663 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1664 TOP_LVALUE = Fnarrow_to_region (TOP, arg, Qnil); |
| 428 | 1665 break; |
| 1666 } | |
| 1667 | |
| 1668 case Bend_of_line: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1669 TOP_LVALUE = Fend_of_line (TOP, Qnil); |
| 428 | 1670 break; |
| 1671 | |
| 1672 case Btemp_output_buffer_setup: | |
| 1673 temp_output_buffer_setup (TOP); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1674 TOP_LVALUE = Vstandard_output; |
| 428 | 1675 break; |
| 1676 | |
| 1677 case Btemp_output_buffer_show: | |
| 1678 { | |
| 1679 Lisp_Object arg = POP; | |
| 1680 temp_output_buffer_show (TOP, Qnil); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1681 TOP_LVALUE = arg; |
| 428 | 1682 /* GAG ME!! */ |
| 1683 /* pop binding of standard-output */ | |
| 771 | 1684 unbind_to (specpdl_depth() - 1); |
| 428 | 1685 break; |
| 1686 } | |
| 1687 | |
| 1688 case Bold_eq: | |
| 1689 { | |
| 1690 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1691 TOP_LVALUE = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil; |
| 428 | 1692 break; |
| 1693 } | |
| 1694 | |
| 1695 case Bold_memq: | |
| 1696 { | |
| 1697 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1698 TOP_LVALUE = Fold_memq (TOP, arg); |
| 428 | 1699 break; |
| 1700 } | |
| 1701 | |
| 1702 case Bold_equal: | |
| 1703 { | |
| 1704 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1705 TOP_LVALUE = Fold_equal (TOP, arg); |
| 428 | 1706 break; |
| 1707 } | |
| 1708 | |
| 1709 case Bold_member: | |
| 1710 { | |
| 1711 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1712 TOP_LVALUE = Fold_member (TOP, arg); |
| 428 | 1713 break; |
| 1714 } | |
| 1715 | |
| 1716 case Bold_assq: | |
| 1717 { | |
| 1718 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1719 TOP_LVALUE = Fold_assq (TOP, arg); |
| 428 | 1720 break; |
| 1721 } | |
| 1722 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1723 case Bbind_multiple_value_limits: |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1724 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1725 Lisp_Object upper = POP, first = TOP, speccount; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1726 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1727 CHECK_NATNUM (upper); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1728 CHECK_NATNUM (first); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1729 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1730 speccount = make_int (bind_multiple_value_limits (XINT (first), |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1731 XINT (upper))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1732 PUSH (upper); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1733 PUSH (speccount); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1734 break; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1735 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1736 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1737 case Bmultiple_value_call: |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1738 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1739 n = XINT (POP); |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
1740 DISCARD_PRESERVING_MULTIPLE_VALUES_UNSAFE (n - 1); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1741 /* Discard multiple values for the first (function) argument: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1742 TOP_LVALUE = TOP; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1743 TOP_LVALUE = multiple_value_call (n, TOP_ADDRESS); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1744 break; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1745 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1746 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1747 case Bmultiple_value_list_internal: |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1748 { |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
1749 DISCARD_PRESERVING_MULTIPLE_VALUES_UNSAFE (3); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1750 TOP_LVALUE = multiple_value_list_internal (4, TOP_ADDRESS); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1751 break; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1752 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1753 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1754 case Bthrow: |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1755 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1756 Lisp_Object arg = POP_WITH_MULTIPLE_VALUES; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1757 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1758 /* We never throw to a catch tag that is a multiple value: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1759 throw_or_bomb_out (TOP, arg, 0, Qnil, Qnil); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1760 break; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1761 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1762 |
| 428 | 1763 default: |
|
4914
1628e3b9601a
When aborting due to unknown opcode, output more descriptive msg
Ben Wing <ben@xemacs.org>
parents:
4910
diff
changeset
|
1764 { |
|
1628e3b9601a
When aborting due to unknown opcode, output more descriptive msg
Ben Wing <ben@xemacs.org>
parents:
4910
diff
changeset
|
1765 Ascbyte msg[100]; |
|
1628e3b9601a
When aborting due to unknown opcode, output more descriptive msg
Ben Wing <ben@xemacs.org>
parents:
4910
diff
changeset
|
1766 sprintf (msg, "Unknown opcode %d", opcode); |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
1767 bytecode_abort_with_message (msg); |
|
4914
1628e3b9601a
When aborting due to unknown opcode, output more descriptive msg
Ben Wing <ben@xemacs.org>
parents:
4910
diff
changeset
|
1768 } |
| 428 | 1769 break; |
| 1770 } | |
| 1771 return stack_ptr; | |
| 1772 } | |
| 1773 | |
| 1774 | |
| 563 | 1775 DOESNT_RETURN |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4775
diff
changeset
|
1776 invalid_byte_code (const Ascbyte *reason, Lisp_Object frob) |
| 428 | 1777 { |
| 563 | 1778 signal_error (Qinvalid_byte_code, reason, frob); |
| 428 | 1779 } |
| 1780 | |
| 1781 /* Check for valid opcodes. Change this when adding new opcodes. */ | |
| 1782 static void | |
| 1783 check_opcode (Opcode opcode) | |
| 1784 { | |
| 1785 if ((opcode < Bvarref) || | |
| 1786 (opcode == 0251) || | |
| 1787 (opcode > Bassq && opcode < Bconstant)) | |
| 563 | 1788 invalid_byte_code ("invalid opcode in instruction stream", |
| 1789 make_int (opcode)); | |
| 428 | 1790 } |
| 1791 | |
| 1792 /* Check that IDX is a valid offset into the `constants' vector */ | |
| 1793 static void | |
| 1794 check_constants_index (int idx, Lisp_Object constants) | |
| 1795 { | |
| 1796 if (idx < 0 || idx >= XVECTOR_LENGTH (constants)) | |
| 563 | 1797 signal_ferror |
| 1798 (Qinvalid_byte_code, | |
| 1799 "reference %d to constants array out of range 0, %ld", | |
| 428 | 1800 idx, XVECTOR_LENGTH (constants) - 1); |
| 1801 } | |
| 1802 | |
| 1803 /* Get next character from Lisp instructions string. */ | |
| 563 | 1804 #define READ_INSTRUCTION_CHAR(lvalue) do { \ |
| 867 | 1805 (lvalue) = itext_ichar (ptr); \ |
| 1806 INC_IBYTEPTR (ptr); \ | |
| 563 | 1807 *icounts_ptr++ = program_ptr - program; \ |
| 1808 if (lvalue > UCHAR_MAX) \ | |
| 1809 invalid_byte_code \ | |
| 1810 ("Invalid character in byte code string", make_char (lvalue)); \ | |
| 428 | 1811 } while (0) |
| 1812 | |
| 1813 /* Get opcode from Lisp instructions string. */ | |
| 1814 #define READ_OPCODE do { \ | |
| 1815 unsigned int c; \ | |
| 1816 READ_INSTRUCTION_CHAR (c); \ | |
| 1817 opcode = (Opcode) c; \ | |
| 1818 } while (0) | |
| 1819 | |
| 1820 /* Get next operand, a uint8, from Lisp instructions string. */ | |
| 1821 #define READ_OPERAND_1 do { \ | |
| 1822 READ_INSTRUCTION_CHAR (arg); \ | |
| 1823 argsize = 1; \ | |
| 1824 } while (0) | |
| 1825 | |
| 1826 /* Get next operand, a uint16, from Lisp instructions string. */ | |
| 1827 #define READ_OPERAND_2 do { \ | |
| 1828 unsigned int arg1, arg2; \ | |
| 1829 READ_INSTRUCTION_CHAR (arg1); \ | |
| 1830 READ_INSTRUCTION_CHAR (arg2); \ | |
| 1831 arg = arg1 + (arg2 << 8); \ | |
| 1832 argsize = 2; \ | |
| 1833 } while (0) | |
| 1834 | |
| 1835 /* Write 1 byte to PTR, incrementing PTR */ | |
| 1836 #define WRITE_INT8(value, ptr) do { \ | |
| 1837 *((ptr)++) = (value); \ | |
| 1838 } while (0) | |
| 1839 | |
| 1840 /* Write 2 bytes to PTR, incrementing PTR */ | |
| 1841 #define WRITE_INT16(value, ptr) do { \ | |
| 1842 WRITE_INT8 (((unsigned) (value)) & 0x00ff, (ptr)); \ | |
| 1843 WRITE_INT8 (((unsigned) (value)) >> 8 , (ptr)); \ | |
| 1844 } while (0) | |
| 1845 | |
| 1846 /* We've changed our minds about the opcode we've already written. */ | |
| 1847 #define REWRITE_OPCODE(new_opcode) ((void) (program_ptr[-1] = new_opcode)) | |
| 1848 | |
| 1849 /* Encode an op arg within the opcode, or as a 1 or 2-byte operand. */ | |
| 1850 #define WRITE_NARGS(base_opcode) do { \ | |
| 1851 if (arg <= 5) \ | |
| 1852 { \ | |
| 1853 REWRITE_OPCODE (base_opcode + arg); \ | |
| 1854 } \ | |
| 1855 else if (arg <= UCHAR_MAX) \ | |
| 1856 { \ | |
| 1857 REWRITE_OPCODE (base_opcode + 6); \ | |
| 1858 WRITE_INT8 (arg, program_ptr); \ | |
| 1859 } \ | |
| 1860 else \ | |
| 1861 { \ | |
| 1862 REWRITE_OPCODE (base_opcode + 7); \ | |
| 1863 WRITE_INT16 (arg, program_ptr); \ | |
| 1864 } \ | |
| 1865 } while (0) | |
| 1866 | |
| 1867 /* Encode a constants reference within the opcode, or as a 2-byte operand. */ | |
| 1868 #define WRITE_CONSTANT do { \ | |
| 1869 check_constants_index(arg, constants); \ | |
| 1870 if (arg <= UCHAR_MAX - Bconstant) \ | |
| 1871 { \ | |
| 1872 REWRITE_OPCODE (Bconstant + arg); \ | |
| 1873 } \ | |
| 1874 else \ | |
| 1875 { \ | |
| 1876 REWRITE_OPCODE (Bconstant2); \ | |
| 1877 WRITE_INT16 (arg, program_ptr); \ | |
| 1878 } \ | |
| 1879 } while (0) | |
| 1880 | |
| 1881 #define WRITE_OPCODE WRITE_INT8 (opcode, program_ptr) | |
| 1882 | |
| 1883 /* Compile byte code instructions into free space provided by caller, with | |
| 1884 size >= (2 * string_char_length (instructions) + 1) * sizeof (Opbyte). | |
| 1885 Returns length of compiled code. */ | |
| 1886 static void | |
| 1887 optimize_byte_code (/* in */ | |
| 1888 Lisp_Object instructions, | |
| 1889 Lisp_Object constants, | |
| 1890 /* out */ | |
| 442 | 1891 Opbyte * const program, |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
1892 Elemcount * const program_length, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
1893 Elemcount * const varbind_count) |
| 428 | 1894 { |
| 647 | 1895 Bytecount instructions_length = XSTRING_LENGTH (instructions); |
| 665 | 1896 Elemcount comfy_size = (Elemcount) (2 * instructions_length); |
| 428 | 1897 |
| 442 | 1898 int * const icounts = alloca_array (int, comfy_size); |
| 428 | 1899 int * icounts_ptr = icounts; |
| 1900 | |
| 1901 /* We maintain a table of jumps in the source code. */ | |
| 1902 struct jump | |
| 1903 { | |
| 1904 int from; | |
| 1905 int to; | |
| 1906 }; | |
| 442 | 1907 struct jump * const jumps = alloca_array (struct jump, comfy_size); |
| 428 | 1908 struct jump *jumps_ptr = jumps; |
| 1909 | |
| 1910 Opbyte *program_ptr = program; | |
| 1911 | |
| 867 | 1912 const Ibyte *ptr = XSTRING_DATA (instructions); |
| 1913 const Ibyte * const end = ptr + instructions_length; | |
| 428 | 1914 |
| 1915 *varbind_count = 0; | |
| 1916 | |
| 1917 while (ptr < end) | |
| 1918 { | |
| 1919 Opcode opcode; | |
| 1920 int arg; | |
| 1921 int argsize = 0; | |
| 1922 READ_OPCODE; | |
| 1923 WRITE_OPCODE; | |
| 1924 | |
| 1925 switch (opcode) | |
| 1926 { | |
| 1927 Lisp_Object val; | |
| 1928 | |
| 1929 case Bvarref+7: READ_OPERAND_2; goto do_varref; | |
| 1930 case Bvarref+6: READ_OPERAND_1; goto do_varref; | |
| 1931 case Bvarref: case Bvarref+1: case Bvarref+2: | |
| 1932 case Bvarref+3: case Bvarref+4: case Bvarref+5: | |
| 1933 arg = opcode - Bvarref; | |
| 1934 do_varref: | |
| 1935 check_constants_index (arg, constants); | |
| 1936 val = XVECTOR_DATA (constants) [arg]; | |
| 1937 if (!SYMBOLP (val)) | |
| 563 | 1938 invalid_byte_code ("variable reference to non-symbol", val); |
| 428 | 1939 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val))) |
| 563 | 1940 invalid_byte_code ("variable reference to constant symbol", val); |
| 428 | 1941 WRITE_NARGS (Bvarref); |
| 1942 break; | |
| 1943 | |
| 1944 case Bvarset+7: READ_OPERAND_2; goto do_varset; | |
| 1945 case Bvarset+6: READ_OPERAND_1; goto do_varset; | |
| 1946 case Bvarset: case Bvarset+1: case Bvarset+2: | |
| 1947 case Bvarset+3: case Bvarset+4: case Bvarset+5: | |
| 1948 arg = opcode - Bvarset; | |
| 1949 do_varset: | |
| 1950 check_constants_index (arg, constants); | |
| 1951 val = XVECTOR_DATA (constants) [arg]; | |
| 1952 if (!SYMBOLP (val)) | |
| 563 | 1953 wtaerror ("attempt to set non-symbol", val); |
| 428 | 1954 if (EQ (val, Qnil) || EQ (val, Qt)) |
| 563 | 1955 signal_error (Qsetting_constant, 0, val); |
| 428 | 1956 /* Ignore assignments to keywords by converting to Bdiscard. |
| 1957 For backward compatibility only - we'd like to make this an error. */ | |
| 1958 if (SYMBOL_IS_KEYWORD (val)) | |
| 1959 REWRITE_OPCODE (Bdiscard); | |
| 1960 else | |
| 1961 WRITE_NARGS (Bvarset); | |
| 1962 break; | |
| 1963 | |
| 1964 case Bvarbind+7: READ_OPERAND_2; goto do_varbind; | |
| 1965 case Bvarbind+6: READ_OPERAND_1; goto do_varbind; | |
| 1966 case Bvarbind: case Bvarbind+1: case Bvarbind+2: | |
| 1967 case Bvarbind+3: case Bvarbind+4: case Bvarbind+5: | |
| 1968 arg = opcode - Bvarbind; | |
| 1969 do_varbind: | |
| 1970 (*varbind_count)++; | |
| 1971 check_constants_index (arg, constants); | |
| 1972 val = XVECTOR_DATA (constants) [arg]; | |
| 1973 if (!SYMBOLP (val)) | |
| 563 | 1974 wtaerror ("attempt to let-bind non-symbol", val); |
| 428 | 1975 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val))) |
| 563 | 1976 signal_error (Qsetting_constant, |
| 1977 "attempt to let-bind constant symbol", val); | |
| 428 | 1978 WRITE_NARGS (Bvarbind); |
| 1979 break; | |
| 1980 | |
| 1981 case Bcall+7: READ_OPERAND_2; goto do_call; | |
| 1982 case Bcall+6: READ_OPERAND_1; goto do_call; | |
| 1983 case Bcall: case Bcall+1: case Bcall+2: | |
| 1984 case Bcall+3: case Bcall+4: case Bcall+5: | |
| 1985 arg = opcode - Bcall; | |
| 1986 do_call: | |
| 1987 WRITE_NARGS (Bcall); | |
| 1988 break; | |
| 1989 | |
| 1990 case Bunbind+7: READ_OPERAND_2; goto do_unbind; | |
| 1991 case Bunbind+6: READ_OPERAND_1; goto do_unbind; | |
| 1992 case Bunbind: case Bunbind+1: case Bunbind+2: | |
| 1993 case Bunbind+3: case Bunbind+4: case Bunbind+5: | |
| 1994 arg = opcode - Bunbind; | |
| 1995 do_unbind: | |
| 1996 WRITE_NARGS (Bunbind); | |
| 1997 break; | |
| 1998 | |
| 1999 case Bgoto: | |
| 2000 case Bgotoifnil: | |
| 2001 case Bgotoifnonnil: | |
| 2002 case Bgotoifnilelsepop: | |
| 2003 case Bgotoifnonnilelsepop: | |
| 2004 READ_OPERAND_2; | |
| 2005 /* Make program_ptr-relative */ | |
| 2006 arg += icounts - (icounts_ptr - argsize); | |
| 2007 goto do_jump; | |
| 2008 | |
| 2009 case BRgoto: | |
| 2010 case BRgotoifnil: | |
| 2011 case BRgotoifnonnil: | |
| 2012 case BRgotoifnilelsepop: | |
| 2013 case BRgotoifnonnilelsepop: | |
| 2014 READ_OPERAND_1; | |
| 2015 /* Make program_ptr-relative */ | |
| 2016 arg -= 127; | |
| 2017 do_jump: | |
| 2018 /* Record program-relative goto addresses in `jumps' table */ | |
| 2019 jumps_ptr->from = icounts_ptr - icounts - argsize; | |
| 2020 jumps_ptr->to = jumps_ptr->from + arg; | |
| 2021 jumps_ptr++; | |
| 2022 if (arg >= -1 && arg <= argsize) | |
| 563 | 2023 invalid_byte_code ("goto instruction is its own target", Qunbound); |
| 428 | 2024 if (arg <= SCHAR_MIN || |
| 2025 arg > SCHAR_MAX) | |
| 2026 { | |
| 2027 if (argsize == 1) | |
| 2028 REWRITE_OPCODE (opcode + Bgoto - BRgoto); | |
| 2029 WRITE_INT16 (arg, program_ptr); | |
| 2030 } | |
| 2031 else | |
| 2032 { | |
| 2033 if (argsize == 2) | |
| 2034 REWRITE_OPCODE (opcode + BRgoto - Bgoto); | |
| 2035 WRITE_INT8 (arg, program_ptr); | |
| 2036 } | |
| 2037 break; | |
| 2038 | |
| 2039 case Bconstant2: | |
| 2040 READ_OPERAND_2; | |
| 2041 WRITE_CONSTANT; | |
| 2042 break; | |
| 2043 | |
| 2044 case BlistN: | |
| 2045 case BconcatN: | |
| 2046 case BinsertN: | |
| 2047 READ_OPERAND_1; | |
| 2048 WRITE_INT8 (arg, program_ptr); | |
| 2049 break; | |
| 2050 | |
| 2051 default: | |
| 2052 if (opcode < Bconstant) | |
| 2053 check_opcode (opcode); | |
| 2054 else | |
| 2055 { | |
| 2056 arg = opcode - Bconstant; | |
| 2057 WRITE_CONSTANT; | |
| 2058 } | |
| 2059 break; | |
| 2060 } | |
| 2061 } | |
| 2062 | |
| 2063 /* Fix up jumps table to refer to NEW offsets. */ | |
| 2064 { | |
| 2065 struct jump *j; | |
| 2066 for (j = jumps; j < jumps_ptr; j++) | |
| 2067 { | |
| 2068 #ifdef ERROR_CHECK_BYTE_CODE | |
| 2069 assert (j->from < icounts_ptr - icounts); | |
| 2070 assert (j->to < icounts_ptr - icounts); | |
| 2071 #endif | |
| 2072 j->from = icounts[j->from]; | |
| 2073 j->to = icounts[j->to]; | |
| 2074 #ifdef ERROR_CHECK_BYTE_CODE | |
| 2075 assert (j->from < program_ptr - program); | |
| 2076 assert (j->to < program_ptr - program); | |
| 2077 check_opcode ((Opcode) (program[j->from-1])); | |
| 2078 #endif | |
| 2079 check_opcode ((Opcode) (program[j->to])); | |
| 2080 } | |
| 2081 } | |
| 2082 | |
| 2083 /* Fixup jumps in byte-code until no more fixups needed */ | |
| 2084 { | |
| 2085 int more_fixups_needed = 1; | |
| 2086 | |
| 2087 while (more_fixups_needed) | |
| 2088 { | |
| 2089 struct jump *j; | |
| 2090 more_fixups_needed = 0; | |
| 2091 for (j = jumps; j < jumps_ptr; j++) | |
| 2092 { | |
| 2093 int from = j->from; | |
| 2094 int to = j->to; | |
| 2095 int jump = to - from; | |
| 2096 Opbyte *p = program + from; | |
| 2097 Opcode opcode = (Opcode) p[-1]; | |
| 2098 if (!more_fixups_needed) | |
| 2099 check_opcode ((Opcode) p[jump]); | |
| 2100 assert (to >= 0 && program + to < program_ptr); | |
| 2101 switch (opcode) | |
| 2102 { | |
| 2103 case Bgoto: | |
| 2104 case Bgotoifnil: | |
| 2105 case Bgotoifnonnil: | |
| 2106 case Bgotoifnilelsepop: | |
| 2107 case Bgotoifnonnilelsepop: | |
| 2108 WRITE_INT16 (jump, p); | |
| 2109 break; | |
| 2110 | |
| 2111 case BRgoto: | |
| 2112 case BRgotoifnil: | |
| 2113 case BRgotoifnonnil: | |
| 2114 case BRgotoifnilelsepop: | |
| 2115 case BRgotoifnonnilelsepop: | |
| 2116 if (jump > SCHAR_MIN && | |
| 2117 jump <= SCHAR_MAX) | |
| 2118 { | |
| 2119 WRITE_INT8 (jump, p); | |
| 2120 } | |
| 2121 else /* barf */ | |
| 2122 { | |
| 2123 struct jump *jj; | |
| 2124 for (jj = jumps; jj < jumps_ptr; jj++) | |
| 2125 { | |
| 2126 assert (jj->from < program_ptr - program); | |
| 2127 assert (jj->to < program_ptr - program); | |
| 2128 if (jj->from > from) jj->from++; | |
| 2129 if (jj->to > from) jj->to++; | |
| 2130 } | |
| 2131 p[-1] += Bgoto - BRgoto; | |
| 2132 more_fixups_needed = 1; | |
| 2133 memmove (p+1, p, program_ptr++ - p); | |
| 2134 WRITE_INT16 (jump, p); | |
| 2135 } | |
| 2136 break; | |
| 2137 | |
| 2138 default: | |
| 2500 | 2139 ABORT(); |
| 428 | 2140 break; |
| 2141 } | |
| 2142 } | |
| 2143 } | |
| 2144 } | |
| 2145 | |
| 2146 /* *program_ptr++ = 0; */ | |
| 2147 *program_length = program_ptr - program; | |
| 2148 } | |
| 2149 | |
| 2150 /* Optimize the byte code and store the optimized program, only | |
| 2151 understood by bytecode.c, in an opaque object in the | |
| 2152 instructions slot of the Compiled_Function object. */ | |
| 2153 void | |
| 2154 optimize_compiled_function (Lisp_Object compiled_function) | |
| 2155 { | |
| 2156 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (compiled_function); | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2157 Elemcount program_length; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2158 Elemcount varbind_count; |
| 428 | 2159 Opbyte *program; |
| 2160 | |
| 1737 | 2161 { |
| 2162 int minargs = 0, maxargs = 0, totalargs = 0; | |
| 2163 int optional_p = 0, rest_p = 0, i = 0; | |
| 2164 { | |
| 2165 LIST_LOOP_2 (arg, f->arglist) | |
| 2166 { | |
| 2167 if (EQ (arg, Qand_optional)) | |
| 2168 optional_p = 1; | |
| 2169 else if (EQ (arg, Qand_rest)) | |
| 2170 rest_p = 1; | |
| 2171 else | |
| 2172 { | |
| 2173 if (rest_p) | |
| 2174 { | |
| 2175 maxargs = MANY; | |
| 2176 totalargs++; | |
| 2177 break; | |
| 2178 } | |
| 2179 if (!optional_p) | |
| 2180 minargs++; | |
| 2181 maxargs++; | |
| 2182 totalargs++; | |
| 2183 } | |
| 2184 } | |
| 2185 } | |
| 2186 | |
| 2187 if (totalargs) | |
| 3092 | 2188 #ifdef NEW_GC |
| 2189 f->arguments = make_compiled_function_args (totalargs); | |
| 2190 #else /* not NEW_GC */ | |
| 1737 | 2191 f->args = xnew_array (Lisp_Object, totalargs); |
| 3092 | 2192 #endif /* not NEW_GC */ |
| 1737 | 2193 |
| 2194 { | |
| 2195 LIST_LOOP_2 (arg, f->arglist) | |
| 2196 { | |
| 2197 if (!EQ (arg, Qand_optional) && !EQ (arg, Qand_rest)) | |
| 3092 | 2198 #ifdef NEW_GC |
| 2199 XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i++] = arg; | |
| 2200 #else /* not NEW_GC */ | |
| 1737 | 2201 f->args[i++] = arg; |
| 3092 | 2202 #endif /* not NEW_GC */ |
| 1737 | 2203 } |
| 2204 } | |
| 2205 | |
| 2206 f->max_args = maxargs; | |
| 2207 f->min_args = minargs; | |
| 2208 f->args_in_array = totalargs; | |
| 2209 } | |
| 2210 | |
| 428 | 2211 /* If we have not actually read the bytecode string |
| 2212 and constants vector yet, fetch them from the file. */ | |
| 2213 if (CONSP (f->instructions)) | |
| 2214 Ffetch_bytecode (compiled_function); | |
| 2215 | |
| 2216 if (STRINGP (f->instructions)) | |
| 2217 { | |
| 826 | 2218 /* XSTRING_LENGTH() is more efficient than string_char_length(), |
| 428 | 2219 which would be slightly more `proper' */ |
| 2220 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions)); | |
| 2221 optimize_byte_code (f->instructions, f->constants, | |
| 2222 program, &program_length, &varbind_count); | |
| 2500 | 2223 f->specpdl_depth = (unsigned short) (XINT (Flength (f->arglist)) + |
| 2224 varbind_count); | |
| 428 | 2225 f->instructions = |
| 440 | 2226 make_opaque (program, program_length * sizeof (Opbyte)); |
| 428 | 2227 } |
| 2228 | |
| 2229 assert (OPAQUEP (f->instructions)); | |
| 2230 } | |
| 2231 | |
| 2232 /************************************************************************/ | |
| 2233 /* The compiled-function object type */ | |
| 2234 /************************************************************************/ | |
| 3092 | 2235 |
| 428 | 2236 static void |
| 2237 print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun, | |
| 2238 int escapeflag) | |
| 2239 { | |
| 2240 /* This function can GC */ | |
| 2241 Lisp_Compiled_Function *f = | |
| 2242 XCOMPILED_FUNCTION (obj); /* GC doesn't relocate */ | |
| 2243 int docp = f->flags.documentationp; | |
| 2244 int intp = f->flags.interactivep; | |
| 2245 struct gcpro gcpro1, gcpro2; | |
| 2246 GCPRO2 (obj, printcharfun); | |
| 2247 | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4775
diff
changeset
|
2248 write_ascstring (printcharfun, print_readably ? "#[" : "#<compiled-function "); |
| 428 | 2249 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK |
| 2250 if (!print_readably) | |
| 2251 { | |
| 2252 Lisp_Object ann = compiled_function_annotation (f); | |
| 2253 if (!NILP (ann)) | |
| 800 | 2254 write_fmt_string_lisp (printcharfun, "(from %S) ", 1, ann); |
| 428 | 2255 } |
| 2256 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */ | |
| 2257 /* COMPILED_ARGLIST = 0 */ | |
| 2258 print_internal (compiled_function_arglist (f), printcharfun, escapeflag); | |
| 2259 | |
| 2260 /* COMPILED_INSTRUCTIONS = 1 */ | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4775
diff
changeset
|
2261 write_ascstring (printcharfun, " "); |
| 428 | 2262 { |
| 2263 struct gcpro ngcpro1; | |
| 2264 Lisp_Object instructions = compiled_function_instructions (f); | |
| 2265 NGCPRO1 (instructions); | |
| 2266 if (STRINGP (instructions) && !print_readably) | |
| 2267 { | |
| 2268 /* We don't usually want to see that junk in the bytecode. */ | |
| 800 | 2269 write_fmt_string (printcharfun, "\"...(%ld)\"", |
| 826 | 2270 (long) string_char_length (instructions)); |
| 428 | 2271 } |
| 2272 else | |
| 2273 print_internal (instructions, printcharfun, escapeflag); | |
| 2274 NUNGCPRO; | |
| 2275 } | |
| 2276 | |
| 2277 /* COMPILED_CONSTANTS = 2 */ | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4775
diff
changeset
|
2278 write_ascstring (printcharfun, " "); |
| 428 | 2279 print_internal (compiled_function_constants (f), printcharfun, escapeflag); |
| 2280 | |
| 2281 /* COMPILED_STACK_DEPTH = 3 */ | |
| 800 | 2282 write_fmt_string (printcharfun, " %d", compiled_function_stack_depth (f)); |
| 428 | 2283 |
| 2284 /* COMPILED_DOC_STRING = 4 */ | |
| 2285 if (docp || intp) | |
| 2286 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4775
diff
changeset
|
2287 write_ascstring (printcharfun, " "); |
| 428 | 2288 print_internal (compiled_function_documentation (f), printcharfun, |
| 2289 escapeflag); | |
| 2290 } | |
| 2291 | |
| 2292 /* COMPILED_INTERACTIVE = 5 */ | |
| 2293 if (intp) | |
| 2294 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4775
diff
changeset
|
2295 write_ascstring (printcharfun, " "); |
| 428 | 2296 print_internal (compiled_function_interactive (f), printcharfun, |
| 2297 escapeflag); | |
| 2298 } | |
| 2299 | |
| 2300 UNGCPRO; | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4775
diff
changeset
|
2301 write_ascstring (printcharfun, print_readably ? "]" : ">"); |
| 428 | 2302 } |
| 2303 | |
| 2304 | |
| 2305 static Lisp_Object | |
| 2306 mark_compiled_function (Lisp_Object obj) | |
| 2307 { | |
| 2308 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj); | |
| 814 | 2309 int i; |
| 428 | 2310 |
| 2311 mark_object (f->instructions); | |
| 2312 mark_object (f->arglist); | |
| 2313 mark_object (f->doc_and_interactive); | |
| 2314 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
| 2315 mark_object (f->annotated); | |
| 2316 #endif | |
| 814 | 2317 for (i = 0; i < f->args_in_array; i++) |
| 3092 | 2318 #ifdef NEW_GC |
| 2319 mark_object (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i]); | |
| 2320 #else /* not NEW_GC */ | |
| 814 | 2321 mark_object (f->args[i]); |
| 3092 | 2322 #endif /* not NEW_GC */ |
| 814 | 2323 |
| 428 | 2324 /* tail-recurse on constants */ |
| 2325 return f->constants; | |
| 2326 } | |
| 2327 | |
| 2328 static int | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
2329 compiled_function_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
2330 int UNUSED (foldcase)) |
| 428 | 2331 { |
| 2332 Lisp_Compiled_Function *f1 = XCOMPILED_FUNCTION (obj1); | |
| 2333 Lisp_Compiled_Function *f2 = XCOMPILED_FUNCTION (obj2); | |
| 2334 return | |
| 2335 (f1->flags.documentationp == f2->flags.documentationp && | |
| 2336 f1->flags.interactivep == f2->flags.interactivep && | |
| 2337 f1->flags.domainp == f2->flags.domainp && /* I18N3 */ | |
| 2338 internal_equal (compiled_function_instructions (f1), | |
| 2339 compiled_function_instructions (f2), depth + 1) && | |
| 2340 internal_equal (f1->constants, f2->constants, depth + 1) && | |
| 2341 internal_equal (f1->arglist, f2->arglist, depth + 1) && | |
| 2342 internal_equal (f1->doc_and_interactive, | |
| 2343 f2->doc_and_interactive, depth + 1)); | |
| 2344 } | |
| 2345 | |
| 665 | 2346 static Hashcode |
| 428 | 2347 compiled_function_hash (Lisp_Object obj, int depth) |
| 2348 { | |
| 2349 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj); | |
| 2350 return HASH3 ((f->flags.documentationp << 2) + | |
| 2351 (f->flags.interactivep << 1) + | |
| 2352 f->flags.domainp, | |
| 2353 internal_hash (f->instructions, depth + 1), | |
| 2354 internal_hash (f->constants, depth + 1)); | |
| 2355 } | |
| 2356 | |
| 1204 | 2357 static const struct memory_description compiled_function_description[] = { |
| 814 | 2358 { XD_INT, offsetof (Lisp_Compiled_Function, args_in_array) }, |
| 3092 | 2359 #ifdef NEW_GC |
| 2360 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, arguments) }, | |
| 2361 #else /* not NEW_GC */ | |
| 2362 { XD_BLOCK_PTR, offsetof (Lisp_Compiled_Function, args), | |
| 2551 | 2363 XD_INDIRECT (0, 0), { &lisp_object_description } }, |
| 3092 | 2364 #endif /* not NEW_GC */ |
| 440 | 2365 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, instructions) }, |
| 2366 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, constants) }, | |
| 2367 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, arglist) }, | |
| 2368 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, doc_and_interactive) }, | |
| 428 | 2369 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK |
| 440 | 2370 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, annotated) }, |
| 428 | 2371 #endif |
| 2372 { XD_END } | |
| 2373 }; | |
| 2374 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2375 DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("compiled-function", compiled_function, |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
2376 mark_compiled_function, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
2377 print_compiled_function, 0, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
2378 compiled_function_equal, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
2379 compiled_function_hash, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
2380 compiled_function_description, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
2381 Lisp_Compiled_Function); |
| 3092 | 2382 |
| 428 | 2383 |
| 2384 DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /* | |
| 2385 Return t if OBJECT is a byte-compiled function object. | |
| 2386 */ | |
| 2387 (object)) | |
| 2388 { | |
| 2389 return COMPILED_FUNCTIONP (object) ? Qt : Qnil; | |
| 2390 } | |
| 2391 | |
| 2392 /************************************************************************/ | |
| 2393 /* compiled-function object accessor functions */ | |
| 2394 /************************************************************************/ | |
| 2395 | |
| 2396 Lisp_Object | |
| 2397 compiled_function_arglist (Lisp_Compiled_Function *f) | |
| 2398 { | |
| 2399 return f->arglist; | |
| 2400 } | |
| 2401 | |
| 2402 Lisp_Object | |
| 2403 compiled_function_instructions (Lisp_Compiled_Function *f) | |
| 2404 { | |
| 2405 if (! OPAQUEP (f->instructions)) | |
| 2406 return f->instructions; | |
| 2407 | |
| 2408 { | |
| 2409 /* Invert action performed by optimize_byte_code() */ | |
| 2410 Lisp_Opaque *opaque = XOPAQUE (f->instructions); | |
| 2411 | |
| 867 | 2412 Ibyte * const buffer = |
| 2367 | 2413 alloca_ibytes (OPAQUE_SIZE (opaque) * MAX_ICHAR_LEN); |
| 867 | 2414 Ibyte *bp = buffer; |
| 428 | 2415 |
| 442 | 2416 const Opbyte * const program = (const Opbyte *) OPAQUE_DATA (opaque); |
| 2417 const Opbyte *program_ptr = program; | |
| 2418 const Opbyte * const program_end = program_ptr + OPAQUE_SIZE (opaque); | |
| 428 | 2419 |
| 2420 while (program_ptr < program_end) | |
| 2421 { | |
| 2422 Opcode opcode = (Opcode) READ_UINT_1; | |
| 867 | 2423 bp += set_itext_ichar (bp, opcode); |
| 428 | 2424 switch (opcode) |
| 2425 { | |
| 2426 case Bvarref+7: | |
| 2427 case Bvarset+7: | |
| 2428 case Bvarbind+7: | |
| 2429 case Bcall+7: | |
| 2430 case Bunbind+7: | |
| 2431 case Bconstant2: | |
| 867 | 2432 bp += set_itext_ichar (bp, READ_UINT_1); |
| 2433 bp += set_itext_ichar (bp, READ_UINT_1); | |
| 428 | 2434 break; |
| 2435 | |
| 2436 case Bvarref+6: | |
| 2437 case Bvarset+6: | |
| 2438 case Bvarbind+6: | |
| 2439 case Bcall+6: | |
| 2440 case Bunbind+6: | |
| 2441 case BlistN: | |
| 2442 case BconcatN: | |
| 2443 case BinsertN: | |
| 867 | 2444 bp += set_itext_ichar (bp, READ_UINT_1); |
| 428 | 2445 break; |
| 2446 | |
| 2447 case Bgoto: | |
| 2448 case Bgotoifnil: | |
| 2449 case Bgotoifnonnil: | |
| 2450 case Bgotoifnilelsepop: | |
| 2451 case Bgotoifnonnilelsepop: | |
| 2452 { | |
| 2453 int jump = READ_INT_2; | |
| 2454 Opbyte buf2[2]; | |
| 2455 Opbyte *buf2p = buf2; | |
| 2456 /* Convert back to program-relative address */ | |
| 2457 WRITE_INT16 (jump + (program_ptr - 2 - program), buf2p); | |
| 867 | 2458 bp += set_itext_ichar (bp, buf2[0]); |
| 2459 bp += set_itext_ichar (bp, buf2[1]); | |
| 428 | 2460 break; |
| 2461 } | |
| 2462 | |
| 2463 case BRgoto: | |
| 2464 case BRgotoifnil: | |
| 2465 case BRgotoifnonnil: | |
| 2466 case BRgotoifnilelsepop: | |
| 2467 case BRgotoifnonnilelsepop: | |
| 867 | 2468 bp += set_itext_ichar (bp, READ_INT_1 + 127); |
| 428 | 2469 break; |
| 2470 | |
| 2471 default: | |
| 2472 break; | |
| 2473 } | |
| 2474 } | |
| 2475 return make_string (buffer, bp - buffer); | |
| 2476 } | |
| 2477 } | |
| 2478 | |
| 2479 Lisp_Object | |
| 2480 compiled_function_constants (Lisp_Compiled_Function *f) | |
| 2481 { | |
| 2482 return f->constants; | |
| 2483 } | |
| 2484 | |
| 2485 int | |
| 2486 compiled_function_stack_depth (Lisp_Compiled_Function *f) | |
| 2487 { | |
| 2488 return f->stack_depth; | |
| 2489 } | |
| 2490 | |
| 2491 /* The compiled_function->doc_and_interactive slot uses the minimal | |
| 2492 number of conses, based on compiled_function->flags; it may take | |
| 2493 any of the following forms: | |
| 2494 | |
| 2495 doc | |
| 2496 interactive | |
| 2497 domain | |
| 2498 (doc . interactive) | |
| 2499 (doc . domain) | |
| 2500 (interactive . domain) | |
| 2501 (doc . (interactive . domain)) | |
| 2502 */ | |
| 2503 | |
| 2504 /* Caller must check flags.interactivep first */ | |
| 2505 Lisp_Object | |
| 2506 compiled_function_interactive (Lisp_Compiled_Function *f) | |
| 2507 { | |
| 2508 assert (f->flags.interactivep); | |
| 2509 if (f->flags.documentationp && f->flags.domainp) | |
| 2510 return XCAR (XCDR (f->doc_and_interactive)); | |
| 2511 else if (f->flags.documentationp) | |
| 2512 return XCDR (f->doc_and_interactive); | |
| 2513 else if (f->flags.domainp) | |
| 2514 return XCAR (f->doc_and_interactive); | |
| 2515 else | |
| 2516 return f->doc_and_interactive; | |
| 2517 } | |
| 2518 | |
| 2519 /* Caller need not check flags.documentationp first */ | |
| 2520 Lisp_Object | |
| 2521 compiled_function_documentation (Lisp_Compiled_Function *f) | |
| 2522 { | |
| 2523 if (! f->flags.documentationp) | |
| 2524 return Qnil; | |
| 2525 else if (f->flags.interactivep && f->flags.domainp) | |
| 2526 return XCAR (f->doc_and_interactive); | |
| 2527 else if (f->flags.interactivep) | |
| 2528 return XCAR (f->doc_and_interactive); | |
| 2529 else if (f->flags.domainp) | |
| 2530 return XCAR (f->doc_and_interactive); | |
| 2531 else | |
| 2532 return f->doc_and_interactive; | |
| 2533 } | |
| 2534 | |
| 2535 /* Caller need not check flags.domainp first */ | |
| 2536 Lisp_Object | |
| 2537 compiled_function_domain (Lisp_Compiled_Function *f) | |
| 2538 { | |
| 2539 if (! f->flags.domainp) | |
| 2540 return Qnil; | |
| 2541 else if (f->flags.documentationp && f->flags.interactivep) | |
| 2542 return XCDR (XCDR (f->doc_and_interactive)); | |
| 2543 else if (f->flags.documentationp) | |
| 2544 return XCDR (f->doc_and_interactive); | |
| 2545 else if (f->flags.interactivep) | |
| 2546 return XCDR (f->doc_and_interactive); | |
| 2547 else | |
| 2548 return f->doc_and_interactive; | |
| 2549 } | |
| 2550 | |
| 2551 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
| 2552 | |
| 2553 Lisp_Object | |
| 2554 compiled_function_annotation (Lisp_Compiled_Function *f) | |
| 2555 { | |
| 2556 return f->annotated; | |
| 2557 } | |
| 2558 | |
| 2559 #endif | |
| 2560 | |
| 2561 /* used only by Snarf-documentation; there must be doc already. */ | |
| 2562 void | |
| 2563 set_compiled_function_documentation (Lisp_Compiled_Function *f, | |
| 2564 Lisp_Object new_doc) | |
| 2565 { | |
| 2566 assert (f->flags.documentationp); | |
| 2567 assert (INTP (new_doc) || STRINGP (new_doc)); | |
| 2568 | |
| 2569 if (f->flags.interactivep && f->flags.domainp) | |
| 2570 XCAR (f->doc_and_interactive) = new_doc; | |
| 2571 else if (f->flags.interactivep) | |
| 2572 XCAR (f->doc_and_interactive) = new_doc; | |
| 2573 else if (f->flags.domainp) | |
| 2574 XCAR (f->doc_and_interactive) = new_doc; | |
| 2575 else | |
| 2576 f->doc_and_interactive = new_doc; | |
| 2577 } | |
| 2578 | |
| 2579 | |
| 2580 DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /* | |
| 2581 Return the argument list of the compiled-function object FUNCTION. | |
| 2582 */ | |
| 2583 (function)) | |
| 2584 { | |
| 2585 CHECK_COMPILED_FUNCTION (function); | |
| 2586 return compiled_function_arglist (XCOMPILED_FUNCTION (function)); | |
| 2587 } | |
| 2588 | |
| 2589 DEFUN ("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /* | |
| 2590 Return the byte-opcode string of the compiled-function object FUNCTION. | |
| 2591 */ | |
| 2592 (function)) | |
| 2593 { | |
| 2594 CHECK_COMPILED_FUNCTION (function); | |
| 2595 return compiled_function_instructions (XCOMPILED_FUNCTION (function)); | |
| 2596 } | |
| 2597 | |
| 2598 DEFUN ("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /* | |
| 2599 Return the constants vector of the compiled-function object FUNCTION. | |
| 2600 */ | |
| 2601 (function)) | |
| 2602 { | |
| 2603 CHECK_COMPILED_FUNCTION (function); | |
| 2604 return compiled_function_constants (XCOMPILED_FUNCTION (function)); | |
| 2605 } | |
| 2606 | |
| 2607 DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /* | |
| 444 | 2608 Return the maximum stack depth of the compiled-function object FUNCTION. |
| 428 | 2609 */ |
| 2610 (function)) | |
| 2611 { | |
| 2612 CHECK_COMPILED_FUNCTION (function); | |
| 2613 return make_int (compiled_function_stack_depth (XCOMPILED_FUNCTION (function))); | |
| 2614 } | |
| 2615 | |
| 2616 DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /* | |
| 2617 Return the doc string of the compiled-function object FUNCTION, if available. | |
| 2618 Functions that had their doc strings snarfed into the DOC file will have | |
| 2619 an integer returned instead of a string. | |
| 2620 */ | |
| 2621 (function)) | |
| 2622 { | |
| 2623 CHECK_COMPILED_FUNCTION (function); | |
| 2624 return compiled_function_documentation (XCOMPILED_FUNCTION (function)); | |
| 2625 } | |
| 2626 | |
| 2627 DEFUN ("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /* | |
| 2628 Return the interactive spec of the compiled-function object FUNCTION, or nil. | |
| 2629 If non-nil, the return value will be a list whose first element is | |
| 2630 `interactive' and whose second element is the interactive spec. | |
| 2631 */ | |
| 2632 (function)) | |
| 2633 { | |
| 2634 CHECK_COMPILED_FUNCTION (function); | |
| 2635 return XCOMPILED_FUNCTION (function)->flags.interactivep | |
| 2636 ? list2 (Qinteractive, | |
| 2637 compiled_function_interactive (XCOMPILED_FUNCTION (function))) | |
| 2638 : Qnil; | |
| 2639 } | |
| 2640 | |
| 2641 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
| 2642 | |
| 826 | 2643 DEFUN ("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /* |
| 428 | 2644 Return the annotation of the compiled-function object FUNCTION, or nil. |
| 2645 The annotation is a piece of information indicating where this | |
| 2646 compiled-function object came from. Generally this will be | |
| 2647 a symbol naming a function; or a string naming a file, if the | |
| 2648 compiled-function object was not defined in a function; or nil, | |
| 2649 if the compiled-function object was not created as a result of | |
| 2650 a `load'. | |
| 2651 */ | |
| 2652 (function)) | |
| 2653 { | |
| 2654 CHECK_COMPILED_FUNCTION (function); | |
| 2655 return compiled_function_annotation (XCOMPILED_FUNCTION (function)); | |
| 2656 } | |
| 2657 | |
| 2658 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */ | |
| 2659 | |
| 2660 DEFUN ("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /* | |
| 2661 Return the domain of the compiled-function object FUNCTION, or nil. | |
| 2662 This is only meaningful if I18N3 was enabled when emacs was compiled. | |
| 2663 */ | |
| 2664 (function)) | |
| 2665 { | |
| 2666 CHECK_COMPILED_FUNCTION (function); | |
| 2667 return XCOMPILED_FUNCTION (function)->flags.domainp | |
| 2668 ? compiled_function_domain (XCOMPILED_FUNCTION (function)) | |
| 2669 : Qnil; | |
| 2670 } | |
| 2671 | |
| 2672 | |
| 2673 | |
| 2674 DEFUN ("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /* | |
| 2675 If the byte code for compiled function FUNCTION is lazy-loaded, fetch it now. | |
| 2676 */ | |
| 2677 (function)) | |
| 2678 { | |
| 2679 Lisp_Compiled_Function *f; | |
| 2680 CHECK_COMPILED_FUNCTION (function); | |
| 2681 f = XCOMPILED_FUNCTION (function); | |
| 2682 | |
| 2683 if (OPAQUEP (f->instructions) || STRINGP (f->instructions)) | |
| 2684 return function; | |
| 2685 | |
| 2686 if (CONSP (f->instructions)) | |
| 2687 { | |
| 2688 Lisp_Object tem = read_doc_string (f->instructions); | |
| 2689 if (!CONSP (tem)) | |
| 563 | 2690 signal_error (Qinvalid_byte_code, |
| 2691 "Invalid lazy-loaded byte code", tem); | |
| 428 | 2692 /* v18 or v19 bytecode file. Need to Ebolify. */ |
| 2693 if (f->flags.ebolified && VECTORP (XCDR (tem))) | |
| 2694 ebolify_bytecode_constants (XCDR (tem)); | |
| 2695 f->instructions = XCAR (tem); | |
| 2696 f->constants = XCDR (tem); | |
| 2697 return function; | |
| 2698 } | |
| 2500 | 2699 ABORT (); |
| 801 | 2700 return Qnil; /* not (usually) reached */ |
| 428 | 2701 } |
| 2702 | |
| 2703 DEFUN ("optimize-compiled-function", Foptimize_compiled_function, 1, 1, 0, /* | |
| 2704 Convert compiled function FUNCTION into an optimized internal form. | |
| 2705 */ | |
| 2706 (function)) | |
| 2707 { | |
| 2708 Lisp_Compiled_Function *f; | |
| 2709 CHECK_COMPILED_FUNCTION (function); | |
| 2710 f = XCOMPILED_FUNCTION (function); | |
| 2711 | |
| 2712 if (OPAQUEP (f->instructions)) /* Already optimized? */ | |
| 2713 return Qnil; | |
| 2714 | |
| 2715 optimize_compiled_function (function); | |
| 2716 return Qnil; | |
| 2717 } | |
| 2718 | |
| 2719 DEFUN ("byte-code", Fbyte_code, 3, 3, 0, /* | |
| 2720 Function used internally in byte-compiled code. | |
| 2721 First argument INSTRUCTIONS is a string of byte code. | |
| 2722 Second argument CONSTANTS is a vector of constants. | |
| 2723 Third argument STACK-DEPTH is the maximum stack depth used in this function. | |
| 2724 If STACK-DEPTH is incorrect, Emacs may crash. | |
| 2725 */ | |
| 2726 (instructions, constants, stack_depth)) | |
| 2727 { | |
| 2728 /* This function can GC */ | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2729 Elemcount varbind_count; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2730 Elemcount program_length; |
| 428 | 2731 Opbyte *program; |
| 2732 | |
| 2733 CHECK_STRING (instructions); | |
| 2734 CHECK_VECTOR (constants); | |
| 2735 CHECK_NATNUM (stack_depth); | |
| 2736 | |
| 2737 /* Optimize the `instructions' string, just like when executing a | |
| 2738 regular compiled function, but don't save it for later since this is | |
| 2739 likely to only be executed once. */ | |
| 2740 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (instructions)); | |
| 2741 optimize_byte_code (instructions, constants, program, | |
| 2742 &program_length, &varbind_count); | |
| 2743 SPECPDL_RESERVE (varbind_count); | |
| 2744 return execute_optimized_program (program, | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2745 #ifdef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2746 program_length, |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2747 #endif |
| 428 | 2748 XINT (stack_depth), |
| 2749 XVECTOR_DATA (constants)); | |
| 2750 } | |
| 2751 | |
| 2752 | |
| 2753 void | |
| 2754 syms_of_bytecode (void) | |
| 2755 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
2720
diff
changeset
|
2756 INIT_LISP_OBJECT (compiled_function); |
| 3092 | 2757 #ifdef NEW_GC |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2758 INIT_LISP_OBJECT (compiled_function_args); |
| 3092 | 2759 #endif /* NEW_GC */ |
| 442 | 2760 |
| 2761 DEFERROR_STANDARD (Qinvalid_byte_code, Qinvalid_state); | |
| 563 | 2762 DEFSYMBOL (Qbyte_code); |
| 2763 DEFSYMBOL_MULTIWORD_PREDICATE (Qcompiled_functionp); | |
| 428 | 2764 |
| 2765 DEFSUBR (Fbyte_code); | |
| 2766 DEFSUBR (Ffetch_bytecode); | |
| 2767 DEFSUBR (Foptimize_compiled_function); | |
| 2768 | |
| 2769 DEFSUBR (Fcompiled_function_p); | |
| 2770 DEFSUBR (Fcompiled_function_instructions); | |
| 2771 DEFSUBR (Fcompiled_function_constants); | |
| 2772 DEFSUBR (Fcompiled_function_stack_depth); | |
| 2773 DEFSUBR (Fcompiled_function_arglist); | |
| 2774 DEFSUBR (Fcompiled_function_interactive); | |
| 2775 DEFSUBR (Fcompiled_function_doc_string); | |
| 2776 DEFSUBR (Fcompiled_function_domain); | |
| 2777 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
| 2778 DEFSUBR (Fcompiled_function_annotation); | |
| 2779 #endif | |
| 2780 | |
| 2781 #ifdef BYTE_CODE_METER | |
| 563 | 2782 DEFSYMBOL (Qbyte_code_meter); |
| 428 | 2783 #endif |
| 2784 } | |
| 2785 | |
| 2786 void | |
| 2787 vars_of_bytecode (void) | |
| 2788 { | |
| 2789 #ifdef BYTE_CODE_METER | |
| 2790 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter /* | |
| 2791 A vector of vectors which holds a histogram of byte code usage. | |
| 2792 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte | |
| 2793 opcode CODE has been executed. | |
| 2794 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0, | |
| 2795 indicates how many times the byte opcodes CODE1 and CODE2 have been | |
| 2796 executed in succession. | |
| 2797 */ ); | |
| 2798 DEFVAR_BOOL ("byte-metering-on", &byte_metering_on /* | |
| 2799 If non-nil, keep profiling information on byte code usage. | |
| 2800 The variable `byte-code-meter' indicates how often each byte opcode is used. | |
| 2801 If a symbol has a property named `byte-code-meter' whose value is an | |
| 2802 integer, it is incremented each time that symbol's function is called. | |
| 2803 */ ); | |
| 2804 | |
| 2805 byte_metering_on = 0; | |
| 2806 Vbyte_code_meter = make_vector (256, Qzero); | |
| 2807 { | |
| 2808 int i = 256; | |
| 2809 while (i--) | |
| 2810 XVECTOR_DATA (Vbyte_code_meter)[i] = make_vector (256, Qzero); | |
| 2811 } | |
| 2812 #endif /* BYTE_CODE_METER */ | |
| 2813 } | |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2814 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2815 #ifdef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2816 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2817 /* Initialize the opcodes in the table that correspond to a base opcode |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2818 plus an offset (except for Bconstant). */ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2819 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2820 static void |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2821 init_opcode_table_multi_op (Opcode op) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2822 { |
| 4970 | 2823 const Ascbyte *basename = opcode_name_table[op]; |
|
4921
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2824 Ascbyte temp[300]; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2825 int i; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2826 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2827 for (i = 1; i < 7; i++) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2828 { |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2829 assert (!opcode_name_table[op + i]); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2830 sprintf (temp, "%s+%d", basename, i); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2831 opcode_name_table[op + i] = xstrdup (temp); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2832 } |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2833 } |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2834 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2835 #endif /* ERROR_CHECK_BYTE_CODE */ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2836 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2837 void |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2838 reinit_vars_of_bytecode (void) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2839 { |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2840 #ifdef ERROR_CHECK_BYTE_CODE |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2841 int i; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2842 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2843 #define OPCODE(sym, val) opcode_name_table[val] = xstrdup (#sym); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2844 #include "bytecode-ops.h" |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2845 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2846 for (i = 0; i < countof (opcode_name_table); i++) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2847 { |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2848 int j; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2849 Ascbyte *name = opcode_name_table[i]; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2850 if (name) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2851 { |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2852 Bytecount len = strlen (name); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2853 /* Prettify the name by converting underscores to hyphens, similar |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2854 to what happens with DEFSYMBOL. */ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2855 for (j = 0; j < len; j++) |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2856 if (name[j] == '_') |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2857 name[j] = '-'; |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2858 } |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2859 } |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2860 |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2861 init_opcode_table_multi_op (Bvarref); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2862 init_opcode_table_multi_op (Bvarset); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2863 init_opcode_table_multi_op (Bvarbind); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2864 init_opcode_table_multi_op (Bcall); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2865 init_opcode_table_multi_op (Bunbind); |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2866 #endif /* ERROR_CHECK_BYTE_CODE */ |
|
17362f371cc2
add more byte-code assertions and better failure output
Ben Wing <ben@xemacs.org>
parents:
4914
diff
changeset
|
2867 } |