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