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