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