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