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