HCoop / bpt / emacs.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
Miscellanous cleanups in preparation for the merge.
[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 #endif
451 int bytestr_length;
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 bytestr_length = SBYTES (bytestr);
479 vectorp = XVECTOR (vector)->contents;
480
481 stack.byte_string = bytestr;
482 stack.pc = stack.byte_string_start = SDATA (bytestr);
483 stack.constants = vector;
484 top = (Lisp_Object *) alloca (XFASTINT (maxdepth)
485 * sizeof (Lisp_Object));
486 #if BYTE_MAINTAIN_TOP
487 stack.bottom = top;
488 stack.top = NULL;
489 #endif
490 top -= 1;
491 stack.next = byte_stack_list;
492 byte_stack_list = &stack;
493
494 #ifdef BYTE_CODE_SAFE
495 stacke = stack.bottom - 1 + XFASTINT (maxdepth);
496 #endif
497
498 if (INTEGERP (args_template))
499 {
500 int at = XINT (args_template);
501 int rest = at & 128;
502 int mandatory = at & 127;
503 int nonrest = at >> 8;
504 eassert (mandatory <= nonrest);
505 if (nargs <= nonrest)
506 {
507 int i;
508 for (i = 0 ; i < nargs; i++, args++)
509 PUSH (*args);
510 if (nargs < mandatory)
511 /* Too few arguments. */
512 Fsignal (Qwrong_number_of_arguments,
513 Fcons (Fcons (make_number (mandatory),
514 rest ? Qand_rest : make_number (nonrest)),
515 Fcons (make_number (nargs), Qnil)));
516 else
517 {
518 for (; i < nonrest; i++)
519 PUSH (Qnil);
520 if (rest)
521 PUSH (Qnil);
522 }
523 }
524 else if (rest)
525 {
526 int i;
527 for (i = 0 ; i < nonrest; i++, args++)
528 PUSH (*args);
529 PUSH (Flist (nargs - nonrest, args));
530 }
531 else
532 /* Too many arguments. */
533 Fsignal (Qwrong_number_of_arguments,
534 Fcons (Fcons (make_number (mandatory),
535 make_number (nonrest)),
536 Fcons (make_number (nargs), Qnil)));
537 }
538 else if (! NILP (args_template))
539 /* We should push some arguments on the stack. */
540 {
541 error ("Unknown args template!");
542 }
543
544 while (1)
545 {
546 #ifdef BYTE_CODE_SAFE
547 if (top > stacke)
548 abort ();
549 else if (top < stack.bottom - 1)
550 abort ();
551 #endif
552
553 #ifdef BYTE_CODE_METER
554 prev_op = this_op;
555 this_op = op = FETCH;
556 METER_CODE (prev_op, op);
557 #else
558 op = FETCH;
559 #endif
560
561 switch (op)
562 {
563 case Bvarref + 7:
564 op = FETCH2;
565 goto varref;
566
567 case Bvarref:
568 case Bvarref + 1:
569 case Bvarref + 2:
570 case Bvarref + 3:
571 case Bvarref + 4:
572 case Bvarref + 5:
573 op = op - Bvarref;
574 goto varref;
575
576 /* This seems to be the most frequently executed byte-code
577 among the Bvarref's, so avoid a goto here. */
578 case Bvarref+6:
579 op = FETCH;
580 varref:
581 {
582 Lisp_Object v1, v2;
583
584 v1 = vectorp[op];
585 if (SYMBOLP (v1))
586 {
587 if (XSYMBOL (v1)->redirect != SYMBOL_PLAINVAL
588 || (v2 = SYMBOL_VAL (XSYMBOL (v1)),
589 EQ (v2, Qunbound)))
590 {
591 BEFORE_POTENTIAL_GC ();
592 v2 = Fsymbol_value (v1);
593 AFTER_POTENTIAL_GC ();
594 }
595 }
596 else
597 {
598 BEFORE_POTENTIAL_GC ();
599 v2 = Fsymbol_value (v1);
600 AFTER_POTENTIAL_GC ();
601 }
602 PUSH (v2);
603 break;
604 }
605
606 case Bgotoifnil:
607 {
608 Lisp_Object v1;
609 MAYBE_GC ();
610 op = FETCH2;
611 v1 = POP;
612 if (NILP (v1))
613 {
614 BYTE_CODE_QUIT;
615 CHECK_RANGE (op);
616 stack.pc = stack.byte_string_start + op;
617 }
618 break;
619 }
620
621 case Bcar:
622 {
623 Lisp_Object v1;
624 v1 = TOP;
625 if (CONSP (v1))
626 TOP = XCAR (v1);
627 else if (NILP (v1))
628 TOP = Qnil;
629 else
630 {
631 BEFORE_POTENTIAL_GC ();
632 wrong_type_argument (Qlistp, v1);
633 AFTER_POTENTIAL_GC ();
634 }
635 break;
636 }
637
638 case Beq:
639 {
640 Lisp_Object v1;
641 v1 = POP;
642 TOP = EQ (v1, TOP) ? Qt : Qnil;
643 break;
644 }
645
646 case Bmemq:
647 {
648 Lisp_Object v1;
649 BEFORE_POTENTIAL_GC ();
650 v1 = POP;
651 TOP = Fmemq (TOP, v1);
652 AFTER_POTENTIAL_GC ();
653 break;
654 }
655
656 case Bcdr:
657 {
658 Lisp_Object v1;
659 v1 = TOP;
660 if (CONSP (v1))
661 TOP = XCDR (v1);
662 else if (NILP (v1))
663 TOP = Qnil;
664 else
665 {
666 BEFORE_POTENTIAL_GC ();
667 wrong_type_argument (Qlistp, v1);
668 AFTER_POTENTIAL_GC ();
669 }
670 break;
671 break;
672 }
673
674 case Bvarset:
675 case Bvarset+1:
676 case Bvarset+2:
677 case Bvarset+3:
678 case Bvarset+4:
679 case Bvarset+5:
680 op -= Bvarset;
681 goto varset;
682
683 case Bvarset+7:
684 op = FETCH2;
685 goto varset;
686
687 case Bvarset+6:
688 op = FETCH;
689 varset:
690 {
691 Lisp_Object sym, val;
692
693 sym = vectorp[op];
694 val = TOP;
695
696 /* Inline the most common case. */
697 if (SYMBOLP (sym)
698 && !EQ (val, Qunbound)
699 && !XSYMBOL (sym)->redirect
700 && !SYMBOL_CONSTANT_P (sym))
701 XSYMBOL (sym)->val.value = val;
702 else
703 {
704 BEFORE_POTENTIAL_GC ();
705 set_internal (sym, val, Qnil, 0);
706 AFTER_POTENTIAL_GC ();
707 }
708 }
709 (void) POP;
710 break;
711
712 case Bdup:
713 {
714 Lisp_Object v1;
715 v1 = TOP;
716 PUSH (v1);
717 break;
718 }
719
720 /* ------------------ */
721
722 case Bvarbind+6:
723 op = FETCH;
724 goto varbind;
725
726 case Bvarbind+7:
727 op = FETCH2;
728 goto varbind;
729
730 case Bvarbind:
731 case Bvarbind+1:
732 case Bvarbind+2:
733 case Bvarbind+3:
734 case Bvarbind+4:
735 case Bvarbind+5:
736 op -= Bvarbind;
737 varbind:
738 /* Specbind can signal and thus GC. */
739 BEFORE_POTENTIAL_GC ();
740 specbind (vectorp[op], POP);
741 AFTER_POTENTIAL_GC ();
742 break;
743
744 case Bcall+6:
745 op = FETCH;
746 goto docall;
747
748 case Bcall+7:
749 op = FETCH2;
750 goto docall;
751
752 case Bcall:
753 case Bcall+1:
754 case Bcall+2:
755 case Bcall+3:
756 case Bcall+4:
757 case Bcall+5:
758 op -= Bcall;
759 docall:
760 {
761 BEFORE_POTENTIAL_GC ();
762 DISCARD (op);
763 #ifdef BYTE_CODE_METER
764 if (byte_metering_on && SYMBOLP (TOP))
765 {
766 Lisp_Object v1, v2;
767
768 v1 = TOP;
769 v2 = Fget (v1, Qbyte_code_meter);
770 if (INTEGERP (v2)
771 && XINT (v2) < MOST_POSITIVE_FIXNUM)
772 {
773 XSETINT (v2, XINT (v2) + 1);
774 Fput (v1, Qbyte_code_meter, v2);
775 }
776 }
777 #endif
778 TOP = Ffuncall (op + 1, &TOP);
779 AFTER_POTENTIAL_GC ();
780 break;
781 }
782
783 case Bunbind+6:
784 op = FETCH;
785 goto dounbind;
786
787 case Bunbind+7:
788 op = FETCH2;
789 goto dounbind;
790
791 case Bunbind:
792 case Bunbind+1:
793 case Bunbind+2:
794 case Bunbind+3:
795 case Bunbind+4:
796 case Bunbind+5:
797 op -= Bunbind;
798 dounbind:
799 BEFORE_POTENTIAL_GC ();
800 unbind_to (SPECPDL_INDEX () - op, Qnil);
801 AFTER_POTENTIAL_GC ();
802 break;
803
804 case Bunbind_all: /* Obsolete. Never used. */
805 /* To unbind back to the beginning of this frame. Not used yet,
806 but will be needed for tail-recursion elimination. */
807 BEFORE_POTENTIAL_GC ();
808 unbind_to (count, Qnil);
809 AFTER_POTENTIAL_GC ();
810 break;
811
812 case Bgoto:
813 MAYBE_GC ();
814 BYTE_CODE_QUIT;
815 op = FETCH2; /* pc = FETCH2 loses since FETCH2 contains pc++ */
816 CHECK_RANGE (op);
817 stack.pc = stack.byte_string_start + op;
818 break;
819
820 case Bgotoifnonnil:
821 {
822 Lisp_Object v1;
823 MAYBE_GC ();
824 op = FETCH2;
825 v1 = POP;
826 if (!NILP (v1))
827 {
828 BYTE_CODE_QUIT;
829 CHECK_RANGE (op);
830 stack.pc = stack.byte_string_start + op;
831 }
832 break;
833 }
834
835 case Bgotoifnilelsepop:
836 MAYBE_GC ();
837 op = FETCH2;
838 if (NILP (TOP))
839 {
840 BYTE_CODE_QUIT;
841 CHECK_RANGE (op);
842 stack.pc = stack.byte_string_start + op;
843 }
844 else DISCARD (1);
845 break;
846
847 case Bgotoifnonnilelsepop:
848 MAYBE_GC ();
849 op = FETCH2;
850 if (!NILP (TOP))
851 {
852 BYTE_CODE_QUIT;
853 CHECK_RANGE (op);
854 stack.pc = stack.byte_string_start + op;
855 }
856 else DISCARD (1);
857 break;
858
859 case BRgoto:
860 MAYBE_GC ();
861 BYTE_CODE_QUIT;
862 stack.pc += (int) *stack.pc - 127;
863 break;
864
865 case BRgotoifnil:
866 {
867 Lisp_Object v1;
868 MAYBE_GC ();
869 v1 = POP;
870 if (NILP (v1))
871 {
872 BYTE_CODE_QUIT;
873 stack.pc += (int) *stack.pc - 128;
874 }
875 stack.pc++;
876 break;
877 }
878
879 case BRgotoifnonnil:
880 {
881 Lisp_Object v1;
882 MAYBE_GC ();
883 v1 = POP;
884 if (!NILP (v1))
885 {
886 BYTE_CODE_QUIT;
887 stack.pc += (int) *stack.pc - 128;
888 }
889 stack.pc++;
890 break;
891 }
892
893 case BRgotoifnilelsepop:
894 MAYBE_GC ();
895 op = *stack.pc++;
896 if (NILP (TOP))
897 {
898 BYTE_CODE_QUIT;
899 stack.pc += op - 128;
900 }
901 else DISCARD (1);
902 break;
903
904 case BRgotoifnonnilelsepop:
905 MAYBE_GC ();
906 op = *stack.pc++;
907 if (!NILP (TOP))
908 {
909 BYTE_CODE_QUIT;
910 stack.pc += op - 128;
911 }
912 else DISCARD (1);
913 break;
914
915 case Breturn:
916 result = POP;
917 goto exit;
918
919 case Bdiscard:
920 DISCARD (1);
921 break;
922
923 case Bconstant2:
924 PUSH (vectorp[FETCH2]);
925 break;
926
927 case Bsave_excursion:
928 record_unwind_protect (save_excursion_restore,
929 save_excursion_save ());
930 break;
931
932 case Bsave_current_buffer: /* Obsolete since ??. */
933 case Bsave_current_buffer_1:
934 record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ());
935 break;
936
937 case Bsave_window_excursion: /* Obsolete since 24.1. */
938 {
939 register int count = SPECPDL_INDEX ();
940 record_unwind_protect (Fset_window_configuration,
941 Fcurrent_window_configuration (Qnil));
942 BEFORE_POTENTIAL_GC ();
943 TOP = Fprogn (TOP);
944 unbind_to (count, TOP);
945 AFTER_POTENTIAL_GC ();
946 break;
947 }
948
949 case Bsave_restriction:
950 record_unwind_protect (save_restriction_restore,
951 save_restriction_save ());
952 break;
953
954 case Bcatch: /* FIXME: ill-suited for lexbind */
955 {
956 Lisp_Object v1;
957 BEFORE_POTENTIAL_GC ();
958 v1 = POP;
959 TOP = internal_catch (TOP, eval_sub, v1);
960 AFTER_POTENTIAL_GC ();
961 break;
962 }
963
964 case Bunwind_protect: /* FIXME: avoid closure for lexbind */
965 record_unwind_protect (Fprogn, POP);
966 break;
967
968 case Bcondition_case: /* FIXME: ill-suited for lexbind */
969 {
970 Lisp_Object handlers, body;
971 handlers = POP;
972 body = POP;
973 BEFORE_POTENTIAL_GC ();
974 TOP = internal_lisp_condition_case (TOP, body, handlers);
975 AFTER_POTENTIAL_GC ();
976 break;
977 }
978
979 case Btemp_output_buffer_setup: /* Obsolete since 24.1. */
980 BEFORE_POTENTIAL_GC ();
981 CHECK_STRING (TOP);
982 temp_output_buffer_setup (SSDATA (TOP));
983 AFTER_POTENTIAL_GC ();
984 TOP = Vstandard_output;
985 break;
986
987 case Btemp_output_buffer_show: /* Obsolete since 24.1. */
988 {
989 Lisp_Object v1;
990 BEFORE_POTENTIAL_GC ();
991 v1 = POP;
992 temp_output_buffer_show (TOP);
993 TOP = v1;
994 /* pop binding of standard-output */
995 unbind_to (SPECPDL_INDEX () - 1, Qnil);
996 AFTER_POTENTIAL_GC ();
997 break;
998 }
999
1000 case Bnth:
1001 {
1002 Lisp_Object v1, v2;
1003 BEFORE_POTENTIAL_GC ();
1004 v1 = POP;
1005 v2 = TOP;
1006 CHECK_NUMBER (v2);
1007 op = XINT (v2);
1008 immediate_quit = 1;
1009 while (--op >= 0 && CONSP (v1))
1010 v1 = XCDR (v1);
1011 immediate_quit = 0;
1012 TOP = CAR (v1);
1013 AFTER_POTENTIAL_GC ();
1014 break;
1015 }
1016
1017 case Bsymbolp:
1018 TOP = SYMBOLP (TOP) ? Qt : Qnil;
1019 break;
1020
1021 case Bconsp:
1022 TOP = CONSP (TOP) ? Qt : Qnil;
1023 break;
1024
1025 case Bstringp:
1026 TOP = STRINGP (TOP) ? Qt : Qnil;
1027 break;
1028
1029 case Blistp:
1030 TOP = CONSP (TOP) || NILP (TOP) ? Qt : Qnil;
1031 break;
1032
1033 case Bnot:
1034 TOP = NILP (TOP) ? Qt : Qnil;
1035 break;
1036
1037 case Bcons:
1038 {
1039 Lisp_Object v1;
1040 v1 = POP;
1041 TOP = Fcons (TOP, v1);
1042 break;
1043 }
1044
1045 case Blist1:
1046 TOP = Fcons (TOP, Qnil);
1047 break;
1048
1049 case Blist2:
1050 {
1051 Lisp_Object v1;
1052 v1 = POP;
1053 TOP = Fcons (TOP, Fcons (v1, Qnil));
1054 break;
1055 }
1056
1057 case Blist3:
1058 DISCARD (2);
1059 TOP = Flist (3, &TOP);
1060 break;
1061
1062 case Blist4:
1063 DISCARD (3);
1064 TOP = Flist (4, &TOP);
1065 break;
1066
1067 case BlistN:
1068 op = FETCH;
1069 DISCARD (op - 1);
1070 TOP = Flist (op, &TOP);
1071 break;
1072
1073 case Blength:
1074 BEFORE_POTENTIAL_GC ();
1075 TOP = Flength (TOP);
1076 AFTER_POTENTIAL_GC ();
1077 break;
1078
1079 case Baref:
1080 {
1081 Lisp_Object v1;
1082 BEFORE_POTENTIAL_GC ();
1083 v1 = POP;
1084 TOP = Faref (TOP, v1);
1085 AFTER_POTENTIAL_GC ();
1086 break;
1087 }
1088
1089 case Baset:
1090 {
1091 Lisp_Object v1, v2;
1092 BEFORE_POTENTIAL_GC ();
1093 v2 = POP; v1 = POP;
1094 TOP = Faset (TOP, v1, v2);
1095 AFTER_POTENTIAL_GC ();
1096 break;
1097 }
1098
1099 case Bsymbol_value:
1100 BEFORE_POTENTIAL_GC ();
1101 TOP = Fsymbol_value (TOP);
1102 AFTER_POTENTIAL_GC ();
1103 break;
1104
1105 case Bsymbol_function:
1106 BEFORE_POTENTIAL_GC ();
1107 TOP = Fsymbol_function (TOP);
1108 AFTER_POTENTIAL_GC ();
1109 break;
1110
1111 case Bset:
1112 {
1113 Lisp_Object v1;
1114 BEFORE_POTENTIAL_GC ();
1115 v1 = POP;
1116 TOP = Fset (TOP, v1);
1117 AFTER_POTENTIAL_GC ();
1118 break;
1119 }
1120
1121 case Bfset:
1122 {
1123 Lisp_Object v1;
1124 BEFORE_POTENTIAL_GC ();
1125 v1 = POP;
1126 TOP = Ffset (TOP, v1);
1127 AFTER_POTENTIAL_GC ();
1128 break;
1129 }
1130
1131 case Bget:
1132 {
1133 Lisp_Object v1;
1134 BEFORE_POTENTIAL_GC ();
1135 v1 = POP;
1136 TOP = Fget (TOP, v1);
1137 AFTER_POTENTIAL_GC ();
1138 break;
1139 }
1140
1141 case Bsubstring:
1142 {
1143 Lisp_Object v1, v2;
1144 BEFORE_POTENTIAL_GC ();
1145 v2 = POP; v1 = POP;
1146 TOP = Fsubstring (TOP, v1, v2);
1147 AFTER_POTENTIAL_GC ();
1148 break;
1149 }
1150
1151 case Bconcat2:
1152 BEFORE_POTENTIAL_GC ();
1153 DISCARD (1);
1154 TOP = Fconcat (2, &TOP);
1155 AFTER_POTENTIAL_GC ();
1156 break;
1157
1158 case Bconcat3:
1159 BEFORE_POTENTIAL_GC ();
1160 DISCARD (2);
1161 TOP = Fconcat (3, &TOP);
1162 AFTER_POTENTIAL_GC ();
1163 break;
1164
1165 case Bconcat4:
1166 BEFORE_POTENTIAL_GC ();
1167 DISCARD (3);
1168 TOP = Fconcat (4, &TOP);
1169 AFTER_POTENTIAL_GC ();
1170 break;
1171
1172 case BconcatN:
1173 op = FETCH;
1174 BEFORE_POTENTIAL_GC ();
1175 DISCARD (op - 1);
1176 TOP = Fconcat (op, &TOP);
1177 AFTER_POTENTIAL_GC ();
1178 break;
1179
1180 case Bsub1:
1181 {
1182 Lisp_Object v1;
1183 v1 = TOP;
1184 if (INTEGERP (v1))
1185 {
1186 XSETINT (v1, XINT (v1) - 1);
1187 TOP = v1;
1188 }
1189 else
1190 {
1191 BEFORE_POTENTIAL_GC ();
1192 TOP = Fsub1 (v1);
1193 AFTER_POTENTIAL_GC ();
1194 }
1195 break;
1196 }
1197
1198 case Badd1:
1199 {
1200 Lisp_Object v1;
1201 v1 = TOP;
1202 if (INTEGERP (v1))
1203 {
1204 XSETINT (v1, XINT (v1) + 1);
1205 TOP = v1;
1206 }
1207 else
1208 {
1209 BEFORE_POTENTIAL_GC ();
1210 TOP = Fadd1 (v1);
1211 AFTER_POTENTIAL_GC ();
1212 }
1213 break;
1214 }
1215
1216 case Beqlsign:
1217 {
1218 Lisp_Object v1, v2;
1219 BEFORE_POTENTIAL_GC ();
1220 v2 = POP; v1 = TOP;
1221 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v1);
1222 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v2);
1223 AFTER_POTENTIAL_GC ();
1224 if (FLOATP (v1) || FLOATP (v2))
1225 {
1226 double f1, f2;
1227
1228 f1 = (FLOATP (v1) ? XFLOAT_DATA (v1) : XINT (v1));
1229 f2 = (FLOATP (v2) ? XFLOAT_DATA (v2) : XINT (v2));
1230 TOP = (f1 == f2 ? Qt : Qnil);
1231 }
1232 else
1233 TOP = (XINT (v1) == XINT (v2) ? Qt : Qnil);
1234 break;
1235 }
1236
1237 case Bgtr:
1238 {
1239 Lisp_Object v1;
1240 BEFORE_POTENTIAL_GC ();
1241 v1 = POP;
1242 TOP = Fgtr (TOP, v1);
1243 AFTER_POTENTIAL_GC ();
1244 break;
1245 }
1246
1247 case Blss:
1248 {
1249 Lisp_Object v1;
1250 BEFORE_POTENTIAL_GC ();
1251 v1 = POP;
1252 TOP = Flss (TOP, v1);
1253 AFTER_POTENTIAL_GC ();
1254 break;
1255 }
1256
1257 case Bleq:
1258 {
1259 Lisp_Object v1;
1260 BEFORE_POTENTIAL_GC ();
1261 v1 = POP;
1262 TOP = Fleq (TOP, v1);
1263 AFTER_POTENTIAL_GC ();
1264 break;
1265 }
1266
1267 case Bgeq:
1268 {
1269 Lisp_Object v1;
1270 BEFORE_POTENTIAL_GC ();
1271 v1 = POP;
1272 TOP = Fgeq (TOP, v1);
1273 AFTER_POTENTIAL_GC ();
1274 break;
1275 }
1276
1277 case Bdiff:
1278 BEFORE_POTENTIAL_GC ();
1279 DISCARD (1);
1280 TOP = Fminus (2, &TOP);
1281 AFTER_POTENTIAL_GC ();
1282 break;
1283
1284 case Bnegate:
1285 {
1286 Lisp_Object v1;
1287 v1 = TOP;
1288 if (INTEGERP (v1))
1289 {
1290 XSETINT (v1, - XINT (v1));
1291 TOP = v1;
1292 }
1293 else
1294 {
1295 BEFORE_POTENTIAL_GC ();
1296 TOP = Fminus (1, &TOP);
1297 AFTER_POTENTIAL_GC ();
1298 }
1299 break;
1300 }
1301
1302 case Bplus:
1303 BEFORE_POTENTIAL_GC ();
1304 DISCARD (1);
1305 TOP = Fplus (2, &TOP);
1306 AFTER_POTENTIAL_GC ();
1307 break;
1308
1309 case Bmax:
1310 BEFORE_POTENTIAL_GC ();
1311 DISCARD (1);
1312 TOP = Fmax (2, &TOP);
1313 AFTER_POTENTIAL_GC ();
1314 break;
1315
1316 case Bmin:
1317 BEFORE_POTENTIAL_GC ();
1318 DISCARD (1);
1319 TOP = Fmin (2, &TOP);
1320 AFTER_POTENTIAL_GC ();
1321 break;
1322
1323 case Bmult:
1324 BEFORE_POTENTIAL_GC ();
1325 DISCARD (1);
1326 TOP = Ftimes (2, &TOP);
1327 AFTER_POTENTIAL_GC ();
1328 break;
1329
1330 case Bquo:
1331 BEFORE_POTENTIAL_GC ();
1332 DISCARD (1);
1333 TOP = Fquo (2, &TOP);
1334 AFTER_POTENTIAL_GC ();
1335 break;
1336
1337 case Brem:
1338 {
1339 Lisp_Object v1;
1340 BEFORE_POTENTIAL_GC ();
1341 v1 = POP;
1342 TOP = Frem (TOP, v1);
1343 AFTER_POTENTIAL_GC ();
1344 break;
1345 }
1346
1347 case Bpoint:
1348 {
1349 Lisp_Object v1;
1350 XSETFASTINT (v1, PT);
1351 PUSH (v1);
1352 break;
1353 }
1354
1355 case Bgoto_char:
1356 BEFORE_POTENTIAL_GC ();
1357 TOP = Fgoto_char (TOP);
1358 AFTER_POTENTIAL_GC ();
1359 break;
1360
1361 case Binsert:
1362 BEFORE_POTENTIAL_GC ();
1363 TOP = Finsert (1, &TOP);
1364 AFTER_POTENTIAL_GC ();
1365 break;
1366
1367 case BinsertN:
1368 op = FETCH;
1369 BEFORE_POTENTIAL_GC ();
1370 DISCARD (op - 1);
1371 TOP = Finsert (op, &TOP);
1372 AFTER_POTENTIAL_GC ();
1373 break;
1374
1375 case Bpoint_max:
1376 {
1377 Lisp_Object v1;
1378 XSETFASTINT (v1, ZV);
1379 PUSH (v1);
1380 break;
1381 }
1382
1383 case Bpoint_min:
1384 {
1385 Lisp_Object v1;
1386 XSETFASTINT (v1, BEGV);
1387 PUSH (v1);
1388 break;
1389 }
1390
1391 case Bchar_after:
1392 BEFORE_POTENTIAL_GC ();
1393 TOP = Fchar_after (TOP);
1394 AFTER_POTENTIAL_GC ();
1395 break;
1396
1397 case Bfollowing_char:
1398 {
1399 Lisp_Object v1;
1400 BEFORE_POTENTIAL_GC ();
1401 v1 = Ffollowing_char ();
1402 AFTER_POTENTIAL_GC ();
1403 PUSH (v1);
1404 break;
1405 }
1406
1407 case Bpreceding_char:
1408 {
1409 Lisp_Object v1;
1410 BEFORE_POTENTIAL_GC ();
1411 v1 = Fprevious_char ();
1412 AFTER_POTENTIAL_GC ();
1413 PUSH (v1);
1414 break;
1415 }
1416
1417 case Bcurrent_column:
1418 {
1419 Lisp_Object v1;
1420 BEFORE_POTENTIAL_GC ();
1421 XSETFASTINT (v1, current_column ());
1422 AFTER_POTENTIAL_GC ();
1423 PUSH (v1);
1424 break;
1425 }
1426
1427 case Bindent_to:
1428 BEFORE_POTENTIAL_GC ();
1429 TOP = Findent_to (TOP, Qnil);
1430 AFTER_POTENTIAL_GC ();
1431 break;
1432
1433 case Beolp:
1434 PUSH (Feolp ());
1435 break;
1436
1437 case Beobp:
1438 PUSH (Feobp ());
1439 break;
1440
1441 case Bbolp:
1442 PUSH (Fbolp ());
1443 break;
1444
1445 case Bbobp:
1446 PUSH (Fbobp ());
1447 break;
1448
1449 case Bcurrent_buffer:
1450 PUSH (Fcurrent_buffer ());
1451 break;
1452
1453 case Bset_buffer:
1454 BEFORE_POTENTIAL_GC ();
1455 TOP = Fset_buffer (TOP);
1456 AFTER_POTENTIAL_GC ();
1457 break;
1458
1459 case Binteractive_p: /* Obsolete since 24.1. */
1460 PUSH (Finteractive_p ());
1461 break;
1462
1463 case Bforward_char:
1464 BEFORE_POTENTIAL_GC ();
1465 TOP = Fforward_char (TOP);
1466 AFTER_POTENTIAL_GC ();
1467 break;
1468
1469 case Bforward_word:
1470 BEFORE_POTENTIAL_GC ();
1471 TOP = Fforward_word (TOP);
1472 AFTER_POTENTIAL_GC ();
1473 break;
1474
1475 case Bskip_chars_forward:
1476 {
1477 Lisp_Object v1;
1478 BEFORE_POTENTIAL_GC ();
1479 v1 = POP;
1480 TOP = Fskip_chars_forward (TOP, v1);
1481 AFTER_POTENTIAL_GC ();
1482 break;
1483 }
1484
1485 case Bskip_chars_backward:
1486 {
1487 Lisp_Object v1;
1488 BEFORE_POTENTIAL_GC ();
1489 v1 = POP;
1490 TOP = Fskip_chars_backward (TOP, v1);
1491 AFTER_POTENTIAL_GC ();
1492 break;
1493 }
1494
1495 case Bforward_line:
1496 BEFORE_POTENTIAL_GC ();
1497 TOP = Fforward_line (TOP);
1498 AFTER_POTENTIAL_GC ();
1499 break;
1500
1501 case Bchar_syntax:
1502 {
1503 int c;
1504
1505 BEFORE_POTENTIAL_GC ();
1506 CHECK_CHARACTER (TOP);
1507 AFTER_POTENTIAL_GC ();
1508 c = XFASTINT (TOP);
1509 if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
1510 MAKE_CHAR_MULTIBYTE (c);
1511 XSETFASTINT (TOP, syntax_code_spec[(int) SYNTAX (c)]);
1512 }
1513 break;
1514
1515 case Bbuffer_substring:
1516 {
1517 Lisp_Object v1;
1518 BEFORE_POTENTIAL_GC ();
1519 v1 = POP;
1520 TOP = Fbuffer_substring (TOP, v1);
1521 AFTER_POTENTIAL_GC ();
1522 break;
1523 }
1524
1525 case Bdelete_region:
1526 {
1527 Lisp_Object v1;
1528 BEFORE_POTENTIAL_GC ();
1529 v1 = POP;
1530 TOP = Fdelete_region (TOP, v1);
1531 AFTER_POTENTIAL_GC ();
1532 break;
1533 }
1534
1535 case Bnarrow_to_region:
1536 {
1537 Lisp_Object v1;
1538 BEFORE_POTENTIAL_GC ();
1539 v1 = POP;
1540 TOP = Fnarrow_to_region (TOP, v1);
1541 AFTER_POTENTIAL_GC ();
1542 break;
1543 }
1544
1545 case Bwiden:
1546 BEFORE_POTENTIAL_GC ();
1547 PUSH (Fwiden ());
1548 AFTER_POTENTIAL_GC ();
1549 break;
1550
1551 case Bend_of_line:
1552 BEFORE_POTENTIAL_GC ();
1553 TOP = Fend_of_line (TOP);
1554 AFTER_POTENTIAL_GC ();
1555 break;
1556
1557 case Bset_marker:
1558 {
1559 Lisp_Object v1, v2;
1560 BEFORE_POTENTIAL_GC ();
1561 v1 = POP;
1562 v2 = POP;
1563 TOP = Fset_marker (TOP, v2, v1);
1564 AFTER_POTENTIAL_GC ();
1565 break;
1566 }
1567
1568 case Bmatch_beginning:
1569 BEFORE_POTENTIAL_GC ();
1570 TOP = Fmatch_beginning (TOP);
1571 AFTER_POTENTIAL_GC ();
1572 break;
1573
1574 case Bmatch_end:
1575 BEFORE_POTENTIAL_GC ();
1576 TOP = Fmatch_end (TOP);
1577 AFTER_POTENTIAL_GC ();
1578 break;
1579
1580 case Bupcase:
1581 BEFORE_POTENTIAL_GC ();
1582 TOP = Fupcase (TOP);
1583 AFTER_POTENTIAL_GC ();
1584 break;
1585
1586 case Bdowncase:
1587 BEFORE_POTENTIAL_GC ();
1588 TOP = Fdowncase (TOP);
1589 AFTER_POTENTIAL_GC ();
1590 break;
1591
1592 case Bstringeqlsign:
1593 {
1594 Lisp_Object v1;
1595 BEFORE_POTENTIAL_GC ();
1596 v1 = POP;
1597 TOP = Fstring_equal (TOP, v1);
1598 AFTER_POTENTIAL_GC ();
1599 break;
1600 }
1601
1602 case Bstringlss:
1603 {
1604 Lisp_Object v1;
1605 BEFORE_POTENTIAL_GC ();
1606 v1 = POP;
1607 TOP = Fstring_lessp (TOP, v1);
1608 AFTER_POTENTIAL_GC ();
1609 break;
1610 }
1611
1612 case Bequal:
1613 {
1614 Lisp_Object v1;
1615 v1 = POP;
1616 TOP = Fequal (TOP, v1);
1617 break;
1618 }
1619
1620 case Bnthcdr:
1621 {
1622 Lisp_Object v1;
1623 BEFORE_POTENTIAL_GC ();
1624 v1 = POP;
1625 TOP = Fnthcdr (TOP, v1);
1626 AFTER_POTENTIAL_GC ();
1627 break;
1628 }
1629
1630 case Belt:
1631 {
1632 Lisp_Object v1, v2;
1633 if (CONSP (TOP))
1634 {
1635 /* Exchange args and then do nth. */
1636 BEFORE_POTENTIAL_GC ();
1637 v2 = POP;
1638 v1 = TOP;
1639 CHECK_NUMBER (v2);
1640 AFTER_POTENTIAL_GC ();
1641 op = XINT (v2);
1642 immediate_quit = 1;
1643 while (--op >= 0 && CONSP (v1))
1644 v1 = XCDR (v1);
1645 immediate_quit = 0;
1646 TOP = CAR (v1);
1647 }
1648 else
1649 {
1650 BEFORE_POTENTIAL_GC ();
1651 v1 = POP;
1652 TOP = Felt (TOP, v1);
1653 AFTER_POTENTIAL_GC ();
1654 }
1655 break;
1656 }
1657
1658 case Bmember:
1659 {
1660 Lisp_Object v1;
1661 BEFORE_POTENTIAL_GC ();
1662 v1 = POP;
1663 TOP = Fmember (TOP, v1);
1664 AFTER_POTENTIAL_GC ();
1665 break;
1666 }
1667
1668 case Bassq:
1669 {
1670 Lisp_Object v1;
1671 BEFORE_POTENTIAL_GC ();
1672 v1 = POP;
1673 TOP = Fassq (TOP, v1);
1674 AFTER_POTENTIAL_GC ();
1675 break;
1676 }
1677
1678 case Bnreverse:
1679 BEFORE_POTENTIAL_GC ();
1680 TOP = Fnreverse (TOP);
1681 AFTER_POTENTIAL_GC ();
1682 break;
1683
1684 case Bsetcar:
1685 {
1686 Lisp_Object v1;
1687 BEFORE_POTENTIAL_GC ();
1688 v1 = POP;
1689 TOP = Fsetcar (TOP, v1);
1690 AFTER_POTENTIAL_GC ();
1691 break;
1692 }
1693
1694 case Bsetcdr:
1695 {
1696 Lisp_Object v1;
1697 BEFORE_POTENTIAL_GC ();
1698 v1 = POP;
1699 TOP = Fsetcdr (TOP, v1);
1700 AFTER_POTENTIAL_GC ();
1701 break;
1702 }
1703
1704 case Bcar_safe:
1705 {
1706 Lisp_Object v1;
1707 v1 = TOP;
1708 TOP = CAR_SAFE (v1);
1709 break;
1710 }
1711
1712 case Bcdr_safe:
1713 {
1714 Lisp_Object v1;
1715 v1 = TOP;
1716 TOP = CDR_SAFE (v1);
1717 break;
1718 }
1719
1720 case Bnconc:
1721 BEFORE_POTENTIAL_GC ();
1722 DISCARD (1);
1723 TOP = Fnconc (2, &TOP);
1724 AFTER_POTENTIAL_GC ();
1725 break;
1726
1727 case Bnumberp:
1728 TOP = (NUMBERP (TOP) ? Qt : Qnil);
1729 break;
1730
1731 case Bintegerp:
1732 TOP = INTEGERP (TOP) ? Qt : Qnil;
1733 break;
1734
1735 #ifdef BYTE_CODE_SAFE
1736 case Bset_mark:
1737 BEFORE_POTENTIAL_GC ();
1738 error ("set-mark is an obsolete bytecode");
1739 AFTER_POTENTIAL_GC ();
1740 break;
1741 case Bscan_buffer:
1742 BEFORE_POTENTIAL_GC ();
1743 error ("scan-buffer is an obsolete bytecode");
1744 AFTER_POTENTIAL_GC ();
1745 break;
1746 #endif
1747
1748 case 0:
1749 /* Actually this is Bstack_ref with offset 0, but we use Bdup
1750 for that instead. */
1751 /* case Bstack_ref: */
1752 abort ();
1753
1754 /* Handy byte-codes for lexical binding. */
1755 case Bstack_ref+1:
1756 case Bstack_ref+2:
1757 case Bstack_ref+3:
1758 case Bstack_ref+4:
1759 case Bstack_ref+5:
1760 {
1761 Lisp_Object *ptr = top - (op - Bstack_ref);
1762 PUSH (*ptr);
1763 break;
1764 }
1765 case Bstack_ref+6:
1766 {
1767 Lisp_Object *ptr = top - (FETCH);
1768 PUSH (*ptr);
1769 break;
1770 }
1771 case Bstack_ref+7:
1772 {
1773 Lisp_Object *ptr = top - (FETCH2);
1774 PUSH (*ptr);
1775 break;
1776 }
1777 /* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos. */
1778 case Bstack_set:
1779 {
1780 Lisp_Object *ptr = top - (FETCH);
1781 *ptr = POP;
1782 break;
1783 }
1784 case Bstack_set2:
1785 {
1786 Lisp_Object *ptr = top - (FETCH2);
1787 *ptr = POP;
1788 break;
1789 }
1790 case BdiscardN:
1791 op = FETCH;
1792 if (op & 0x80)
1793 {
1794 op &= 0x7F;
1795 top[-op] = TOP;
1796 }
1797 DISCARD (op);
1798 break;
1799
1800 case 255:
1801 default:
1802 #ifdef BYTE_CODE_SAFE
1803 if (op < Bconstant)
1804 {
1805 abort ();
1806 }
1807 if ((op -= Bconstant) >= const_length)
1808 {
1809 abort ();
1810 }
1811 PUSH (vectorp[op]);
1812 #else
1813 PUSH (vectorp[op - Bconstant]);
1814 #endif
1815 }
1816 }
1817
1818 exit:
1819
1820 byte_stack_list = byte_stack_list->next;
1821
1822 /* Binds and unbinds are supposed to be compiled balanced. */
1823 if (SPECPDL_INDEX () != count)
1824 #ifdef BYTE_CODE_SAFE
1825 error ("binding stack not balanced (serious byte compiler bug)");
1826 #else
1827 abort ();
1828 #endif
1829
1830 return result;
1831 }
1832
1833 void
1834 syms_of_bytecode (void)
1835 {
1836 Qbytecode = intern_c_string ("byte-code");
1837 staticpro (&Qbytecode);
1838
1839 defsubr (&Sbyte_code);
1840
1841 #ifdef BYTE_CODE_METER
1842
1843 DEFVAR_LISP ("byte-code-meter", Vbyte_code_meter,
1844 doc: /* A vector of vectors which holds a histogram of byte-code usage.
1845 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
1846 opcode CODE has been executed.
1847 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
1848 indicates how many times the byte opcodes CODE1 and CODE2 have been
1849 executed in succession. */);
1850
1851 DEFVAR_BOOL ("byte-metering-on", byte_metering_on,
1852 doc: /* If non-nil, keep profiling information on byte code usage.
1853 The variable byte-code-meter indicates how often each byte opcode is used.
1854 If a symbol has a property named `byte-code-meter' whose value is an
1855 integer, it is incremented each time that symbol's function is called. */);
1856
1857 byte_metering_on = 0;
1858 Vbyte_code_meter = Fmake_vector (make_number (256), make_number (0));
1859 Qbyte_code_meter = intern_c_string ("byte-code-meter");
1860 staticpro (&Qbyte_code_meter);
1861 {
1862 int i = 256;
1863 while (i--)
1864 XVECTOR (Vbyte_code_meter)->contents[i] =
1865 Fmake_vector (make_number (256), make_number (0));
1866 }
1867 #endif
1868 }
Unnamed repository; edit this file 'description' to name the repository.