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