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