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