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