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