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