Avoid crash on composition (backport from trunk).
[emacs.git] / src / bytecode.c
blobfd119c58e19d206de9f93a38ed4b58986009ac41
1 /* Execution of byte code produced by bytecomp.el.
2 Copyright (C) 1985, 1986, 1987, 1988, 1993, 2000, 2001, 2002, 2003, 2004,
3 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
21 hacked on by jwz@lucid.com 17-jun-91
22 o added a compile-time switch to turn on simple sanity checking;
23 o put back the obsolete byte-codes for error-detection;
24 o added a new instruction, unbind_all, which I will use for
25 tail-recursion elimination;
26 o made temp_output_buffer_show be called with the right number
27 of args;
28 o made the new bytecodes be called with args in the right order;
29 o added metering support.
31 by Hallvard:
32 o added relative jump instructions;
33 o all conditionals now only do QUIT if they jump.
36 #include <config.h>
37 #include <setjmp.h>
38 #include "lisp.h"
39 #include "buffer.h"
40 #include "character.h"
41 #include "syntax.h"
42 #include "window.h"
44 #ifdef CHECK_FRAME_FONT
45 #include "frame.h"
46 #include "xterm.h"
47 #endif
50 * define BYTE_CODE_SAFE to enable some minor sanity checking (useful for
51 * debugging the byte compiler...)
53 * define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
55 /* #define BYTE_CODE_SAFE */
56 /* #define BYTE_CODE_METER */
59 #ifdef BYTE_CODE_METER
61 Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
62 int byte_metering_on;
64 #define METER_2(code1, code2) \
65 XFASTINT (XVECTOR (XVECTOR (Vbyte_code_meter)->contents[(code1)]) \
66 ->contents[(code2)])
68 #define METER_1(code) METER_2 (0, (code))
70 #define METER_CODE(last_code, this_code) \
71 { \
72 if (byte_metering_on) \
73 { \
74 if (METER_1 (this_code) < MOST_POSITIVE_FIXNUM) \
75 METER_1 (this_code)++; \
76 if (last_code \
77 && METER_2 (last_code, this_code) < MOST_POSITIVE_FIXNUM) \
78 METER_2 (last_code, this_code)++; \
79 } \
82 #else /* no BYTE_CODE_METER */
84 #define METER_CODE(last_code, this_code)
86 #endif /* no BYTE_CODE_METER */
89 Lisp_Object Qbytecode;
91 /* Byte codes: */
93 #define Bvarref 010
94 #define Bvarset 020
95 #define Bvarbind 030
96 #define Bcall 040
97 #define Bunbind 050
99 #define Bnth 070
100 #define Bsymbolp 071
101 #define Bconsp 072
102 #define Bstringp 073
103 #define Blistp 074
104 #define Beq 075
105 #define Bmemq 076
106 #define Bnot 077
107 #define Bcar 0100
108 #define Bcdr 0101
109 #define Bcons 0102
110 #define Blist1 0103
111 #define Blist2 0104
112 #define Blist3 0105
113 #define Blist4 0106
114 #define Blength 0107
115 #define Baref 0110
116 #define Baset 0111
117 #define Bsymbol_value 0112
118 #define Bsymbol_function 0113
119 #define Bset 0114
120 #define Bfset 0115
121 #define Bget 0116
122 #define Bsubstring 0117
123 #define Bconcat2 0120
124 #define Bconcat3 0121
125 #define Bconcat4 0122
126 #define Bsub1 0123
127 #define Badd1 0124
128 #define Beqlsign 0125
129 #define Bgtr 0126
130 #define Blss 0127
131 #define Bleq 0130
132 #define Bgeq 0131
133 #define Bdiff 0132
134 #define Bnegate 0133
135 #define Bplus 0134
136 #define Bmax 0135
137 #define Bmin 0136
138 #define Bmult 0137
140 #define Bpoint 0140
141 /* Was Bmark in v17. */
142 #define Bsave_current_buffer 0141
143 #define Bgoto_char 0142
144 #define Binsert 0143
145 #define Bpoint_max 0144
146 #define Bpoint_min 0145
147 #define Bchar_after 0146
148 #define Bfollowing_char 0147
149 #define Bpreceding_char 0150
150 #define Bcurrent_column 0151
151 #define Bindent_to 0152
152 #define Bscan_buffer 0153 /* No longer generated as of v18 */
153 #define Beolp 0154
154 #define Beobp 0155
155 #define Bbolp 0156
156 #define Bbobp 0157
157 #define Bcurrent_buffer 0160
158 #define Bset_buffer 0161
159 #define Bsave_current_buffer_1 0162 /* Replacing Bsave_current_buffer. */
160 #define Bread_char 0162 /* No longer generated as of v19 */
161 #define Bset_mark 0163 /* this loser is no longer generated as of v18 */
162 #define Binteractive_p 0164 /* Needed since interactive-p takes unevalled args */
164 #define Bforward_char 0165
165 #define Bforward_word 0166
166 #define Bskip_chars_forward 0167
167 #define Bskip_chars_backward 0170
168 #define Bforward_line 0171
169 #define Bchar_syntax 0172
170 #define Bbuffer_substring 0173
171 #define Bdelete_region 0174
172 #define Bnarrow_to_region 0175
173 #define Bwiden 0176
174 #define Bend_of_line 0177
176 #define Bconstant2 0201
177 #define Bgoto 0202
178 #define Bgotoifnil 0203
179 #define Bgotoifnonnil 0204
180 #define Bgotoifnilelsepop 0205
181 #define Bgotoifnonnilelsepop 0206
182 #define Breturn 0207
183 #define Bdiscard 0210
184 #define Bdup 0211
186 #define Bsave_excursion 0212
187 #define Bsave_window_excursion 0213
188 #define Bsave_restriction 0214
189 #define Bcatch 0215
191 #define Bunwind_protect 0216
192 #define Bcondition_case 0217
193 #define Btemp_output_buffer_setup 0220
194 #define Btemp_output_buffer_show 0221
196 #define Bunbind_all 0222
198 #define Bset_marker 0223
199 #define Bmatch_beginning 0224
200 #define Bmatch_end 0225
201 #define Bupcase 0226
202 #define Bdowncase 0227
204 #define Bstringeqlsign 0230
205 #define Bstringlss 0231
206 #define Bequal 0232
207 #define Bnthcdr 0233
208 #define Belt 0234
209 #define Bmember 0235
210 #define Bassq 0236
211 #define Bnreverse 0237
212 #define Bsetcar 0240
213 #define Bsetcdr 0241
214 #define Bcar_safe 0242
215 #define Bcdr_safe 0243
216 #define Bnconc 0244
217 #define Bquo 0245
218 #define Brem 0246
219 #define Bnumberp 0247
220 #define Bintegerp 0250
222 #define BRgoto 0252
223 #define BRgotoifnil 0253
224 #define BRgotoifnonnil 0254
225 #define BRgotoifnilelsepop 0255
226 #define BRgotoifnonnilelsepop 0256
228 #define BlistN 0257
229 #define BconcatN 0260
230 #define BinsertN 0261
232 #define Bconstant 0300
233 #define CONSTANTLIM 0100
236 /* Structure describing a value stack used during byte-code execution
237 in Fbyte_code. */
239 struct byte_stack
241 /* Program counter. This points into the byte_string below
242 and is relocated when that string is relocated. */
243 const unsigned char *pc;
245 /* Top and bottom of stack. The bottom points to an area of memory
246 allocated with alloca in Fbyte_code. */
247 Lisp_Object *top, *bottom;
249 /* The string containing the byte-code, and its current address.
250 Storing this here protects it from GC because mark_byte_stack
251 marks it. */
252 Lisp_Object byte_string;
253 const unsigned char *byte_string_start;
255 /* The vector of constants used during byte-code execution. Storing
256 this here protects it from GC because mark_byte_stack marks it. */
257 Lisp_Object constants;
259 /* Next entry in byte_stack_list. */
260 struct byte_stack *next;
263 /* A list of currently active byte-code execution value stacks.
264 Fbyte_code adds an entry to the head of this list before it starts
265 processing byte-code, and it removed the entry again when it is
266 done. Signalling an error truncates the list analoguous to
267 gcprolist. */
269 struct byte_stack *byte_stack_list;
272 /* Mark objects on byte_stack_list. Called during GC. */
274 void
275 mark_byte_stack ()
277 struct byte_stack *stack;
278 Lisp_Object *obj;
280 for (stack = byte_stack_list; stack; stack = stack->next)
282 /* If STACK->top is null here, this means there's an opcode in
283 Fbyte_code that wasn't expected to GC, but did. To find out
284 which opcode this is, record the value of `stack', and walk
285 up the stack in a debugger, stopping in frames of Fbyte_code.
286 The culprit is found in the frame of Fbyte_code where the
287 address of its local variable `stack' is equal to the
288 recorded value of `stack' here. */
289 eassert (stack->top);
291 for (obj = stack->bottom; obj <= stack->top; ++obj)
292 mark_object (*obj);
294 mark_object (stack->byte_string);
295 mark_object (stack->constants);
300 /* Unmark objects in the stacks on byte_stack_list. Relocate program
301 counters. Called when GC has completed. */
303 void
304 unmark_byte_stack ()
306 struct byte_stack *stack;
308 for (stack = byte_stack_list; stack; stack = stack->next)
310 if (stack->byte_string_start != SDATA (stack->byte_string))
312 int offset = stack->pc - stack->byte_string_start;
313 stack->byte_string_start = SDATA (stack->byte_string);
314 stack->pc = stack->byte_string_start + offset;
320 /* Fetch the next byte from the bytecode stream */
322 #define FETCH *stack.pc++
324 /* Fetch two bytes from the bytecode stream and make a 16-bit number
325 out of them */
327 #define FETCH2 (op = FETCH, op + (FETCH << 8))
329 /* Push x onto the execution stack. This used to be #define PUSH(x)
330 (*++stackp = (x)) This oddity is necessary because Alliant can't be
331 bothered to compile the preincrement operator properly, as of 4/91.
332 -JimB */
334 #define PUSH(x) (top++, *top = (x))
336 /* Pop a value off the execution stack. */
338 #define POP (*top--)
340 /* Discard n values from the execution stack. */
342 #define DISCARD(n) (top -= (n))
344 /* Get the value which is at the top of the execution stack, but don't
345 pop it. */
347 #define TOP (*top)
349 /* Actions that must be performed before and after calling a function
350 that might GC. */
352 #define BEFORE_POTENTIAL_GC() stack.top = top
353 #define AFTER_POTENTIAL_GC() stack.top = NULL
355 /* Garbage collect if we have consed enough since the last time.
356 We do this at every branch, to avoid loops that never GC. */
358 #define MAYBE_GC() \
359 if (consing_since_gc > gc_cons_threshold \
360 && consing_since_gc > gc_relative_threshold) \
362 BEFORE_POTENTIAL_GC (); \
363 Fgarbage_collect (); \
364 AFTER_POTENTIAL_GC (); \
366 else
368 /* Check for jumping out of range. */
370 #ifdef BYTE_CODE_SAFE
372 #define CHECK_RANGE(ARG) \
373 if (ARG >= bytestr_length) abort ()
375 #else /* not BYTE_CODE_SAFE */
377 #define CHECK_RANGE(ARG)
379 #endif /* not BYTE_CODE_SAFE */
381 /* A version of the QUIT macro which makes sure that the stack top is
382 set before signaling `quit'. */
384 #define BYTE_CODE_QUIT \
385 do { \
386 if (!NILP (Vquit_flag) && NILP (Vinhibit_quit)) \
388 Lisp_Object flag = Vquit_flag; \
389 Vquit_flag = Qnil; \
390 BEFORE_POTENTIAL_GC (); \
391 if (EQ (Vthrow_on_input, flag)) \
392 Fthrow (Vthrow_on_input, Qt); \
393 Fsignal (Qquit, Qnil); \
394 AFTER_POTENTIAL_GC (); \
396 ELSE_PENDING_SIGNALS \
397 } while (0)
400 DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0,
401 doc: /* Function used internally in byte-compiled code.
402 The first argument, BYTESTR, is a string of byte code;
403 the second, VECTOR, a vector of constants;
404 the third, MAXDEPTH, the maximum stack depth used in this function.
405 If the third argument is incorrect, Emacs may crash. */)
406 (bytestr, vector, maxdepth)
407 Lisp_Object bytestr, vector, maxdepth;
409 int count = SPECPDL_INDEX ();
410 #ifdef BYTE_CODE_METER
411 int this_op = 0;
412 int prev_op;
413 #endif
414 int op;
415 /* Lisp_Object v1, v2; */
416 Lisp_Object *vectorp;
417 #ifdef BYTE_CODE_SAFE
418 int const_length;
419 Lisp_Object *stacke;
420 #endif
421 int bytestr_length;
422 struct byte_stack stack;
423 Lisp_Object *top;
424 Lisp_Object result;
426 #if 0 /* CHECK_FRAME_FONT */
428 struct frame *f = SELECTED_FRAME ();
429 if (FRAME_X_P (f)
430 && FRAME_FONT (f)->direction != 0
431 && FRAME_FONT (f)->direction != 1)
432 abort ();
434 #endif
436 CHECK_STRING (bytestr);
437 CHECK_VECTOR (vector);
438 CHECK_NUMBER (maxdepth);
440 #ifdef BYTE_CODE_SAFE
441 const_length = XVECTOR_SIZE (vector);
442 #endif
443 if (STRING_MULTIBYTE (bytestr))
444 /* BYTESTR must have been produced by Emacs 20.2 or the earlier
445 because they produced a raw 8-bit string for byte-code and now
446 such a byte-code string is loaded as multibyte while raw 8-bit
447 characters converted to multibyte form. Thus, now we must
448 convert them back to the originally intended unibyte form. */
449 bytestr = Fstring_as_unibyte (bytestr);
451 bytestr_length = SBYTES (bytestr);
452 vectorp = XVECTOR (vector)->contents;
454 stack.byte_string = bytestr;
455 stack.pc = stack.byte_string_start = SDATA (bytestr);
456 stack.constants = vector;
457 stack.bottom = (Lisp_Object *) alloca (XFASTINT (maxdepth)
458 * sizeof (Lisp_Object));
459 top = stack.bottom - 1;
460 stack.top = NULL;
461 stack.next = byte_stack_list;
462 byte_stack_list = &stack;
464 #ifdef BYTE_CODE_SAFE
465 stacke = stack.bottom - 1 + XFASTINT (maxdepth);
466 #endif
468 while (1)
470 #ifdef BYTE_CODE_SAFE
471 if (top > stacke)
472 abort ();
473 else if (top < stack.bottom - 1)
474 abort ();
475 #endif
477 #ifdef BYTE_CODE_METER
478 prev_op = this_op;
479 this_op = op = FETCH;
480 METER_CODE (prev_op, op);
481 #else
482 op = FETCH;
483 #endif
485 switch (op)
487 case Bvarref + 7:
488 op = FETCH2;
489 goto varref;
491 case Bvarref:
492 case Bvarref + 1:
493 case Bvarref + 2:
494 case Bvarref + 3:
495 case Bvarref + 4:
496 case Bvarref + 5:
497 op = op - Bvarref;
498 goto varref;
500 /* This seems to be the most frequently executed byte-code
501 among the Bvarref's, so avoid a goto here. */
502 case Bvarref+6:
503 op = FETCH;
504 varref:
506 Lisp_Object v1, v2;
508 v1 = vectorp[op];
509 if (SYMBOLP (v1))
511 v2 = SYMBOL_VALUE (v1);
512 if (MISCP (v2) || EQ (v2, Qunbound))
514 BEFORE_POTENTIAL_GC ();
515 v2 = Fsymbol_value (v1);
516 AFTER_POTENTIAL_GC ();
519 else
521 BEFORE_POTENTIAL_GC ();
522 v2 = Fsymbol_value (v1);
523 AFTER_POTENTIAL_GC ();
525 PUSH (v2);
526 break;
529 case Bgotoifnil:
531 Lisp_Object v1;
532 MAYBE_GC ();
533 op = FETCH2;
534 v1 = POP;
535 if (NILP (v1))
537 BYTE_CODE_QUIT;
538 CHECK_RANGE (op);
539 stack.pc = stack.byte_string_start + op;
541 break;
544 case Bcar:
546 Lisp_Object v1;
547 v1 = TOP;
548 TOP = CAR (v1);
549 break;
552 case Beq:
554 Lisp_Object v1;
555 v1 = POP;
556 TOP = EQ (v1, TOP) ? Qt : Qnil;
557 break;
560 case Bmemq:
562 Lisp_Object v1;
563 BEFORE_POTENTIAL_GC ();
564 v1 = POP;
565 TOP = Fmemq (TOP, v1);
566 AFTER_POTENTIAL_GC ();
567 break;
570 case Bcdr:
572 Lisp_Object v1;
573 v1 = TOP;
574 TOP = CDR (v1);
575 break;
578 case Bvarset:
579 case Bvarset+1:
580 case Bvarset+2:
581 case Bvarset+3:
582 case Bvarset+4:
583 case Bvarset+5:
584 op -= Bvarset;
585 goto varset;
587 case Bvarset+7:
588 op = FETCH2;
589 goto varset;
591 case Bvarset+6:
592 op = FETCH;
593 varset:
595 Lisp_Object sym, val;
597 sym = vectorp[op];
598 val = TOP;
600 /* Inline the most common case. */
601 if (SYMBOLP (sym)
602 && !EQ (val, Qunbound)
603 && !XSYMBOL (sym)->indirect_variable
604 && !SYMBOL_CONSTANT_P (sym)
605 && !MISCP (XSYMBOL (sym)->value))
606 XSYMBOL (sym)->value = val;
607 else
609 BEFORE_POTENTIAL_GC ();
610 set_internal (sym, val, current_buffer, 0);
611 AFTER_POTENTIAL_GC ();
614 (void) POP;
615 break;
617 case Bdup:
619 Lisp_Object v1;
620 v1 = TOP;
621 PUSH (v1);
622 break;
625 /* ------------------ */
627 case Bvarbind+6:
628 op = FETCH;
629 goto varbind;
631 case Bvarbind+7:
632 op = FETCH2;
633 goto varbind;
635 case Bvarbind:
636 case Bvarbind+1:
637 case Bvarbind+2:
638 case Bvarbind+3:
639 case Bvarbind+4:
640 case Bvarbind+5:
641 op -= Bvarbind;
642 varbind:
643 /* Specbind can signal and thus GC. */
644 BEFORE_POTENTIAL_GC ();
645 specbind (vectorp[op], POP);
646 AFTER_POTENTIAL_GC ();
647 break;
649 case Bcall+6:
650 op = FETCH;
651 goto docall;
653 case Bcall+7:
654 op = FETCH2;
655 goto docall;
657 case Bcall:
658 case Bcall+1:
659 case Bcall+2:
660 case Bcall+3:
661 case Bcall+4:
662 case Bcall+5:
663 op -= Bcall;
664 docall:
666 BEFORE_POTENTIAL_GC ();
667 DISCARD (op);
668 #ifdef BYTE_CODE_METER
669 if (byte_metering_on && SYMBOLP (TOP))
671 Lisp_Object v1, v2;
673 v1 = TOP;
674 v2 = Fget (v1, Qbyte_code_meter);
675 if (INTEGERP (v2)
676 && XINT (v2) < MOST_POSITIVE_FIXNUM)
678 XSETINT (v2, XINT (v2) + 1);
679 Fput (v1, Qbyte_code_meter, v2);
682 #endif
683 TOP = Ffuncall (op + 1, &TOP);
684 AFTER_POTENTIAL_GC ();
685 break;
688 case Bunbind+6:
689 op = FETCH;
690 goto dounbind;
692 case Bunbind+7:
693 op = FETCH2;
694 goto dounbind;
696 case Bunbind:
697 case Bunbind+1:
698 case Bunbind+2:
699 case Bunbind+3:
700 case Bunbind+4:
701 case Bunbind+5:
702 op -= Bunbind;
703 dounbind:
704 BEFORE_POTENTIAL_GC ();
705 unbind_to (SPECPDL_INDEX () - op, Qnil);
706 AFTER_POTENTIAL_GC ();
707 break;
709 case Bunbind_all:
710 /* To unbind back to the beginning of this frame. Not used yet,
711 but will be needed for tail-recursion elimination. */
712 BEFORE_POTENTIAL_GC ();
713 unbind_to (count, Qnil);
714 AFTER_POTENTIAL_GC ();
715 break;
717 case Bgoto:
718 MAYBE_GC ();
719 BYTE_CODE_QUIT;
720 op = FETCH2; /* pc = FETCH2 loses since FETCH2 contains pc++ */
721 CHECK_RANGE (op);
722 stack.pc = stack.byte_string_start + op;
723 break;
725 case Bgotoifnonnil:
727 Lisp_Object v1;
728 MAYBE_GC ();
729 op = FETCH2;
730 v1 = POP;
731 if (!NILP (v1))
733 BYTE_CODE_QUIT;
734 CHECK_RANGE (op);
735 stack.pc = stack.byte_string_start + op;
737 break;
740 case Bgotoifnilelsepop:
741 MAYBE_GC ();
742 op = FETCH2;
743 if (NILP (TOP))
745 BYTE_CODE_QUIT;
746 CHECK_RANGE (op);
747 stack.pc = stack.byte_string_start + op;
749 else DISCARD (1);
750 break;
752 case Bgotoifnonnilelsepop:
753 MAYBE_GC ();
754 op = FETCH2;
755 if (!NILP (TOP))
757 BYTE_CODE_QUIT;
758 CHECK_RANGE (op);
759 stack.pc = stack.byte_string_start + op;
761 else DISCARD (1);
762 break;
764 case BRgoto:
765 MAYBE_GC ();
766 BYTE_CODE_QUIT;
767 stack.pc += (int) *stack.pc - 127;
768 break;
770 case BRgotoifnil:
772 Lisp_Object v1;
773 MAYBE_GC ();
774 v1 = POP;
775 if (NILP (v1))
777 BYTE_CODE_QUIT;
778 stack.pc += (int) *stack.pc - 128;
780 stack.pc++;
781 break;
784 case BRgotoifnonnil:
786 Lisp_Object v1;
787 MAYBE_GC ();
788 v1 = POP;
789 if (!NILP (v1))
791 BYTE_CODE_QUIT;
792 stack.pc += (int) *stack.pc - 128;
794 stack.pc++;
795 break;
798 case BRgotoifnilelsepop:
799 MAYBE_GC ();
800 op = *stack.pc++;
801 if (NILP (TOP))
803 BYTE_CODE_QUIT;
804 stack.pc += op - 128;
806 else DISCARD (1);
807 break;
809 case BRgotoifnonnilelsepop:
810 MAYBE_GC ();
811 op = *stack.pc++;
812 if (!NILP (TOP))
814 BYTE_CODE_QUIT;
815 stack.pc += op - 128;
817 else DISCARD (1);
818 break;
820 case Breturn:
821 result = POP;
822 goto exit;
824 case Bdiscard:
825 DISCARD (1);
826 break;
828 case Bconstant2:
829 PUSH (vectorp[FETCH2]);
830 break;
832 case Bsave_excursion:
833 record_unwind_protect (save_excursion_restore,
834 save_excursion_save ());
835 break;
837 case Bsave_current_buffer:
838 case Bsave_current_buffer_1:
839 record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ());
840 break;
842 case Bsave_window_excursion:
843 BEFORE_POTENTIAL_GC ();
844 TOP = Fsave_window_excursion (TOP);
845 AFTER_POTENTIAL_GC ();
846 break;
848 case Bsave_restriction:
849 record_unwind_protect (save_restriction_restore,
850 save_restriction_save ());
851 break;
853 case Bcatch:
855 Lisp_Object v1;
856 BEFORE_POTENTIAL_GC ();
857 v1 = POP;
858 TOP = internal_catch (TOP, Feval, v1);
859 AFTER_POTENTIAL_GC ();
860 break;
863 case Bunwind_protect:
864 record_unwind_protect (Fprogn, POP);
865 break;
867 case Bcondition_case:
869 Lisp_Object handlers, body;
870 handlers = POP;
871 body = POP;
872 BEFORE_POTENTIAL_GC ();
873 TOP = internal_lisp_condition_case (TOP, body, handlers);
874 AFTER_POTENTIAL_GC ();
875 break;
878 case Btemp_output_buffer_setup:
879 BEFORE_POTENTIAL_GC ();
880 CHECK_STRING (TOP);
881 temp_output_buffer_setup (SDATA (TOP));
882 AFTER_POTENTIAL_GC ();
883 TOP = Vstandard_output;
884 break;
886 case Btemp_output_buffer_show:
888 Lisp_Object v1;
889 BEFORE_POTENTIAL_GC ();
890 v1 = POP;
891 temp_output_buffer_show (TOP);
892 TOP = v1;
893 /* pop binding of standard-output */
894 unbind_to (SPECPDL_INDEX () - 1, Qnil);
895 AFTER_POTENTIAL_GC ();
896 break;
899 case Bnth:
901 Lisp_Object v1, v2;
902 BEFORE_POTENTIAL_GC ();
903 v1 = POP;
904 v2 = TOP;
905 CHECK_NUMBER (v2);
906 AFTER_POTENTIAL_GC ();
907 op = XINT (v2);
908 immediate_quit = 1;
909 while (--op >= 0 && CONSP (v1))
910 v1 = XCDR (v1);
911 immediate_quit = 0;
912 TOP = CAR (v1);
913 break;
916 case Bsymbolp:
917 TOP = SYMBOLP (TOP) ? Qt : Qnil;
918 break;
920 case Bconsp:
921 TOP = CONSP (TOP) ? Qt : Qnil;
922 break;
924 case Bstringp:
925 TOP = STRINGP (TOP) ? Qt : Qnil;
926 break;
928 case Blistp:
929 TOP = CONSP (TOP) || NILP (TOP) ? Qt : Qnil;
930 break;
932 case Bnot:
933 TOP = NILP (TOP) ? Qt : Qnil;
934 break;
936 case Bcons:
938 Lisp_Object v1;
939 v1 = POP;
940 TOP = Fcons (TOP, v1);
941 break;
944 case Blist1:
945 TOP = Fcons (TOP, Qnil);
946 break;
948 case Blist2:
950 Lisp_Object v1;
951 v1 = POP;
952 TOP = Fcons (TOP, Fcons (v1, Qnil));
953 break;
956 case Blist3:
957 DISCARD (2);
958 TOP = Flist (3, &TOP);
959 break;
961 case Blist4:
962 DISCARD (3);
963 TOP = Flist (4, &TOP);
964 break;
966 case BlistN:
967 op = FETCH;
968 DISCARD (op - 1);
969 TOP = Flist (op, &TOP);
970 break;
972 case Blength:
973 BEFORE_POTENTIAL_GC ();
974 TOP = Flength (TOP);
975 AFTER_POTENTIAL_GC ();
976 break;
978 case Baref:
980 Lisp_Object v1;
981 BEFORE_POTENTIAL_GC ();
982 v1 = POP;
983 TOP = Faref (TOP, v1);
984 AFTER_POTENTIAL_GC ();
985 break;
988 case Baset:
990 Lisp_Object v1, v2;
991 BEFORE_POTENTIAL_GC ();
992 v2 = POP; v1 = POP;
993 TOP = Faset (TOP, v1, v2);
994 AFTER_POTENTIAL_GC ();
995 break;
998 case Bsymbol_value:
999 BEFORE_POTENTIAL_GC ();
1000 TOP = Fsymbol_value (TOP);
1001 AFTER_POTENTIAL_GC ();
1002 break;
1004 case Bsymbol_function:
1005 BEFORE_POTENTIAL_GC ();
1006 TOP = Fsymbol_function (TOP);
1007 AFTER_POTENTIAL_GC ();
1008 break;
1010 case Bset:
1012 Lisp_Object v1;
1013 BEFORE_POTENTIAL_GC ();
1014 v1 = POP;
1015 TOP = Fset (TOP, v1);
1016 AFTER_POTENTIAL_GC ();
1017 break;
1020 case Bfset:
1022 Lisp_Object v1;
1023 BEFORE_POTENTIAL_GC ();
1024 v1 = POP;
1025 TOP = Ffset (TOP, v1);
1026 AFTER_POTENTIAL_GC ();
1027 break;
1030 case Bget:
1032 Lisp_Object v1;
1033 BEFORE_POTENTIAL_GC ();
1034 v1 = POP;
1035 TOP = Fget (TOP, v1);
1036 AFTER_POTENTIAL_GC ();
1037 break;
1040 case Bsubstring:
1042 Lisp_Object v1, v2;
1043 BEFORE_POTENTIAL_GC ();
1044 v2 = POP; v1 = POP;
1045 TOP = Fsubstring (TOP, v1, v2);
1046 AFTER_POTENTIAL_GC ();
1047 break;
1050 case Bconcat2:
1051 BEFORE_POTENTIAL_GC ();
1052 DISCARD (1);
1053 TOP = Fconcat (2, &TOP);
1054 AFTER_POTENTIAL_GC ();
1055 break;
1057 case Bconcat3:
1058 BEFORE_POTENTIAL_GC ();
1059 DISCARD (2);
1060 TOP = Fconcat (3, &TOP);
1061 AFTER_POTENTIAL_GC ();
1062 break;
1064 case Bconcat4:
1065 BEFORE_POTENTIAL_GC ();
1066 DISCARD (3);
1067 TOP = Fconcat (4, &TOP);
1068 AFTER_POTENTIAL_GC ();
1069 break;
1071 case BconcatN:
1072 op = FETCH;
1073 BEFORE_POTENTIAL_GC ();
1074 DISCARD (op - 1);
1075 TOP = Fconcat (op, &TOP);
1076 AFTER_POTENTIAL_GC ();
1077 break;
1079 case Bsub1:
1081 Lisp_Object v1;
1082 v1 = TOP;
1083 if (INTEGERP (v1))
1085 XSETINT (v1, XINT (v1) - 1);
1086 TOP = v1;
1088 else
1090 BEFORE_POTENTIAL_GC ();
1091 TOP = Fsub1 (v1);
1092 AFTER_POTENTIAL_GC ();
1094 break;
1097 case Badd1:
1099 Lisp_Object v1;
1100 v1 = TOP;
1101 if (INTEGERP (v1))
1103 XSETINT (v1, XINT (v1) + 1);
1104 TOP = v1;
1106 else
1108 BEFORE_POTENTIAL_GC ();
1109 TOP = Fadd1 (v1);
1110 AFTER_POTENTIAL_GC ();
1112 break;
1115 case Beqlsign:
1117 Lisp_Object v1, v2;
1118 BEFORE_POTENTIAL_GC ();
1119 v2 = POP; v1 = TOP;
1120 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v1);
1121 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v2);
1122 AFTER_POTENTIAL_GC ();
1123 if (FLOATP (v1) || FLOATP (v2))
1125 double f1, f2;
1127 f1 = (FLOATP (v1) ? XFLOAT_DATA (v1) : XINT (v1));
1128 f2 = (FLOATP (v2) ? XFLOAT_DATA (v2) : XINT (v2));
1129 TOP = (f1 == f2 ? Qt : Qnil);
1131 else
1132 TOP = (XINT (v1) == XINT (v2) ? Qt : Qnil);
1133 break;
1136 case Bgtr:
1138 Lisp_Object v1;
1139 BEFORE_POTENTIAL_GC ();
1140 v1 = POP;
1141 TOP = Fgtr (TOP, v1);
1142 AFTER_POTENTIAL_GC ();
1143 break;
1146 case Blss:
1148 Lisp_Object v1;
1149 BEFORE_POTENTIAL_GC ();
1150 v1 = POP;
1151 TOP = Flss (TOP, v1);
1152 AFTER_POTENTIAL_GC ();
1153 break;
1156 case Bleq:
1158 Lisp_Object v1;
1159 BEFORE_POTENTIAL_GC ();
1160 v1 = POP;
1161 TOP = Fleq (TOP, v1);
1162 AFTER_POTENTIAL_GC ();
1163 break;
1166 case Bgeq:
1168 Lisp_Object v1;
1169 BEFORE_POTENTIAL_GC ();
1170 v1 = POP;
1171 TOP = Fgeq (TOP, v1);
1172 AFTER_POTENTIAL_GC ();
1173 break;
1176 case Bdiff:
1177 BEFORE_POTENTIAL_GC ();
1178 DISCARD (1);
1179 TOP = Fminus (2, &TOP);
1180 AFTER_POTENTIAL_GC ();
1181 break;
1183 case Bnegate:
1185 Lisp_Object v1;
1186 v1 = TOP;
1187 if (INTEGERP (v1))
1189 XSETINT (v1, - XINT (v1));
1190 TOP = v1;
1192 else
1194 BEFORE_POTENTIAL_GC ();
1195 TOP = Fminus (1, &TOP);
1196 AFTER_POTENTIAL_GC ();
1198 break;
1201 case Bplus:
1202 BEFORE_POTENTIAL_GC ();
1203 DISCARD (1);
1204 TOP = Fplus (2, &TOP);
1205 AFTER_POTENTIAL_GC ();
1206 break;
1208 case Bmax:
1209 BEFORE_POTENTIAL_GC ();
1210 DISCARD (1);
1211 TOP = Fmax (2, &TOP);
1212 AFTER_POTENTIAL_GC ();
1213 break;
1215 case Bmin:
1216 BEFORE_POTENTIAL_GC ();
1217 DISCARD (1);
1218 TOP = Fmin (2, &TOP);
1219 AFTER_POTENTIAL_GC ();
1220 break;
1222 case Bmult:
1223 BEFORE_POTENTIAL_GC ();
1224 DISCARD (1);
1225 TOP = Ftimes (2, &TOP);
1226 AFTER_POTENTIAL_GC ();
1227 break;
1229 case Bquo:
1230 BEFORE_POTENTIAL_GC ();
1231 DISCARD (1);
1232 TOP = Fquo (2, &TOP);
1233 AFTER_POTENTIAL_GC ();
1234 break;
1236 case Brem:
1238 Lisp_Object v1;
1239 BEFORE_POTENTIAL_GC ();
1240 v1 = POP;
1241 TOP = Frem (TOP, v1);
1242 AFTER_POTENTIAL_GC ();
1243 break;
1246 case Bpoint:
1248 Lisp_Object v1;
1249 XSETFASTINT (v1, PT);
1250 PUSH (v1);
1251 break;
1254 case Bgoto_char:
1255 BEFORE_POTENTIAL_GC ();
1256 TOP = Fgoto_char (TOP);
1257 AFTER_POTENTIAL_GC ();
1258 break;
1260 case Binsert:
1261 BEFORE_POTENTIAL_GC ();
1262 TOP = Finsert (1, &TOP);
1263 AFTER_POTENTIAL_GC ();
1264 break;
1266 case BinsertN:
1267 op = FETCH;
1268 BEFORE_POTENTIAL_GC ();
1269 DISCARD (op - 1);
1270 TOP = Finsert (op, &TOP);
1271 AFTER_POTENTIAL_GC ();
1272 break;
1274 case Bpoint_max:
1276 Lisp_Object v1;
1277 XSETFASTINT (v1, ZV);
1278 PUSH (v1);
1279 break;
1282 case Bpoint_min:
1284 Lisp_Object v1;
1285 XSETFASTINT (v1, BEGV);
1286 PUSH (v1);
1287 break;
1290 case Bchar_after:
1291 BEFORE_POTENTIAL_GC ();
1292 TOP = Fchar_after (TOP);
1293 AFTER_POTENTIAL_GC ();
1294 break;
1296 case Bfollowing_char:
1298 Lisp_Object v1;
1299 BEFORE_POTENTIAL_GC ();
1300 v1 = Ffollowing_char ();
1301 AFTER_POTENTIAL_GC ();
1302 PUSH (v1);
1303 break;
1306 case Bpreceding_char:
1308 Lisp_Object v1;
1309 BEFORE_POTENTIAL_GC ();
1310 v1 = Fprevious_char ();
1311 AFTER_POTENTIAL_GC ();
1312 PUSH (v1);
1313 break;
1316 case Bcurrent_column:
1318 Lisp_Object v1;
1319 BEFORE_POTENTIAL_GC ();
1320 XSETFASTINT (v1, (int) current_column ()); /* iftc */
1321 AFTER_POTENTIAL_GC ();
1322 PUSH (v1);
1323 break;
1326 case Bindent_to:
1327 BEFORE_POTENTIAL_GC ();
1328 TOP = Findent_to (TOP, Qnil);
1329 AFTER_POTENTIAL_GC ();
1330 break;
1332 case Beolp:
1333 PUSH (Feolp ());
1334 break;
1336 case Beobp:
1337 PUSH (Feobp ());
1338 break;
1340 case Bbolp:
1341 PUSH (Fbolp ());
1342 break;
1344 case Bbobp:
1345 PUSH (Fbobp ());
1346 break;
1348 case Bcurrent_buffer:
1349 PUSH (Fcurrent_buffer ());
1350 break;
1352 case Bset_buffer:
1353 BEFORE_POTENTIAL_GC ();
1354 TOP = Fset_buffer (TOP);
1355 AFTER_POTENTIAL_GC ();
1356 break;
1358 case Binteractive_p:
1359 PUSH (Finteractive_p ());
1360 break;
1362 case Bforward_char:
1363 BEFORE_POTENTIAL_GC ();
1364 TOP = Fforward_char (TOP);
1365 AFTER_POTENTIAL_GC ();
1366 break;
1368 case Bforward_word:
1369 BEFORE_POTENTIAL_GC ();
1370 TOP = Fforward_word (TOP);
1371 AFTER_POTENTIAL_GC ();
1372 break;
1374 case Bskip_chars_forward:
1376 Lisp_Object v1;
1377 BEFORE_POTENTIAL_GC ();
1378 v1 = POP;
1379 TOP = Fskip_chars_forward (TOP, v1);
1380 AFTER_POTENTIAL_GC ();
1381 break;
1384 case Bskip_chars_backward:
1386 Lisp_Object v1;
1387 BEFORE_POTENTIAL_GC ();
1388 v1 = POP;
1389 TOP = Fskip_chars_backward (TOP, v1);
1390 AFTER_POTENTIAL_GC ();
1391 break;
1394 case Bforward_line:
1395 BEFORE_POTENTIAL_GC ();
1396 TOP = Fforward_line (TOP);
1397 AFTER_POTENTIAL_GC ();
1398 break;
1400 case Bchar_syntax:
1402 int c;
1404 BEFORE_POTENTIAL_GC ();
1405 CHECK_CHARACTER (TOP);
1406 AFTER_POTENTIAL_GC ();
1407 c = XFASTINT (TOP);
1408 if (NILP (current_buffer->enable_multibyte_characters))
1409 MAKE_CHAR_MULTIBYTE (c);
1410 XSETFASTINT (TOP, syntax_code_spec[(int) SYNTAX (c)]);
1412 break;
1414 case Bbuffer_substring:
1416 Lisp_Object v1;
1417 BEFORE_POTENTIAL_GC ();
1418 v1 = POP;
1419 TOP = Fbuffer_substring (TOP, v1);
1420 AFTER_POTENTIAL_GC ();
1421 break;
1424 case Bdelete_region:
1426 Lisp_Object v1;
1427 BEFORE_POTENTIAL_GC ();
1428 v1 = POP;
1429 TOP = Fdelete_region (TOP, v1);
1430 AFTER_POTENTIAL_GC ();
1431 break;
1434 case Bnarrow_to_region:
1436 Lisp_Object v1;
1437 BEFORE_POTENTIAL_GC ();
1438 v1 = POP;
1439 TOP = Fnarrow_to_region (TOP, v1);
1440 AFTER_POTENTIAL_GC ();
1441 break;
1444 case Bwiden:
1445 BEFORE_POTENTIAL_GC ();
1446 PUSH (Fwiden ());
1447 AFTER_POTENTIAL_GC ();
1448 break;
1450 case Bend_of_line:
1451 BEFORE_POTENTIAL_GC ();
1452 TOP = Fend_of_line (TOP);
1453 AFTER_POTENTIAL_GC ();
1454 break;
1456 case Bset_marker:
1458 Lisp_Object v1, v2;
1459 BEFORE_POTENTIAL_GC ();
1460 v1 = POP;
1461 v2 = POP;
1462 TOP = Fset_marker (TOP, v2, v1);
1463 AFTER_POTENTIAL_GC ();
1464 break;
1467 case Bmatch_beginning:
1468 BEFORE_POTENTIAL_GC ();
1469 TOP = Fmatch_beginning (TOP);
1470 AFTER_POTENTIAL_GC ();
1471 break;
1473 case Bmatch_end:
1474 BEFORE_POTENTIAL_GC ();
1475 TOP = Fmatch_end (TOP);
1476 AFTER_POTENTIAL_GC ();
1477 break;
1479 case Bupcase:
1480 BEFORE_POTENTIAL_GC ();
1481 TOP = Fupcase (TOP);
1482 AFTER_POTENTIAL_GC ();
1483 break;
1485 case Bdowncase:
1486 BEFORE_POTENTIAL_GC ();
1487 TOP = Fdowncase (TOP);
1488 AFTER_POTENTIAL_GC ();
1489 break;
1491 case Bstringeqlsign:
1493 Lisp_Object v1;
1494 BEFORE_POTENTIAL_GC ();
1495 v1 = POP;
1496 TOP = Fstring_equal (TOP, v1);
1497 AFTER_POTENTIAL_GC ();
1498 break;
1501 case Bstringlss:
1503 Lisp_Object v1;
1504 BEFORE_POTENTIAL_GC ();
1505 v1 = POP;
1506 TOP = Fstring_lessp (TOP, v1);
1507 AFTER_POTENTIAL_GC ();
1508 break;
1511 case Bequal:
1513 Lisp_Object v1;
1514 v1 = POP;
1515 TOP = Fequal (TOP, v1);
1516 break;
1519 case Bnthcdr:
1521 Lisp_Object v1;
1522 BEFORE_POTENTIAL_GC ();
1523 v1 = POP;
1524 TOP = Fnthcdr (TOP, v1);
1525 AFTER_POTENTIAL_GC ();
1526 break;
1529 case Belt:
1531 Lisp_Object v1, v2;
1532 if (CONSP (TOP))
1534 /* Exchange args and then do nth. */
1535 BEFORE_POTENTIAL_GC ();
1536 v2 = POP;
1537 v1 = TOP;
1538 CHECK_NUMBER (v2);
1539 AFTER_POTENTIAL_GC ();
1540 op = XINT (v2);
1541 immediate_quit = 1;
1542 while (--op >= 0 && CONSP (v1))
1543 v1 = XCDR (v1);
1544 immediate_quit = 0;
1545 TOP = CAR (v1);
1547 else
1549 BEFORE_POTENTIAL_GC ();
1550 v1 = POP;
1551 TOP = Felt (TOP, v1);
1552 AFTER_POTENTIAL_GC ();
1554 break;
1557 case Bmember:
1559 Lisp_Object v1;
1560 BEFORE_POTENTIAL_GC ();
1561 v1 = POP;
1562 TOP = Fmember (TOP, v1);
1563 AFTER_POTENTIAL_GC ();
1564 break;
1567 case Bassq:
1569 Lisp_Object v1;
1570 BEFORE_POTENTIAL_GC ();
1571 v1 = POP;
1572 TOP = Fassq (TOP, v1);
1573 AFTER_POTENTIAL_GC ();
1574 break;
1577 case Bnreverse:
1578 BEFORE_POTENTIAL_GC ();
1579 TOP = Fnreverse (TOP);
1580 AFTER_POTENTIAL_GC ();
1581 break;
1583 case Bsetcar:
1585 Lisp_Object v1;
1586 BEFORE_POTENTIAL_GC ();
1587 v1 = POP;
1588 TOP = Fsetcar (TOP, v1);
1589 AFTER_POTENTIAL_GC ();
1590 break;
1593 case Bsetcdr:
1595 Lisp_Object v1;
1596 BEFORE_POTENTIAL_GC ();
1597 v1 = POP;
1598 TOP = Fsetcdr (TOP, v1);
1599 AFTER_POTENTIAL_GC ();
1600 break;
1603 case Bcar_safe:
1605 Lisp_Object v1;
1606 v1 = TOP;
1607 TOP = CAR_SAFE (v1);
1608 break;
1611 case Bcdr_safe:
1613 Lisp_Object v1;
1614 v1 = TOP;
1615 TOP = CDR_SAFE (v1);
1616 break;
1619 case Bnconc:
1620 BEFORE_POTENTIAL_GC ();
1621 DISCARD (1);
1622 TOP = Fnconc (2, &TOP);
1623 AFTER_POTENTIAL_GC ();
1624 break;
1626 case Bnumberp:
1627 TOP = (NUMBERP (TOP) ? Qt : Qnil);
1628 break;
1630 case Bintegerp:
1631 TOP = INTEGERP (TOP) ? Qt : Qnil;
1632 break;
1634 #ifdef BYTE_CODE_SAFE
1635 case Bset_mark:
1636 BEFORE_POTENTIAL_GC ();
1637 error ("set-mark is an obsolete bytecode");
1638 AFTER_POTENTIAL_GC ();
1639 break;
1640 case Bscan_buffer:
1641 BEFORE_POTENTIAL_GC ();
1642 error ("scan-buffer is an obsolete bytecode");
1643 AFTER_POTENTIAL_GC ();
1644 break;
1645 #endif
1647 case 0:
1648 abort ();
1650 case 255:
1651 default:
1652 #ifdef BYTE_CODE_SAFE
1653 if (op < Bconstant)
1655 abort ();
1657 if ((op -= Bconstant) >= const_length)
1659 abort ();
1661 PUSH (vectorp[op]);
1662 #else
1663 PUSH (vectorp[op - Bconstant]);
1664 #endif
1668 exit:
1670 byte_stack_list = byte_stack_list->next;
1672 /* Binds and unbinds are supposed to be compiled balanced. */
1673 if (SPECPDL_INDEX () != count)
1674 #ifdef BYTE_CODE_SAFE
1675 error ("binding stack not balanced (serious byte compiler bug)");
1676 #else
1677 abort ();
1678 #endif
1680 return result;
1683 void
1684 syms_of_bytecode ()
1686 Qbytecode = intern_c_string ("byte-code");
1687 staticpro (&Qbytecode);
1689 defsubr (&Sbyte_code);
1691 #ifdef BYTE_CODE_METER
1693 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter,
1694 doc: /* A vector of vectors which holds a histogram of byte-code usage.
1695 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
1696 opcode CODE has been executed.
1697 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
1698 indicates how many times the byte opcodes CODE1 and CODE2 have been
1699 executed in succession. */);
1701 DEFVAR_BOOL ("byte-metering-on", &byte_metering_on,
1702 doc: /* If non-nil, keep profiling information on byte code usage.
1703 The variable byte-code-meter indicates how often each byte opcode is used.
1704 If a symbol has a property named `byte-code-meter' whose value is an
1705 integer, it is incremented each time that symbol's function is called. */);
1707 byte_metering_on = 0;
1708 Vbyte_code_meter = Fmake_vector (make_number (256), make_number (0));
1709 Qbyte_code_meter = intern_c_string ("byte-code-meter");
1710 staticpro (&Qbyte_code_meter);
1712 int i = 256;
1713 while (i--)
1714 XVECTOR (Vbyte_code_meter)->contents[i] =
1715 Fmake_vector (make_number (256), make_number (0));
1717 #endif
1720 /* arch-tag: b9803b6f-1ed6-4190-8adf-33fd3a9d10e9
1721 (do not change this comment) */