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