?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
ChangeLog fix: standardize some bug refs.
[emacs.git] / src / bytecode.c
blobd3c8b470cc3dc070879dc44c8affd8b3314e6af5
1 /* Execution of byte code produced by bytecomp.el.
2 Copyright (C) 1985-1988, 1993, 2000-2014 Free Software Foundation,
3 Inc.
4
5 This file is part of GNU Emacs.
6
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
11
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
19
20 /*
21 hacked on by jwz@lucid.com 17-jun-91
22 o added a compile-time switch to turn on simple sanity checking;
23 o put back the obsolete byte-codes for error-detection;
24 o added a new instruction, unbind_all, which I will use for
25 tail-recursion elimination;
26 o made temp_output_buffer_show be called with the right number
27 of args;
28 o made the new bytecodes be called with args in the right order;
29 o added metering support.
30
31 by Hallvard:
32 o added relative jump instructions;
33 o all conditionals now only do QUIT if they jump.
34 */
35
36 #include <config.h>
37
38 #include "lisp.h"
39 #include "blockinput.h"
40 #include "character.h"
41 #include "buffer.h"
42 #include "keyboard.h"
43 #include "syntax.h"
44 #include "window.h"
45
46 #ifdef CHECK_FRAME_FONT
47 #include "frame.h"
48 #include "xterm.h"
49 #endif
50
51 /*
52 * define BYTE_CODE_SAFE to enable some minor sanity checking (useful for
53 * debugging the byte compiler...)
54 *
55 * define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
56 */
57 /* #define BYTE_CODE_SAFE */
58 /* #define BYTE_CODE_METER */
59
60 /* If BYTE_CODE_THREADED is defined, then the interpreter will be
61 indirect threaded, using GCC's computed goto extension. This code,
62 as currently implemented, is incompatible with BYTE_CODE_SAFE and
63 BYTE_CODE_METER. */
64 #if (defined __GNUC__ && !defined __STRICT_ANSI__ \
65 && !defined BYTE_CODE_SAFE && !defined BYTE_CODE_METER)
66 #define BYTE_CODE_THREADED
67 #endif
68
69 \f
70 #ifdef BYTE_CODE_METER
71
72 Lisp_Object Qbyte_code_meter;
73 #define METER_2(code1, code2) AREF (AREF (Vbyte_code_meter, code1), code2)
74 #define METER_1(code) METER_2 (0, code)
75
76 #define METER_CODE(last_code, this_code) \
77 { \
78 if (byte_metering_on) \
79 { \
80 if (XFASTINT (METER_1 (this_code)) < MOST_POSITIVE_FIXNUM) \
81 XSETFASTINT (METER_1 (this_code), \
82 XFASTINT (METER_1 (this_code)) + 1); \
83 if (last_code \
84 && (XFASTINT (METER_2 (last_code, this_code)) \
85 < MOST_POSITIVE_FIXNUM)) \
86 XSETFASTINT (METER_2 (last_code, this_code), \
87 XFASTINT (METER_2 (last_code, this_code)) + 1); \
88 } \
89 }
90
91 #endif /* BYTE_CODE_METER */
92 \f
93
94 /* Byte codes: */
95
96 #define BYTE_CODES \
97 DEFINE (Bstack_ref, 0) /* Actually, Bstack_ref+0 is not implemented: use dup. */ \
98 DEFINE (Bstack_ref1, 1) \
99 DEFINE (Bstack_ref2, 2) \
100 DEFINE (Bstack_ref3, 3) \
101 DEFINE (Bstack_ref4, 4) \
102 DEFINE (Bstack_ref5, 5) \
103 DEFINE (Bstack_ref6, 6) \
104 DEFINE (Bstack_ref7, 7) \
105 DEFINE (Bvarref, 010) \
106 DEFINE (Bvarref1, 011) \
107 DEFINE (Bvarref2, 012) \
108 DEFINE (Bvarref3, 013) \
109 DEFINE (Bvarref4, 014) \
110 DEFINE (Bvarref5, 015) \
111 DEFINE (Bvarref6, 016) \
112 DEFINE (Bvarref7, 017) \
113 DEFINE (Bvarset, 020) \
114 DEFINE (Bvarset1, 021) \
115 DEFINE (Bvarset2, 022) \
116 DEFINE (Bvarset3, 023) \
117 DEFINE (Bvarset4, 024) \
118 DEFINE (Bvarset5, 025) \
119 DEFINE (Bvarset6, 026) \
120 DEFINE (Bvarset7, 027) \
121 DEFINE (Bvarbind, 030) \
122 DEFINE (Bvarbind1, 031) \
123 DEFINE (Bvarbind2, 032) \
124 DEFINE (Bvarbind3, 033) \
125 DEFINE (Bvarbind4, 034) \
126 DEFINE (Bvarbind5, 035) \
127 DEFINE (Bvarbind6, 036) \
128 DEFINE (Bvarbind7, 037) \
129 DEFINE (Bcall, 040) \
130 DEFINE (Bcall1, 041) \
131 DEFINE (Bcall2, 042) \
132 DEFINE (Bcall3, 043) \
133 DEFINE (Bcall4, 044) \
134 DEFINE (Bcall5, 045) \
135 DEFINE (Bcall6, 046) \
136 DEFINE (Bcall7, 047) \
137 DEFINE (Bunbind, 050) \
138 DEFINE (Bunbind1, 051) \
139 DEFINE (Bunbind2, 052) \
140 DEFINE (Bunbind3, 053) \
141 DEFINE (Bunbind4, 054) \
142 DEFINE (Bunbind5, 055) \
143 DEFINE (Bunbind6, 056) \
144 DEFINE (Bunbind7, 057) \
145 \
146 DEFINE (Bpophandler, 060) \
147 DEFINE (Bpushconditioncase, 061) \
148 DEFINE (Bpushcatch, 062) \
149 \
150 DEFINE (Bnth, 070) \
151 DEFINE (Bsymbolp, 071) \
152 DEFINE (Bconsp, 072) \
153 DEFINE (Bstringp, 073) \
154 DEFINE (Blistp, 074) \
155 DEFINE (Beq, 075) \
156 DEFINE (Bmemq, 076) \
157 DEFINE (Bnot, 077) \
158 DEFINE (Bcar, 0100) \
159 DEFINE (Bcdr, 0101) \
160 DEFINE (Bcons, 0102) \
161 DEFINE (Blist1, 0103) \
162 DEFINE (Blist2, 0104) \
163 DEFINE (Blist3, 0105) \
164 DEFINE (Blist4, 0106) \
165 DEFINE (Blength, 0107) \
166 DEFINE (Baref, 0110) \
167 DEFINE (Baset, 0111) \
168 DEFINE (Bsymbol_value, 0112) \
169 DEFINE (Bsymbol_function, 0113) \
170 DEFINE (Bset, 0114) \
171 DEFINE (Bfset, 0115) \
172 DEFINE (Bget, 0116) \
173 DEFINE (Bsubstring, 0117) \
174 DEFINE (Bconcat2, 0120) \
175 DEFINE (Bconcat3, 0121) \
176 DEFINE (Bconcat4, 0122) \
177 DEFINE (Bsub1, 0123) \
178 DEFINE (Badd1, 0124) \
179 DEFINE (Beqlsign, 0125) \
180 DEFINE (Bgtr, 0126) \
181 DEFINE (Blss, 0127) \
182 DEFINE (Bleq, 0130) \
183 DEFINE (Bgeq, 0131) \
184 DEFINE (Bdiff, 0132) \
185 DEFINE (Bnegate, 0133) \
186 DEFINE (Bplus, 0134) \
187 DEFINE (Bmax, 0135) \
188 DEFINE (Bmin, 0136) \
189 DEFINE (Bmult, 0137) \
190 \
191 DEFINE (Bpoint, 0140) \
192 /* Was Bmark in v17. */ \
193 DEFINE (Bsave_current_buffer, 0141) /* Obsolete. */ \
194 DEFINE (Bgoto_char, 0142) \
195 DEFINE (Binsert, 0143) \
196 DEFINE (Bpoint_max, 0144) \
197 DEFINE (Bpoint_min, 0145) \
198 DEFINE (Bchar_after, 0146) \
199 DEFINE (Bfollowing_char, 0147) \
200 DEFINE (Bpreceding_char, 0150) \
201 DEFINE (Bcurrent_column, 0151) \
202 DEFINE (Bindent_to, 0152) \
203 DEFINE (Beolp, 0154) \
204 DEFINE (Beobp, 0155) \
205 DEFINE (Bbolp, 0156) \
206 DEFINE (Bbobp, 0157) \
207 DEFINE (Bcurrent_buffer, 0160) \
208 DEFINE (Bset_buffer, 0161) \
209 DEFINE (Bsave_current_buffer_1, 0162) /* Replacing Bsave_current_buffer. */ \
210 DEFINE (Binteractive_p, 0164) /* Obsolete since Emacs-24.1. */ \
211 \
212 DEFINE (Bforward_char, 0165) \
213 DEFINE (Bforward_word, 0166) \
214 DEFINE (Bskip_chars_forward, 0167) \
215 DEFINE (Bskip_chars_backward, 0170) \
216 DEFINE (Bforward_line, 0171) \
217 DEFINE (Bchar_syntax, 0172) \
218 DEFINE (Bbuffer_substring, 0173) \
219 DEFINE (Bdelete_region, 0174) \
220 DEFINE (Bnarrow_to_region, 0175) \
221 DEFINE (Bwiden, 0176) \
222 DEFINE (Bend_of_line, 0177) \
223 \
224 DEFINE (Bconstant2, 0201) \
225 DEFINE (Bgoto, 0202) \
226 DEFINE (Bgotoifnil, 0203) \
227 DEFINE (Bgotoifnonnil, 0204) \
228 DEFINE (Bgotoifnilelsepop, 0205) \
229 DEFINE (Bgotoifnonnilelsepop, 0206) \
230 DEFINE (Breturn, 0207) \
231 DEFINE (Bdiscard, 0210) \
232 DEFINE (Bdup, 0211) \
233 \
234 DEFINE (Bsave_excursion, 0212) \
235 DEFINE (Bsave_window_excursion, 0213) /* Obsolete since Emacs-24.1. */ \
236 DEFINE (Bsave_restriction, 0214) \
237 DEFINE (Bcatch, 0215) \
238 \
239 DEFINE (Bunwind_protect, 0216) \
240 DEFINE (Bcondition_case, 0217) \
241 DEFINE (Btemp_output_buffer_setup, 0220) /* Obsolete since Emacs-24.1. */ \
242 DEFINE (Btemp_output_buffer_show, 0221) /* Obsolete since Emacs-24.1. */ \
243 \
244 DEFINE (Bunbind_all, 0222) /* Obsolete. Never used. */ \
245 \
246 DEFINE (Bset_marker, 0223) \
247 DEFINE (Bmatch_beginning, 0224) \
248 DEFINE (Bmatch_end, 0225) \
249 DEFINE (Bupcase, 0226) \
250 DEFINE (Bdowncase, 0227) \
251 \
252 DEFINE (Bstringeqlsign, 0230) \
253 DEFINE (Bstringlss, 0231) \
254 DEFINE (Bequal, 0232) \
255 DEFINE (Bnthcdr, 0233) \
256 DEFINE (Belt, 0234) \
257 DEFINE (Bmember, 0235) \
258 DEFINE (Bassq, 0236) \
259 DEFINE (Bnreverse, 0237) \
260 DEFINE (Bsetcar, 0240) \
261 DEFINE (Bsetcdr, 0241) \
262 DEFINE (Bcar_safe, 0242) \
263 DEFINE (Bcdr_safe, 0243) \
264 DEFINE (Bnconc, 0244) \
265 DEFINE (Bquo, 0245) \
266 DEFINE (Brem, 0246) \
267 DEFINE (Bnumberp, 0247) \
268 DEFINE (Bintegerp, 0250) \
269 \
270 DEFINE (BRgoto, 0252) \
271 DEFINE (BRgotoifnil, 0253) \
272 DEFINE (BRgotoifnonnil, 0254) \
273 DEFINE (BRgotoifnilelsepop, 0255) \
274 DEFINE (BRgotoifnonnilelsepop, 0256) \
275 \
276 DEFINE (BlistN, 0257) \
277 DEFINE (BconcatN, 0260) \
278 DEFINE (BinsertN, 0261) \
279 \
280 /* Bstack_ref is code 0. */ \
281 DEFINE (Bstack_set, 0262) \
282 DEFINE (Bstack_set2, 0263) \
283 DEFINE (BdiscardN, 0266) \
284 \
285 DEFINE (Bconstant, 0300)
286
287 enum byte_code_op
288 {
289 #define DEFINE(name, value) name = value,
290 BYTE_CODES
291 #undef DEFINE
292
293 #ifdef BYTE_CODE_SAFE
294 Bscan_buffer = 0153, /* No longer generated as of v18. */
295 Bset_mark = 0163, /* this loser is no longer generated as of v18 */
296 #endif
297 };
298
299 /* Whether to maintain a `top' and `bottom' field in the stack frame. */
300 #define BYTE_MAINTAIN_TOP (BYTE_CODE_SAFE || BYTE_MARK_STACK)
301 \f
302 /* Structure describing a value stack used during byte-code execution
303 in Fbyte_code. */
304
305 struct byte_stack
306 {
307 /* Program counter. This points into the byte_string below
308 and is relocated when that string is relocated. */
309 const unsigned char *pc;
310
311 /* Top and bottom of stack. The bottom points to an area of memory
312 allocated with alloca in Fbyte_code. */
313 #if BYTE_MAINTAIN_TOP
314 Lisp_Object *top, *bottom;
315 #endif
316
317 /* The string containing the byte-code, and its current address.
318 Storing this here protects it from GC because mark_byte_stack
319 marks it. */
320 Lisp_Object byte_string;
321 const unsigned char *byte_string_start;
322
323 #if BYTE_MARK_STACK
324 /* The vector of constants used during byte-code execution. Storing
325 this here protects it from GC because mark_byte_stack marks it. */
326 Lisp_Object constants;
327 #endif
328
329 /* Next entry in byte_stack_list. */
330 struct byte_stack *next;
331 };
332
333 /* A list of currently active byte-code execution value stacks.
334 Fbyte_code adds an entry to the head of this list before it starts
335 processing byte-code, and it removes the entry again when it is
336 done. Signaling an error truncates the list analogous to
337 gcprolist. */
338
339 struct byte_stack *byte_stack_list;
340
341 \f
342 /* Mark objects on byte_stack_list. Called during GC. */
343
344 #if BYTE_MARK_STACK
345 void
346 mark_byte_stack (void)
347 {
348 struct byte_stack *stack;
349 Lisp_Object *obj;
350
351 for (stack = byte_stack_list; stack; stack = stack->next)
352 {
353 /* If STACK->top is null here, this means there's an opcode in
354 Fbyte_code that wasn't expected to GC, but did. To find out
355 which opcode this is, record the value of `stack', and walk
356 up the stack in a debugger, stopping in frames of Fbyte_code.
357 The culprit is found in the frame of Fbyte_code where the
358 address of its local variable `stack' is equal to the
359 recorded value of `stack' here. */
360 eassert (stack->top);
361
362 for (obj = stack->bottom; obj <= stack->top; ++obj)
363 mark_object (*obj);
364
365 mark_object (stack->byte_string);
366 mark_object (stack->constants);
367 }
368 }
369 #endif
370
371 /* Unmark objects in the stacks on byte_stack_list. Relocate program
372 counters. Called when GC has completed. */
373
374 void
375 unmark_byte_stack (void)
376 {
377 struct byte_stack *stack;
378
379 for (stack = byte_stack_list; stack; stack = stack->next)
380 {
381 if (stack->byte_string_start != SDATA (stack->byte_string))
382 {
383 ptrdiff_t offset = stack->pc - stack->byte_string_start;
384 stack->byte_string_start = SDATA (stack->byte_string);
385 stack->pc = stack->byte_string_start + offset;
386 }
387 }
388 }
389
390 \f
391 /* Fetch the next byte from the bytecode stream. */
392
393 #ifdef BYTE_CODE_SAFE
394 #define FETCH (eassert (stack.byte_string_start == SDATA (stack.byte_string)), *stack.pc++)
395 #else
396 #define FETCH *stack.pc++
397 #endif
398
399 /* Fetch two bytes from the bytecode stream and make a 16-bit number
400 out of them. */
401
402 #define FETCH2 (op = FETCH, op + (FETCH << 8))
403
404 /* Push x onto the execution stack. This used to be #define PUSH(x)
405 (*++stackp = (x)) This oddity is necessary because Alliant can't be
406 bothered to compile the preincrement operator properly, as of 4/91.
407 -JimB */
408
409 #define PUSH(x) (top++, *top = (x))
410
411 /* Pop a value off the execution stack. */
412
413 #define POP (*top--)
414
415 /* Discard n values from the execution stack. */
416
417 #define DISCARD(n) (top -= (n))
418
419 /* Get the value which is at the top of the execution stack, but don't
420 pop it. */
421
422 #define TOP (*top)
423
424 /* Actions that must be performed before and after calling a function
425 that might GC. */
426
427 #if !BYTE_MAINTAIN_TOP
428 #define BEFORE_POTENTIAL_GC() ((void)0)
429 #define AFTER_POTENTIAL_GC() ((void)0)
430 #else
431 #define BEFORE_POTENTIAL_GC() stack.top = top
432 #define AFTER_POTENTIAL_GC() stack.top = NULL
433 #endif
434
435 /* Garbage collect if we have consed enough since the last time.
436 We do this at every branch, to avoid loops that never GC. */
437
438 #define MAYBE_GC() \
439 do { \
440 BEFORE_POTENTIAL_GC (); \
441 maybe_gc (); \
442 AFTER_POTENTIAL_GC (); \
443 } while (0)
444
445 /* Check for jumping out of range. */
446
447 #ifdef BYTE_CODE_SAFE
448
449 #define CHECK_RANGE(ARG) \
450 if (ARG >= bytestr_length) emacs_abort ()
451
452 #else /* not BYTE_CODE_SAFE */
453
454 #define CHECK_RANGE(ARG)
455
456 #endif /* not BYTE_CODE_SAFE */
457
458 /* A version of the QUIT macro which makes sure that the stack top is
459 set before signaling `quit'. */
460
461 #define BYTE_CODE_QUIT \
462 do { \
463 if (!NILP (Vquit_flag) && NILP (Vinhibit_quit)) \
464 { \
465 Lisp_Object flag = Vquit_flag; \
466 Vquit_flag = Qnil; \
467 BEFORE_POTENTIAL_GC (); \
468 if (EQ (Vthrow_on_input, flag)) \
469 Fthrow (Vthrow_on_input, Qt); \
470 Fsignal (Qquit, Qnil); \
471 AFTER_POTENTIAL_GC (); \
472 } \
473 else if (pending_signals) \
474 process_pending_signals (); \
475 } while (0)
476
477
478 DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0,
479 doc: /* Function used internally in byte-compiled code.
480 The first argument, BYTESTR, is a string of byte code;
481 the second, VECTOR, a vector of constants;
482 the third, MAXDEPTH, the maximum stack depth used in this function.
483 If the third argument is incorrect, Emacs may crash. */)
484 (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth)
485 {
486 return exec_byte_code (bytestr, vector, maxdepth, Qnil, 0, NULL);
487 }
488
489 static void
490 bcall0 (Lisp_Object f)
491 {
492 Ffuncall (1, &f);
493 }
494
495 /* Execute the byte-code in BYTESTR. VECTOR is the constant vector, and
496 MAXDEPTH is the maximum stack depth used (if MAXDEPTH is incorrect,
497 emacs may crash!). If ARGS_TEMPLATE is non-nil, it should be a lisp
498 argument list (including &rest, &optional, etc.), and ARGS, of size
499 NARGS, should be a vector of the actual arguments. The arguments in
500 ARGS are pushed on the stack according to ARGS_TEMPLATE before
501 executing BYTESTR. */
502
503 Lisp_Object
504 exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
505 Lisp_Object args_template, ptrdiff_t nargs, Lisp_Object *args)
506 {
507 ptrdiff_t count = SPECPDL_INDEX ();
508 #ifdef BYTE_CODE_METER
509 int volatile this_op = 0;
510 int prev_op;
511 #endif
512 int op;
513 /* Lisp_Object v1, v2; */
514 Lisp_Object *vectorp;
515 #ifdef BYTE_CODE_SAFE
516 ptrdiff_t const_length;
517 Lisp_Object *stacke;
518 ptrdiff_t bytestr_length;
519 #endif
520 struct byte_stack stack;
521 Lisp_Object *top;
522 Lisp_Object result;
523 enum handlertype type;
524
525 #if 0 /* CHECK_FRAME_FONT */
526 {
527 struct frame *f = SELECTED_FRAME ();
528 if (FRAME_X_P (f)
529 && FRAME_FONT (f)->direction != 0
530 && FRAME_FONT (f)->direction != 1)
531 emacs_abort ();
532 }
533 #endif
534
535 CHECK_STRING (bytestr);
536 CHECK_VECTOR (vector);
537 CHECK_NATNUM (maxdepth);
538
539 #ifdef BYTE_CODE_SAFE
540 const_length = ASIZE (vector);
541 #endif
542
543 if (STRING_MULTIBYTE (bytestr))
544 /* BYTESTR must have been produced by Emacs 20.2 or the earlier
545 because they produced a raw 8-bit string for byte-code and now
546 such a byte-code string is loaded as multibyte while raw 8-bit
547 characters converted to multibyte form. Thus, now we must
548 convert them back to the originally intended unibyte form. */
549 bytestr = Fstring_as_unibyte (bytestr);
550
551 #ifdef BYTE_CODE_SAFE
552 bytestr_length = SBYTES (bytestr);
553 #endif
554 vectorp = XVECTOR (vector)->contents;
555
556 stack.byte_string = bytestr;
557 stack.pc = stack.byte_string_start = SDATA (bytestr);
558 #if BYTE_MARK_STACK
559 stack.constants = vector;
560 #endif
561 if (MAX_ALLOCA / word_size <= XFASTINT (maxdepth))
562 memory_full (SIZE_MAX);
563 top = alloca ((XFASTINT (maxdepth) + 1) * sizeof *top);
564 #if BYTE_MAINTAIN_TOP
565 stack.bottom = top + 1;
566 stack.top = NULL;
567 #endif
568 stack.next = byte_stack_list;
569 byte_stack_list = &stack;
570
571 #ifdef BYTE_CODE_SAFE
572 stacke = stack.bottom - 1 + XFASTINT (maxdepth);
573 #endif
574
575 if (INTEGERP (args_template))
576 {
577 ptrdiff_t at = XINT (args_template);
578 bool rest = (at & 128) != 0;
579 int mandatory = at & 127;
580 ptrdiff_t nonrest = at >> 8;
581 eassert (mandatory <= nonrest);
582 if (nargs <= nonrest)
583 {
584 ptrdiff_t i;
585 for (i = 0 ; i < nargs; i++, args++)
586 PUSH (*args);
587 if (nargs < mandatory)
588 /* Too few arguments. */
589 Fsignal (Qwrong_number_of_arguments,
590 list2 (Fcons (make_number (mandatory),
591 rest ? Qand_rest : make_number (nonrest)),
592 make_number (nargs)));
593 else
594 {
595 for (; i < nonrest; i++)
596 PUSH (Qnil);
597 if (rest)
598 PUSH (Qnil);
599 }
600 }
601 else if (rest)
602 {
603 ptrdiff_t i;
604 for (i = 0 ; i < nonrest; i++, args++)
605 PUSH (*args);
606 PUSH (Flist (nargs - nonrest, args));
607 }
608 else
609 /* Too many arguments. */
610 Fsignal (Qwrong_number_of_arguments,
611 list2 (Fcons (make_number (mandatory), make_number (nonrest)),
612 make_number (nargs)));
613 }
614 else if (! NILP (args_template))
615 /* We should push some arguments on the stack. */
616 {
617 error ("Unknown args template!");
618 }
619
620 while (1)
621 {
622 #ifdef BYTE_CODE_SAFE
623 if (top > stacke)
624 emacs_abort ();
625 else if (top < stack.bottom - 1)
626 emacs_abort ();
627 #endif
628
629 #ifdef BYTE_CODE_METER
630 prev_op = this_op;
631 this_op = op = FETCH;
632 METER_CODE (prev_op, op);
633 #else
634 #ifndef BYTE_CODE_THREADED
635 op = FETCH;
636 #endif
637 #endif
638
639 /* The interpreter can be compiled one of two ways: as an
640 ordinary switch-based interpreter, or as a threaded
641 interpreter. The threaded interpreter relies on GCC's
642 computed goto extension, so it is not available everywhere.
643 Threading provides a performance boost. These macros are how
644 we allow the code to be compiled both ways. */
645 #ifdef BYTE_CODE_THREADED
646 /* The CASE macro introduces an instruction's body. It is
647 either a label or a case label. */
648 #define CASE(OP) insn_ ## OP
649 /* NEXT is invoked at the end of an instruction to go to the
650 next instruction. It is either a computed goto, or a
651 plain break. */
652 #define NEXT goto *(targets[op = FETCH])
653 /* FIRST is like NEXT, but is only used at the start of the
654 interpreter body. In the switch-based interpreter it is the
655 switch, so the threaded definition must include a semicolon. */
656 #define FIRST NEXT;
657 /* Most cases are labeled with the CASE macro, above.
658 CASE_DEFAULT is one exception; it is used if the interpreter
659 being built requires a default case. The threaded
660 interpreter does not, because the dispatch table is
661 completely filled. */
662 #define CASE_DEFAULT
663 /* This introduces an instruction that is known to call abort. */
664 #define CASE_ABORT CASE (Bstack_ref): CASE (default)
665 #else
666 /* See above for the meaning of the various defines. */
667 #define CASE(OP) case OP
668 #define NEXT break
669 #define FIRST switch (op)
670 #define CASE_DEFAULT case 255: default:
671 #define CASE_ABORT case 0
672 #endif
673
674 #ifdef BYTE_CODE_THREADED
675
676 /* A convenience define that saves us a lot of typing and makes
677 the table clearer. */
678 #define LABEL(OP) [OP] = &&insn_ ## OP
679
680 #if 4 < __GNUC__ + (6 <= __GNUC_MINOR__)
681 # pragma GCC diagnostic push
682 # pragma GCC diagnostic ignored "-Woverride-init"
683 #elif defined __clang__
684 # pragma GCC diagnostic push
685 # pragma GCC diagnostic ignored "-Winitializer-overrides"
686 #endif
687
688 /* This is the dispatch table for the threaded interpreter. */
689 static const void *const targets[256] =
690 {
691 [0 ... (Bconstant - 1)] = &&insn_default,
692 [Bconstant ... 255] = &&insn_Bconstant,
693
694 #define DEFINE(name, value) LABEL (name) ,
695 BYTE_CODES
696 #undef DEFINE
697 };
698
699 #if 4 < __GNUC__ + (6 <= __GNUC_MINOR__) || defined __clang__
700 # pragma GCC diagnostic pop
701 #endif
702
703 #endif
704
705
706 FIRST
707 {
708 CASE (Bvarref7):
709 op = FETCH2;
710 goto varref;
711
712 CASE (Bvarref):
713 CASE (Bvarref1):
714 CASE (Bvarref2):
715 CASE (Bvarref3):
716 CASE (Bvarref4):
717 CASE (Bvarref5):
718 op = op - Bvarref;
719 goto varref;
720
721 /* This seems to be the most frequently executed byte-code
722 among the Bvarref's, so avoid a goto here. */
723 CASE (Bvarref6):
724 op = FETCH;
725 varref:
726 {
727 Lisp_Object v1, v2;
728
729 v1 = vectorp[op];
730 if (SYMBOLP (v1))
731 {
732 if (XSYMBOL (v1)->redirect != SYMBOL_PLAINVAL
733 || (v2 = SYMBOL_VAL (XSYMBOL (v1)),
734 EQ (v2, Qunbound)))
735 {
736 BEFORE_POTENTIAL_GC ();
737 v2 = Fsymbol_value (v1);
738 AFTER_POTENTIAL_GC ();
739 }
740 }
741 else
742 {
743 BEFORE_POTENTIAL_GC ();
744 v2 = Fsymbol_value (v1);
745 AFTER_POTENTIAL_GC ();
746 }
747 PUSH (v2);
748 NEXT;
749 }
750
751 CASE (Bgotoifnil):
752 {
753 Lisp_Object v1;
754 MAYBE_GC ();
755 op = FETCH2;
756 v1 = POP;
757 if (NILP (v1))
758 {
759 BYTE_CODE_QUIT;
760 CHECK_RANGE (op);
761 stack.pc = stack.byte_string_start + op;
762 }
763 NEXT;
764 }
765
766 CASE (Bcar):
767 {
768 Lisp_Object v1;
769 v1 = TOP;
770 if (CONSP (v1))
771 TOP = XCAR (v1);
772 else if (NILP (v1))
773 TOP = Qnil;
774 else
775 {
776 BEFORE_POTENTIAL_GC ();
777 wrong_type_argument (Qlistp, v1);
778 }
779 NEXT;
780 }
781
782 CASE (Beq):
783 {
784 Lisp_Object v1;
785 v1 = POP;
786 TOP = EQ (v1, TOP) ? Qt : Qnil;
787 NEXT;
788 }
789
790 CASE (Bmemq):
791 {
792 Lisp_Object v1;
793 BEFORE_POTENTIAL_GC ();
794 v1 = POP;
795 TOP = Fmemq (TOP, v1);
796 AFTER_POTENTIAL_GC ();
797 NEXT;
798 }
799
800 CASE (Bcdr):
801 {
802 Lisp_Object v1;
803 v1 = TOP;
804 if (CONSP (v1))
805 TOP = XCDR (v1);
806 else if (NILP (v1))
807 TOP = Qnil;
808 else
809 {
810 BEFORE_POTENTIAL_GC ();
811 wrong_type_argument (Qlistp, v1);
812 }
813 NEXT;
814 }
815
816 CASE (Bvarset):
817 CASE (Bvarset1):
818 CASE (Bvarset2):
819 CASE (Bvarset3):
820 CASE (Bvarset4):
821 CASE (Bvarset5):
822 op -= Bvarset;
823 goto varset;
824
825 CASE (Bvarset7):
826 op = FETCH2;
827 goto varset;
828
829 CASE (Bvarset6):
830 op = FETCH;
831 varset:
832 {
833 Lisp_Object sym, val;
834
835 sym = vectorp[op];
836 val = TOP;
837
838 /* Inline the most common case. */
839 if (SYMBOLP (sym)
840 && !EQ (val, Qunbound)
841 && !XSYMBOL (sym)->redirect
842 && !SYMBOL_CONSTANT_P (sym))
843 SET_SYMBOL_VAL (XSYMBOL (sym), val);
844 else
845 {
846 BEFORE_POTENTIAL_GC ();
847 set_internal (sym, val, Qnil, 0);
848 AFTER_POTENTIAL_GC ();
849 }
850 }
851 (void) POP;
852 NEXT;
853
854 CASE (Bdup):
855 {
856 Lisp_Object v1;
857 v1 = TOP;
858 PUSH (v1);
859 NEXT;
860 }
861
862 /* ------------------ */
863
864 CASE (Bvarbind6):
865 op = FETCH;
866 goto varbind;
867
868 CASE (Bvarbind7):
869 op = FETCH2;
870 goto varbind;
871
872 CASE (Bvarbind):
873 CASE (Bvarbind1):
874 CASE (Bvarbind2):
875 CASE (Bvarbind3):
876 CASE (Bvarbind4):
877 CASE (Bvarbind5):
878 op -= Bvarbind;
879 varbind:
880 /* Specbind can signal and thus GC. */
881 BEFORE_POTENTIAL_GC ();
882 specbind (vectorp[op], POP);
883 AFTER_POTENTIAL_GC ();
884 NEXT;
885
886 CASE (Bcall6):
887 op = FETCH;
888 goto docall;
889
890 CASE (Bcall7):
891 op = FETCH2;
892 goto docall;
893
894 CASE (Bcall):
895 CASE (Bcall1):
896 CASE (Bcall2):
897 CASE (Bcall3):
898 CASE (Bcall4):
899 CASE (Bcall5):
900 op -= Bcall;
901 docall:
902 {
903 BEFORE_POTENTIAL_GC ();
904 DISCARD (op);
905 #ifdef BYTE_CODE_METER
906 if (byte_metering_on && SYMBOLP (TOP))
907 {
908 Lisp_Object v1, v2;
909
910 v1 = TOP;
911 v2 = Fget (v1, Qbyte_code_meter);
912 if (INTEGERP (v2)
913 && XINT (v2) < MOST_POSITIVE_FIXNUM)
914 {
915 XSETINT (v2, XINT (v2) + 1);
916 Fput (v1, Qbyte_code_meter, v2);
917 }
918 }
919 #endif
920 TOP = Ffuncall (op + 1, &TOP);
921 AFTER_POTENTIAL_GC ();
922 NEXT;
923 }
924
925 CASE (Bunbind6):
926 op = FETCH;
927 goto dounbind;
928
929 CASE (Bunbind7):
930 op = FETCH2;
931 goto dounbind;
932
933 CASE (Bunbind):
934 CASE (Bunbind1):
935 CASE (Bunbind2):
936 CASE (Bunbind3):
937 CASE (Bunbind4):
938 CASE (Bunbind5):
939 op -= Bunbind;
940 dounbind:
941 BEFORE_POTENTIAL_GC ();
942 unbind_to (SPECPDL_INDEX () - op, Qnil);
943 AFTER_POTENTIAL_GC ();
944 NEXT;
945
946 CASE (Bunbind_all): /* Obsolete. Never used. */
947 /* To unbind back to the beginning of this frame. Not used yet,
948 but will be needed for tail-recursion elimination. */
949 BEFORE_POTENTIAL_GC ();
950 unbind_to (count, Qnil);
951 AFTER_POTENTIAL_GC ();
952 NEXT;
953
954 CASE (Bgoto):
955 MAYBE_GC ();
956 BYTE_CODE_QUIT;
957 op = FETCH2; /* pc = FETCH2 loses since FETCH2 contains pc++ */
958 CHECK_RANGE (op);
959 stack.pc = stack.byte_string_start + op;
960 NEXT;
961
962 CASE (Bgotoifnonnil):
963 {
964 Lisp_Object v1;
965 MAYBE_GC ();
966 op = FETCH2;
967 v1 = POP;
968 if (!NILP (v1))
969 {
970 BYTE_CODE_QUIT;
971 CHECK_RANGE (op);
972 stack.pc = stack.byte_string_start + op;
973 }
974 NEXT;
975 }
976
977 CASE (Bgotoifnilelsepop):
978 MAYBE_GC ();
979 op = FETCH2;
980 if (NILP (TOP))
981 {
982 BYTE_CODE_QUIT;
983 CHECK_RANGE (op);
984 stack.pc = stack.byte_string_start + op;
985 }
986 else DISCARD (1);
987 NEXT;
988
989 CASE (Bgotoifnonnilelsepop):
990 MAYBE_GC ();
991 op = FETCH2;
992 if (!NILP (TOP))
993 {
994 BYTE_CODE_QUIT;
995 CHECK_RANGE (op);
996 stack.pc = stack.byte_string_start + op;
997 }
998 else DISCARD (1);
999 NEXT;
1000
1001 CASE (BRgoto):
1002 MAYBE_GC ();
1003 BYTE_CODE_QUIT;
1004 stack.pc += (int) *stack.pc - 127;
1005 NEXT;
1006
1007 CASE (BRgotoifnil):
1008 {
1009 Lisp_Object v1;
1010 MAYBE_GC ();
1011 v1 = POP;
1012 if (NILP (v1))
1013 {
1014 BYTE_CODE_QUIT;
1015 stack.pc += (int) *stack.pc - 128;
1016 }
1017 stack.pc++;
1018 NEXT;
1019 }
1020
1021 CASE (BRgotoifnonnil):
1022 {
1023 Lisp_Object v1;
1024 MAYBE_GC ();
1025 v1 = POP;
1026 if (!NILP (v1))
1027 {
1028 BYTE_CODE_QUIT;
1029 stack.pc += (int) *stack.pc - 128;
1030 }
1031 stack.pc++;
1032 NEXT;
1033 }
1034
1035 CASE (BRgotoifnilelsepop):
1036 MAYBE_GC ();
1037 op = *stack.pc++;
1038 if (NILP (TOP))
1039 {
1040 BYTE_CODE_QUIT;
1041 stack.pc += op - 128;
1042 }
1043 else DISCARD (1);
1044 NEXT;
1045
1046 CASE (BRgotoifnonnilelsepop):
1047 MAYBE_GC ();
1048 op = *stack.pc++;
1049 if (!NILP (TOP))
1050 {
1051 BYTE_CODE_QUIT;
1052 stack.pc += op - 128;
1053 }
1054 else DISCARD (1);
1055 NEXT;
1056
1057 CASE (Breturn):
1058 result = POP;
1059 goto exit;
1060
1061 CASE (Bdiscard):
1062 DISCARD (1);
1063 NEXT;
1064
1065 CASE (Bconstant2):
1066 PUSH (vectorp[FETCH2]);
1067 NEXT;
1068
1069 CASE (Bsave_excursion):
1070 record_unwind_protect (save_excursion_restore,
1071 save_excursion_save ());
1072 NEXT;
1073
1074 CASE (Bsave_current_buffer): /* Obsolete since ??. */
1075 CASE (Bsave_current_buffer_1):
1076 record_unwind_current_buffer ();
1077 NEXT;
1078
1079 CASE (Bsave_window_excursion): /* Obsolete since 24.1. */
1080 {
1081 ptrdiff_t count1 = SPECPDL_INDEX ();
1082 record_unwind_protect (restore_window_configuration,
1083 Fcurrent_window_configuration (Qnil));
1084 BEFORE_POTENTIAL_GC ();
1085 TOP = Fprogn (TOP);
1086 unbind_to (count1, TOP);
1087 AFTER_POTENTIAL_GC ();
1088 NEXT;
1089 }
1090
1091 CASE (Bsave_restriction):
1092 record_unwind_protect (save_restriction_restore,
1093 save_restriction_save ());
1094 NEXT;
1095
1096 CASE (Bcatch): /* Obsolete since 24.4. */
1097 {
1098 Lisp_Object v1;
1099 BEFORE_POTENTIAL_GC ();
1100 v1 = POP;
1101 TOP = internal_catch (TOP, eval_sub, v1);
1102 AFTER_POTENTIAL_GC ();
1103 NEXT;
1104 }
1105
1106 CASE (Bpushcatch): /* New in 24.4. */
1107 type = CATCHER;
1108 goto pushhandler;
1109 CASE (Bpushconditioncase): /* New in 24.4. */
1110 {
1111 struct handler *c;
1112 Lisp_Object tag;
1113 int dest;
1114
1115 type = CONDITION_CASE;
1116 pushhandler:
1117 tag = POP;
1118 dest = FETCH2;
1119
1120 PUSH_HANDLER (c, tag, type);
1121 c->bytecode_dest = dest;
1122 c->bytecode_top = top;
1123
1124 if (sys_setjmp (c->jmp))
1125 {
1126 struct handler *c = handlerlist;
1127 int dest;
1128 top = c->bytecode_top;
1129 dest = c->bytecode_dest;
1130 handlerlist = c->next;
1131 PUSH (c->val);
1132 CHECK_RANGE (dest);
1133 /* Might have been re-set by longjmp! */
1134 stack.byte_string_start = SDATA (stack.byte_string);
1135 stack.pc = stack.byte_string_start + dest;
1136 }
1137
1138 NEXT;
1139 }
1140
1141 CASE (Bpophandler): /* New in 24.4. */
1142 {
1143 handlerlist = handlerlist->next;
1144 NEXT;
1145 }
1146
1147 CASE (Bunwind_protect): /* FIXME: avoid closure for lexbind. */
1148 {
1149 Lisp_Object handler = POP;
1150 /* Support for a function here is new in 24.4. */
1151 record_unwind_protect (NILP (Ffunctionp (handler))
1152 ? unwind_body : bcall0,
1153 handler);
1154 NEXT;
1155 }
1156
1157 CASE (Bcondition_case): /* Obsolete since 24.4. */
1158 {
1159 Lisp_Object handlers, body;
1160 handlers = POP;
1161 body = POP;
1162 BEFORE_POTENTIAL_GC ();
1163 TOP = internal_lisp_condition_case (TOP, body, handlers);
1164 AFTER_POTENTIAL_GC ();
1165 NEXT;
1166 }
1167
1168 CASE (Btemp_output_buffer_setup): /* Obsolete since 24.1. */
1169 BEFORE_POTENTIAL_GC ();
1170 CHECK_STRING (TOP);
1171 temp_output_buffer_setup (SSDATA (TOP));
1172 AFTER_POTENTIAL_GC ();
1173 TOP = Vstandard_output;
1174 NEXT;
1175
1176 CASE (Btemp_output_buffer_show): /* Obsolete since 24.1. */
1177 {
1178 Lisp_Object v1;
1179 BEFORE_POTENTIAL_GC ();
1180 v1 = POP;
1181 temp_output_buffer_show (TOP);
1182 TOP = v1;
1183 /* pop binding of standard-output */
1184 unbind_to (SPECPDL_INDEX () - 1, Qnil);
1185 AFTER_POTENTIAL_GC ();
1186 NEXT;
1187 }
1188
1189 CASE (Bnth):
1190 {
1191 Lisp_Object v1, v2;
1192 EMACS_INT n;
1193 BEFORE_POTENTIAL_GC ();
1194 v1 = POP;
1195 v2 = TOP;
1196 CHECK_NUMBER (v2);
1197 n = XINT (v2);
1198 immediate_quit = 1;
1199 while (--n >= 0 && CONSP (v1))
1200 v1 = XCDR (v1);
1201 immediate_quit = 0;
1202 TOP = CAR (v1);
1203 AFTER_POTENTIAL_GC ();
1204 NEXT;
1205 }
1206
1207 CASE (Bsymbolp):
1208 TOP = SYMBOLP (TOP) ? Qt : Qnil;
1209 NEXT;
1210
1211 CASE (Bconsp):
1212 TOP = CONSP (TOP) ? Qt : Qnil;
1213 NEXT;
1214
1215 CASE (Bstringp):
1216 TOP = STRINGP (TOP) ? Qt : Qnil;
1217 NEXT;
1218
1219 CASE (Blistp):
1220 TOP = CONSP (TOP) || NILP (TOP) ? Qt : Qnil;
1221 NEXT;
1222
1223 CASE (Bnot):
1224 TOP = NILP (TOP) ? Qt : Qnil;
1225 NEXT;
1226
1227 CASE (Bcons):
1228 {
1229 Lisp_Object v1;
1230 v1 = POP;
1231 TOP = Fcons (TOP, v1);
1232 NEXT;
1233 }
1234
1235 CASE (Blist1):
1236 TOP = list1 (TOP);
1237 NEXT;
1238
1239 CASE (Blist2):
1240 {
1241 Lisp_Object v1;
1242 v1 = POP;
1243 TOP = list2 (TOP, v1);
1244 NEXT;
1245 }
1246
1247 CASE (Blist3):
1248 DISCARD (2);
1249 TOP = Flist (3, &TOP);
1250 NEXT;
1251
1252 CASE (Blist4):
1253 DISCARD (3);
1254 TOP = Flist (4, &TOP);
1255 NEXT;
1256
1257 CASE (BlistN):
1258 op = FETCH;
1259 DISCARD (op - 1);
1260 TOP = Flist (op, &TOP);
1261 NEXT;
1262
1263 CASE (Blength):
1264 BEFORE_POTENTIAL_GC ();
1265 TOP = Flength (TOP);
1266 AFTER_POTENTIAL_GC ();
1267 NEXT;
1268
1269 CASE (Baref):
1270 {
1271 Lisp_Object v1;
1272 BEFORE_POTENTIAL_GC ();
1273 v1 = POP;
1274 TOP = Faref (TOP, v1);
1275 AFTER_POTENTIAL_GC ();
1276 NEXT;
1277 }
1278
1279 CASE (Baset):
1280 {
1281 Lisp_Object v1, v2;
1282 BEFORE_POTENTIAL_GC ();
1283 v2 = POP; v1 = POP;
1284 TOP = Faset (TOP, v1, v2);
1285 AFTER_POTENTIAL_GC ();
1286 NEXT;
1287 }
1288
1289 CASE (Bsymbol_value):
1290 BEFORE_POTENTIAL_GC ();
1291 TOP = Fsymbol_value (TOP);
1292 AFTER_POTENTIAL_GC ();
1293 NEXT;
1294
1295 CASE (Bsymbol_function):
1296 BEFORE_POTENTIAL_GC ();
1297 TOP = Fsymbol_function (TOP);
1298 AFTER_POTENTIAL_GC ();
1299 NEXT;
1300
1301 CASE (Bset):
1302 {
1303 Lisp_Object v1;
1304 BEFORE_POTENTIAL_GC ();
1305 v1 = POP;
1306 TOP = Fset (TOP, v1);
1307 AFTER_POTENTIAL_GC ();
1308 NEXT;
1309 }
1310
1311 CASE (Bfset):
1312 {
1313 Lisp_Object v1;
1314 BEFORE_POTENTIAL_GC ();
1315 v1 = POP;
1316 TOP = Ffset (TOP, v1);
1317 AFTER_POTENTIAL_GC ();
1318 NEXT;
1319 }
1320
1321 CASE (Bget):
1322 {
1323 Lisp_Object v1;
1324 BEFORE_POTENTIAL_GC ();
1325 v1 = POP;
1326 TOP = Fget (TOP, v1);
1327 AFTER_POTENTIAL_GC ();
1328 NEXT;
1329 }
1330
1331 CASE (Bsubstring):
1332 {
1333 Lisp_Object v1, v2;
1334 BEFORE_POTENTIAL_GC ();
1335 v2 = POP; v1 = POP;
1336 TOP = Fsubstring (TOP, v1, v2);
1337 AFTER_POTENTIAL_GC ();
1338 NEXT;
1339 }
1340
1341 CASE (Bconcat2):
1342 BEFORE_POTENTIAL_GC ();
1343 DISCARD (1);
1344 TOP = Fconcat (2, &TOP);
1345 AFTER_POTENTIAL_GC ();
1346 NEXT;
1347
1348 CASE (Bconcat3):
1349 BEFORE_POTENTIAL_GC ();
1350 DISCARD (2);
1351 TOP = Fconcat (3, &TOP);
1352 AFTER_POTENTIAL_GC ();
1353 NEXT;
1354
1355 CASE (Bconcat4):
1356 BEFORE_POTENTIAL_GC ();
1357 DISCARD (3);
1358 TOP = Fconcat (4, &TOP);
1359 AFTER_POTENTIAL_GC ();
1360 NEXT;
1361
1362 CASE (BconcatN):
1363 op = FETCH;
1364 BEFORE_POTENTIAL_GC ();
1365 DISCARD (op - 1);
1366 TOP = Fconcat (op, &TOP);
1367 AFTER_POTENTIAL_GC ();
1368 NEXT;
1369
1370 CASE (Bsub1):
1371 {
1372 Lisp_Object v1;
1373 v1 = TOP;
1374 if (INTEGERP (v1))
1375 {
1376 XSETINT (v1, XINT (v1) - 1);
1377 TOP = v1;
1378 }
1379 else
1380 {
1381 BEFORE_POTENTIAL_GC ();
1382 TOP = Fsub1 (v1);
1383 AFTER_POTENTIAL_GC ();
1384 }
1385 NEXT;
1386 }
1387
1388 CASE (Badd1):
1389 {
1390 Lisp_Object v1;
1391 v1 = TOP;
1392 if (INTEGERP (v1))
1393 {
1394 XSETINT (v1, XINT (v1) + 1);
1395 TOP = v1;
1396 }
1397 else
1398 {
1399 BEFORE_POTENTIAL_GC ();
1400 TOP = Fadd1 (v1);
1401 AFTER_POTENTIAL_GC ();
1402 }
1403 NEXT;
1404 }
1405
1406 CASE (Beqlsign):
1407 {
1408 Lisp_Object v1, v2;
1409 BEFORE_POTENTIAL_GC ();
1410 v2 = POP; v1 = TOP;
1411 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v1);
1412 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v2);
1413 AFTER_POTENTIAL_GC ();
1414 if (FLOATP (v1) || FLOATP (v2))
1415 {
1416 double f1, f2;
1417
1418 f1 = (FLOATP (v1) ? XFLOAT_DATA (v1) : XINT (v1));
1419 f2 = (FLOATP (v2) ? XFLOAT_DATA (v2) : XINT (v2));
1420 TOP = (f1 == f2 ? Qt : Qnil);
1421 }
1422 else
1423 TOP = (XINT (v1) == XINT (v2) ? Qt : Qnil);
1424 NEXT;
1425 }
1426
1427 CASE (Bgtr):
1428 {
1429 Lisp_Object v1;
1430 BEFORE_POTENTIAL_GC ();
1431 v1 = POP;
1432 TOP = arithcompare (TOP, v1, ARITH_GRTR);
1433 AFTER_POTENTIAL_GC ();
1434 NEXT;
1435 }
1436
1437 CASE (Blss):
1438 {
1439 Lisp_Object v1;
1440 BEFORE_POTENTIAL_GC ();
1441 v1 = POP;
1442 TOP = arithcompare (TOP, v1, ARITH_LESS);
1443 AFTER_POTENTIAL_GC ();
1444 NEXT;
1445 }
1446
1447 CASE (Bleq):
1448 {
1449 Lisp_Object v1;
1450 BEFORE_POTENTIAL_GC ();
1451 v1 = POP;
1452 TOP = arithcompare (TOP, v1, ARITH_LESS_OR_EQUAL);
1453 AFTER_POTENTIAL_GC ();
1454 NEXT;
1455 }
1456
1457 CASE (Bgeq):
1458 {
1459 Lisp_Object v1;
1460 BEFORE_POTENTIAL_GC ();
1461 v1 = POP;
1462 TOP = arithcompare (TOP, v1, ARITH_GRTR_OR_EQUAL);
1463 AFTER_POTENTIAL_GC ();
1464 NEXT;
1465 }
1466
1467 CASE (Bdiff):
1468 BEFORE_POTENTIAL_GC ();
1469 DISCARD (1);
1470 TOP = Fminus (2, &TOP);
1471 AFTER_POTENTIAL_GC ();
1472 NEXT;
1473
1474 CASE (Bnegate):
1475 {
1476 Lisp_Object v1;
1477 v1 = TOP;
1478 if (INTEGERP (v1))
1479 {
1480 XSETINT (v1, - XINT (v1));
1481 TOP = v1;
1482 }
1483 else
1484 {
1485 BEFORE_POTENTIAL_GC ();
1486 TOP = Fminus (1, &TOP);
1487 AFTER_POTENTIAL_GC ();
1488 }
1489 NEXT;
1490 }
1491
1492 CASE (Bplus):
1493 BEFORE_POTENTIAL_GC ();
1494 DISCARD (1);
1495 TOP = Fplus (2, &TOP);
1496 AFTER_POTENTIAL_GC ();
1497 NEXT;
1498
1499 CASE (Bmax):
1500 BEFORE_POTENTIAL_GC ();
1501 DISCARD (1);
1502 TOP = Fmax (2, &TOP);
1503 AFTER_POTENTIAL_GC ();
1504 NEXT;
1505
1506 CASE (Bmin):
1507 BEFORE_POTENTIAL_GC ();
1508 DISCARD (1);
1509 TOP = Fmin (2, &TOP);
1510 AFTER_POTENTIAL_GC ();
1511 NEXT;
1512
1513 CASE (Bmult):
1514 BEFORE_POTENTIAL_GC ();
1515 DISCARD (1);
1516 TOP = Ftimes (2, &TOP);
1517 AFTER_POTENTIAL_GC ();
1518 NEXT;
1519
1520 CASE (Bquo):
1521 BEFORE_POTENTIAL_GC ();
1522 DISCARD (1);
1523 TOP = Fquo (2, &TOP);
1524 AFTER_POTENTIAL_GC ();
1525 NEXT;
1526
1527 CASE (Brem):
1528 {
1529 Lisp_Object v1;
1530 BEFORE_POTENTIAL_GC ();
1531 v1 = POP;
1532 TOP = Frem (TOP, v1);
1533 AFTER_POTENTIAL_GC ();
1534 NEXT;
1535 }
1536
1537 CASE (Bpoint):
1538 {
1539 Lisp_Object v1;
1540 XSETFASTINT (v1, PT);
1541 PUSH (v1);
1542 NEXT;
1543 }
1544
1545 CASE (Bgoto_char):
1546 BEFORE_POTENTIAL_GC ();
1547 TOP = Fgoto_char (TOP);
1548 AFTER_POTENTIAL_GC ();
1549 NEXT;
1550
1551 CASE (Binsert):
1552 BEFORE_POTENTIAL_GC ();
1553 TOP = Finsert (1, &TOP);
1554 AFTER_POTENTIAL_GC ();
1555 NEXT;
1556
1557 CASE (BinsertN):
1558 op = FETCH;
1559 BEFORE_POTENTIAL_GC ();
1560 DISCARD (op - 1);
1561 TOP = Finsert (op, &TOP);
1562 AFTER_POTENTIAL_GC ();
1563 NEXT;
1564
1565 CASE (Bpoint_max):
1566 {
1567 Lisp_Object v1;
1568 XSETFASTINT (v1, ZV);
1569 PUSH (v1);
1570 NEXT;
1571 }
1572
1573 CASE (Bpoint_min):
1574 {
1575 Lisp_Object v1;
1576 XSETFASTINT (v1, BEGV);
1577 PUSH (v1);
1578 NEXT;
1579 }
1580
1581 CASE (Bchar_after):
1582 BEFORE_POTENTIAL_GC ();
1583 TOP = Fchar_after (TOP);
1584 AFTER_POTENTIAL_GC ();
1585 NEXT;
1586
1587 CASE (Bfollowing_char):
1588 {
1589 Lisp_Object v1;
1590 BEFORE_POTENTIAL_GC ();
1591 v1 = Ffollowing_char ();
1592 AFTER_POTENTIAL_GC ();
1593 PUSH (v1);
1594 NEXT;
1595 }
1596
1597 CASE (Bpreceding_char):
1598 {
1599 Lisp_Object v1;
1600 BEFORE_POTENTIAL_GC ();
1601 v1 = Fprevious_char ();
1602 AFTER_POTENTIAL_GC ();
1603 PUSH (v1);
1604 NEXT;
1605 }
1606
1607 CASE (Bcurrent_column):
1608 {
1609 Lisp_Object v1;
1610 BEFORE_POTENTIAL_GC ();
1611 XSETFASTINT (v1, current_column ());
1612 AFTER_POTENTIAL_GC ();
1613 PUSH (v1);
1614 NEXT;
1615 }
1616
1617 CASE (Bindent_to):
1618 BEFORE_POTENTIAL_GC ();
1619 TOP = Findent_to (TOP, Qnil);
1620 AFTER_POTENTIAL_GC ();
1621 NEXT;
1622
1623 CASE (Beolp):
1624 PUSH (Feolp ());
1625 NEXT;
1626
1627 CASE (Beobp):
1628 PUSH (Feobp ());
1629 NEXT;
1630
1631 CASE (Bbolp):
1632 PUSH (Fbolp ());
1633 NEXT;
1634
1635 CASE (Bbobp):
1636 PUSH (Fbobp ());
1637 NEXT;
1638
1639 CASE (Bcurrent_buffer):
1640 PUSH (Fcurrent_buffer ());
1641 NEXT;
1642
1643 CASE (Bset_buffer):
1644 BEFORE_POTENTIAL_GC ();
1645 TOP = Fset_buffer (TOP);
1646 AFTER_POTENTIAL_GC ();
1647 NEXT;
1648
1649 CASE (Binteractive_p): /* Obsolete since 24.1. */
1650 BEFORE_POTENTIAL_GC ();
1651 PUSH (call0 (intern ("interactive-p")));
1652 AFTER_POTENTIAL_GC ();
1653 NEXT;
1654
1655 CASE (Bforward_char):
1656 BEFORE_POTENTIAL_GC ();
1657 TOP = Fforward_char (TOP);
1658 AFTER_POTENTIAL_GC ();
1659 NEXT;
1660
1661 CASE (Bforward_word):
1662 BEFORE_POTENTIAL_GC ();
1663 TOP = Fforward_word (TOP);
1664 AFTER_POTENTIAL_GC ();
1665 NEXT;
1666
1667 CASE (Bskip_chars_forward):
1668 {
1669 Lisp_Object v1;
1670 BEFORE_POTENTIAL_GC ();
1671 v1 = POP;
1672 TOP = Fskip_chars_forward (TOP, v1);
1673 AFTER_POTENTIAL_GC ();
1674 NEXT;
1675 }
1676
1677 CASE (Bskip_chars_backward):
1678 {
1679 Lisp_Object v1;
1680 BEFORE_POTENTIAL_GC ();
1681 v1 = POP;
1682 TOP = Fskip_chars_backward (TOP, v1);
1683 AFTER_POTENTIAL_GC ();
1684 NEXT;
1685 }
1686
1687 CASE (Bforward_line):
1688 BEFORE_POTENTIAL_GC ();
1689 TOP = Fforward_line (TOP);
1690 AFTER_POTENTIAL_GC ();
1691 NEXT;
1692
1693 CASE (Bchar_syntax):
1694 {
1695 int c;
1696
1697 BEFORE_POTENTIAL_GC ();
1698 CHECK_CHARACTER (TOP);
1699 AFTER_POTENTIAL_GC ();
1700 c = XFASTINT (TOP);
1701 if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
1702 MAKE_CHAR_MULTIBYTE (c);
1703 XSETFASTINT (TOP, syntax_code_spec[SYNTAX (c)]);
1704 }
1705 NEXT;
1706
1707 CASE (Bbuffer_substring):
1708 {
1709 Lisp_Object v1;
1710 BEFORE_POTENTIAL_GC ();
1711 v1 = POP;
1712 TOP = Fbuffer_substring (TOP, v1);
1713 AFTER_POTENTIAL_GC ();
1714 NEXT;
1715 }
1716
1717 CASE (Bdelete_region):
1718 {
1719 Lisp_Object v1;
1720 BEFORE_POTENTIAL_GC ();
1721 v1 = POP;
1722 TOP = Fdelete_region (TOP, v1);
1723 AFTER_POTENTIAL_GC ();
1724 NEXT;
1725 }
1726
1727 CASE (Bnarrow_to_region):
1728 {
1729 Lisp_Object v1;
1730 BEFORE_POTENTIAL_GC ();
1731 v1 = POP;
1732 TOP = Fnarrow_to_region (TOP, v1);
1733 AFTER_POTENTIAL_GC ();
1734 NEXT;
1735 }
1736
1737 CASE (Bwiden):
1738 BEFORE_POTENTIAL_GC ();
1739 PUSH (Fwiden ());
1740 AFTER_POTENTIAL_GC ();
1741 NEXT;
1742
1743 CASE (Bend_of_line):
1744 BEFORE_POTENTIAL_GC ();
1745 TOP = Fend_of_line (TOP);
1746 AFTER_POTENTIAL_GC ();
1747 NEXT;
1748
1749 CASE (Bset_marker):
1750 {
1751 Lisp_Object v1, v2;
1752 BEFORE_POTENTIAL_GC ();
1753 v1 = POP;
1754 v2 = POP;
1755 TOP = Fset_marker (TOP, v2, v1);
1756 AFTER_POTENTIAL_GC ();
1757 NEXT;
1758 }
1759
1760 CASE (Bmatch_beginning):
1761 BEFORE_POTENTIAL_GC ();
1762 TOP = Fmatch_beginning (TOP);
1763 AFTER_POTENTIAL_GC ();
1764 NEXT;
1765
1766 CASE (Bmatch_end):
1767 BEFORE_POTENTIAL_GC ();
1768 TOP = Fmatch_end (TOP);
1769 AFTER_POTENTIAL_GC ();
1770 NEXT;
1771
1772 CASE (Bupcase):
1773 BEFORE_POTENTIAL_GC ();
1774 TOP = Fupcase (TOP);
1775 AFTER_POTENTIAL_GC ();
1776 NEXT;
1777
1778 CASE (Bdowncase):
1779 BEFORE_POTENTIAL_GC ();
1780 TOP = Fdowncase (TOP);
1781 AFTER_POTENTIAL_GC ();
1782 NEXT;
1783
1784 CASE (Bstringeqlsign):
1785 {
1786 Lisp_Object v1;
1787 BEFORE_POTENTIAL_GC ();
1788 v1 = POP;
1789 TOP = Fstring_equal (TOP, v1);
1790 AFTER_POTENTIAL_GC ();
1791 NEXT;
1792 }
1793
1794 CASE (Bstringlss):
1795 {
1796 Lisp_Object v1;
1797 BEFORE_POTENTIAL_GC ();
1798 v1 = POP;
1799 TOP = Fstring_lessp (TOP, v1);
1800 AFTER_POTENTIAL_GC ();
1801 NEXT;
1802 }
1803
1804 CASE (Bequal):
1805 {
1806 Lisp_Object v1;
1807 v1 = POP;
1808 TOP = Fequal (TOP, v1);
1809 NEXT;
1810 }
1811
1812 CASE (Bnthcdr):
1813 {
1814 Lisp_Object v1;
1815 BEFORE_POTENTIAL_GC ();
1816 v1 = POP;
1817 TOP = Fnthcdr (TOP, v1);
1818 AFTER_POTENTIAL_GC ();
1819 NEXT;
1820 }
1821
1822 CASE (Belt):
1823 {
1824 Lisp_Object v1, v2;
1825 if (CONSP (TOP))
1826 {
1827 /* Exchange args and then do nth. */
1828 EMACS_INT n;
1829 BEFORE_POTENTIAL_GC ();
1830 v2 = POP;
1831 v1 = TOP;
1832 CHECK_NUMBER (v2);
1833 AFTER_POTENTIAL_GC ();
1834 n = XINT (v2);
1835 immediate_quit = 1;
1836 while (--n >= 0 && CONSP (v1))
1837 v1 = XCDR (v1);
1838 immediate_quit = 0;
1839 TOP = CAR (v1);
1840 }
1841 else
1842 {
1843 BEFORE_POTENTIAL_GC ();
1844 v1 = POP;
1845 TOP = Felt (TOP, v1);
1846 AFTER_POTENTIAL_GC ();
1847 }
1848 NEXT;
1849 }
1850
1851 CASE (Bmember):
1852 {
1853 Lisp_Object v1;
1854 BEFORE_POTENTIAL_GC ();
1855 v1 = POP;
1856 TOP = Fmember (TOP, v1);
1857 AFTER_POTENTIAL_GC ();
1858 NEXT;
1859 }
1860
1861 CASE (Bassq):
1862 {
1863 Lisp_Object v1;
1864 BEFORE_POTENTIAL_GC ();
1865 v1 = POP;
1866 TOP = Fassq (TOP, v1);
1867 AFTER_POTENTIAL_GC ();
1868 NEXT;
1869 }
1870
1871 CASE (Bnreverse):
1872 BEFORE_POTENTIAL_GC ();
1873 TOP = Fnreverse (TOP);
1874 AFTER_POTENTIAL_GC ();
1875 NEXT;
1876
1877 CASE (Bsetcar):
1878 {
1879 Lisp_Object v1;
1880 BEFORE_POTENTIAL_GC ();
1881 v1 = POP;
1882 TOP = Fsetcar (TOP, v1);
1883 AFTER_POTENTIAL_GC ();
1884 NEXT;
1885 }
1886
1887 CASE (Bsetcdr):
1888 {
1889 Lisp_Object v1;
1890 BEFORE_POTENTIAL_GC ();
1891 v1 = POP;
1892 TOP = Fsetcdr (TOP, v1);
1893 AFTER_POTENTIAL_GC ();
1894 NEXT;
1895 }
1896
1897 CASE (Bcar_safe):
1898 {
1899 Lisp_Object v1;
1900 v1 = TOP;
1901 TOP = CAR_SAFE (v1);
1902 NEXT;
1903 }
1904
1905 CASE (Bcdr_safe):
1906 {
1907 Lisp_Object v1;
1908 v1 = TOP;
1909 TOP = CDR_SAFE (v1);
1910 NEXT;
1911 }
1912
1913 CASE (Bnconc):
1914 BEFORE_POTENTIAL_GC ();
1915 DISCARD (1);
1916 TOP = Fnconc (2, &TOP);
1917 AFTER_POTENTIAL_GC ();
1918 NEXT;
1919
1920 CASE (Bnumberp):
1921 TOP = (NUMBERP (TOP) ? Qt : Qnil);
1922 NEXT;
1923
1924 CASE (Bintegerp):
1925 TOP = INTEGERP (TOP) ? Qt : Qnil;
1926 NEXT;
1927
1928 #ifdef BYTE_CODE_SAFE
1929 /* These are intentionally written using 'case' syntax,
1930 because they are incompatible with the threaded
1931 interpreter. */
1932
1933 case Bset_mark:
1934 BEFORE_POTENTIAL_GC ();
1935 error ("set-mark is an obsolete bytecode");
1936 AFTER_POTENTIAL_GC ();
1937 break;
1938 case Bscan_buffer:
1939 BEFORE_POTENTIAL_GC ();
1940 error ("scan-buffer is an obsolete bytecode");
1941 AFTER_POTENTIAL_GC ();
1942 break;
1943 #endif
1944
1945 CASE_ABORT:
1946 /* Actually this is Bstack_ref with offset 0, but we use Bdup
1947 for that instead. */
1948 /* CASE (Bstack_ref): */
1949 call3 (intern ("error"),
1950 build_string ("Invalid byte opcode: op=%s, ptr=%d"),
1951 make_number (op),
1952 make_number ((stack.pc - 1) - stack.byte_string_start));
1953
1954 /* Handy byte-codes for lexical binding. */
1955 CASE (Bstack_ref1):
1956 CASE (Bstack_ref2):
1957 CASE (Bstack_ref3):
1958 CASE (Bstack_ref4):
1959 CASE (Bstack_ref5):
1960 {
1961 Lisp_Object *ptr = top - (op - Bstack_ref);
1962 PUSH (*ptr);
1963 NEXT;
1964 }
1965 CASE (Bstack_ref6):
1966 {
1967 Lisp_Object *ptr = top - (FETCH);
1968 PUSH (*ptr);
1969 NEXT;
1970 }
1971 CASE (Bstack_ref7):
1972 {
1973 Lisp_Object *ptr = top - (FETCH2);
1974 PUSH (*ptr);
1975 NEXT;
1976 }
1977 CASE (Bstack_set):
1978 /* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos. */
1979 {
1980 Lisp_Object *ptr = top - (FETCH);
1981 *ptr = POP;
1982 NEXT;
1983 }
1984 CASE (Bstack_set2):
1985 {
1986 Lisp_Object *ptr = top - (FETCH2);
1987 *ptr = POP;
1988 NEXT;
1989 }
1990 CASE (BdiscardN):
1991 op = FETCH;
1992 if (op & 0x80)
1993 {
1994 op &= 0x7F;
1995 top[-op] = TOP;
1996 }
1997 DISCARD (op);
1998 NEXT;
1999
2000 CASE_DEFAULT
2001 CASE (Bconstant):
2002 #ifdef BYTE_CODE_SAFE
2003 if (op < Bconstant)
2004 {
2005 emacs_abort ();
2006 }
2007 if ((op -= Bconstant) >= const_length)
2008 {
2009 emacs_abort ();
2010 }
2011 PUSH (vectorp[op]);
2012 #else
2013 PUSH (vectorp[op - Bconstant]);
2014 #endif
2015 NEXT;
2016 }
2017 }
2018
2019 exit:
2020
2021 byte_stack_list = byte_stack_list->next;
2022
2023 /* Binds and unbinds are supposed to be compiled balanced. */
2024 if (SPECPDL_INDEX () != count)
2025 {
2026 if (SPECPDL_INDEX () > count)
2027 unbind_to (count, Qnil);
2028 error ("binding stack not balanced (serious byte compiler bug)");
2029 }
2030
2031 return result;
2032 }
2033
2034 void
2035 syms_of_bytecode (void)
2036 {
2037 defsubr (&Sbyte_code);
2038
2039 #ifdef BYTE_CODE_METER
2040
2041 DEFVAR_LISP ("byte-code-meter", Vbyte_code_meter,
2042 doc: /* A vector of vectors which holds a histogram of byte-code usage.
2043 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
2044 opcode CODE has been executed.
2045 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
2046 indicates how many times the byte opcodes CODE1 and CODE2 have been
2047 executed in succession. */);
2048
2049 DEFVAR_BOOL ("byte-metering-on", byte_metering_on,
2050 doc: /* If non-nil, keep profiling information on byte code usage.
2051 The variable byte-code-meter indicates how often each byte opcode is used.
2052 If a symbol has a property named `byte-code-meter' whose value is an
2053 integer, it is incremented each time that symbol's function is called. */);
2054
2055 byte_metering_on = 0;
2056 Vbyte_code_meter = Fmake_vector (make_number (256), make_number (0));
2057 DEFSYM (Qbyte_code_meter, "byte-code-meter");
2058 {
2059 int i = 256;
2060 while (i--)
2061 ASET (Vbyte_code_meter, i,
2062 Fmake_vector (make_number (256), make_number (0)));
2063 }
2064 #endif
2065 }
Emacs repository mirror