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