Mention multi-planes text-properties
[emacs.git] / src / bytecode.c
blobc53c5acdbb3be505a9cb6292a51887dd07c58100
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 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 = XVECTOR (vector)->size;
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 if (STRING_MULTIBYTE (bytestr))
441 /* BYTESTR must have been produced by Emacs 20.2 or the earlier
442 because they produced a raw 8-bit string for byte-code and now
443 such a byte-code string is loaded as multibyte while raw 8-bit
444 characters converted to multibyte form. Thus, now we must
445 convert them back to the originally intended unibyte form. */
446 bytestr = Fstring_as_unibyte (bytestr);
448 bytestr_length = SBYTES (bytestr);
449 vectorp = XVECTOR (vector)->contents;
451 stack.byte_string = bytestr;
452 stack.pc = stack.byte_string_start = SDATA (bytestr);
453 stack.constants = vector;
454 stack.bottom = (Lisp_Object *) alloca (XFASTINT (maxdepth)
455 * sizeof (Lisp_Object));
456 top = stack.bottom - 1;
457 stack.top = NULL;
458 stack.next = byte_stack_list;
459 byte_stack_list = &stack;
461 #ifdef BYTE_CODE_SAFE
462 stacke = stack.bottom - 1 + XFASTINT (maxdepth);
463 #endif
465 while (1)
467 #ifdef BYTE_CODE_SAFE
468 if (top > stacke)
469 abort ();
470 else if (top < stack.bottom - 1)
471 abort ();
472 #endif
474 #ifdef BYTE_CODE_METER
475 prev_op = this_op;
476 this_op = op = FETCH;
477 METER_CODE (prev_op, op);
478 #else
479 op = FETCH;
480 #endif
482 switch (op)
484 case Bvarref + 7:
485 op = FETCH2;
486 goto varref;
488 case Bvarref:
489 case Bvarref + 1:
490 case Bvarref + 2:
491 case Bvarref + 3:
492 case Bvarref + 4:
493 case Bvarref + 5:
494 op = op - Bvarref;
495 goto varref;
497 /* This seems to be the most frequently executed byte-code
498 among the Bvarref's, so avoid a goto here. */
499 case Bvarref+6:
500 op = FETCH;
501 varref:
503 Lisp_Object v1, v2;
505 v1 = vectorp[op];
506 if (SYMBOLP (v1))
508 if (XSYMBOL (v1)->redirect != SYMBOL_PLAINVAL
509 || (v2 = SYMBOL_VAL (XSYMBOL (v1)),
510 EQ (v2, Qunbound)))
512 BEFORE_POTENTIAL_GC ();
513 v2 = Fsymbol_value (v1);
514 AFTER_POTENTIAL_GC ();
517 else
519 BEFORE_POTENTIAL_GC ();
520 v2 = Fsymbol_value (v1);
521 AFTER_POTENTIAL_GC ();
523 PUSH (v2);
524 break;
527 case Bgotoifnil:
529 Lisp_Object v1;
530 MAYBE_GC ();
531 op = FETCH2;
532 v1 = POP;
533 if (NILP (v1))
535 BYTE_CODE_QUIT;
536 CHECK_RANGE (op);
537 stack.pc = stack.byte_string_start + op;
539 break;
542 case Bcar:
544 Lisp_Object v1;
545 v1 = TOP;
546 TOP = CAR (v1);
547 break;
550 case Beq:
552 Lisp_Object v1;
553 v1 = POP;
554 TOP = EQ (v1, TOP) ? Qt : Qnil;
555 break;
558 case Bmemq:
560 Lisp_Object v1;
561 BEFORE_POTENTIAL_GC ();
562 v1 = POP;
563 TOP = Fmemq (TOP, v1);
564 AFTER_POTENTIAL_GC ();
565 break;
568 case Bcdr:
570 Lisp_Object v1;
571 v1 = TOP;
572 TOP = CDR (v1);
573 break;
576 case Bvarset:
577 case Bvarset+1:
578 case Bvarset+2:
579 case Bvarset+3:
580 case Bvarset+4:
581 case Bvarset+5:
582 op -= Bvarset;
583 goto varset;
585 case Bvarset+7:
586 op = FETCH2;
587 goto varset;
589 case Bvarset+6:
590 op = FETCH;
591 varset:
593 Lisp_Object sym, val;
595 sym = vectorp[op];
596 val = TOP;
598 /* Inline the most common case. */
599 if (SYMBOLP (sym)
600 && !EQ (val, Qunbound)
601 && !XSYMBOL (sym)->redirect
602 && !SYMBOL_CONSTANT_P (sym))
603 XSYMBOL (sym)->val.value = val;
604 else
606 BEFORE_POTENTIAL_GC ();
607 set_internal (sym, val, Qnil, 0);
608 AFTER_POTENTIAL_GC ();
611 (void) POP;
612 break;
614 case Bdup:
616 Lisp_Object v1;
617 v1 = TOP;
618 PUSH (v1);
619 break;
622 /* ------------------ */
624 case Bvarbind+6:
625 op = FETCH;
626 goto varbind;
628 case Bvarbind+7:
629 op = FETCH2;
630 goto varbind;
632 case Bvarbind:
633 case Bvarbind+1:
634 case Bvarbind+2:
635 case Bvarbind+3:
636 case Bvarbind+4:
637 case Bvarbind+5:
638 op -= Bvarbind;
639 varbind:
640 /* Specbind can signal and thus GC. */
641 BEFORE_POTENTIAL_GC ();
642 specbind (vectorp[op], POP);
643 AFTER_POTENTIAL_GC ();
644 break;
646 case Bcall+6:
647 op = FETCH;
648 goto docall;
650 case Bcall+7:
651 op = FETCH2;
652 goto docall;
654 case Bcall:
655 case Bcall+1:
656 case Bcall+2:
657 case Bcall+3:
658 case Bcall+4:
659 case Bcall+5:
660 op -= Bcall;
661 docall:
663 BEFORE_POTENTIAL_GC ();
664 DISCARD (op);
665 #ifdef BYTE_CODE_METER
666 if (byte_metering_on && SYMBOLP (TOP))
668 Lisp_Object v1, v2;
670 v1 = TOP;
671 v2 = Fget (v1, Qbyte_code_meter);
672 if (INTEGERP (v2)
673 && XINT (v2) < MOST_POSITIVE_FIXNUM)
675 XSETINT (v2, XINT (v2) + 1);
676 Fput (v1, Qbyte_code_meter, v2);
679 #endif
680 TOP = Ffuncall (op + 1, &TOP);
681 AFTER_POTENTIAL_GC ();
682 break;
685 case Bunbind+6:
686 op = FETCH;
687 goto dounbind;
689 case Bunbind+7:
690 op = FETCH2;
691 goto dounbind;
693 case Bunbind:
694 case Bunbind+1:
695 case Bunbind+2:
696 case Bunbind+3:
697 case Bunbind+4:
698 case Bunbind+5:
699 op -= Bunbind;
700 dounbind:
701 BEFORE_POTENTIAL_GC ();
702 unbind_to (SPECPDL_INDEX () - op, Qnil);
703 AFTER_POTENTIAL_GC ();
704 break;
706 case Bunbind_all:
707 /* To unbind back to the beginning of this frame. Not used yet,
708 but will be needed for tail-recursion elimination. */
709 BEFORE_POTENTIAL_GC ();
710 unbind_to (count, Qnil);
711 AFTER_POTENTIAL_GC ();
712 break;
714 case Bgoto:
715 MAYBE_GC ();
716 BYTE_CODE_QUIT;
717 op = FETCH2; /* pc = FETCH2 loses since FETCH2 contains pc++ */
718 CHECK_RANGE (op);
719 stack.pc = stack.byte_string_start + op;
720 break;
722 case Bgotoifnonnil:
724 Lisp_Object v1;
725 MAYBE_GC ();
726 op = FETCH2;
727 v1 = POP;
728 if (!NILP (v1))
730 BYTE_CODE_QUIT;
731 CHECK_RANGE (op);
732 stack.pc = stack.byte_string_start + op;
734 break;
737 case Bgotoifnilelsepop:
738 MAYBE_GC ();
739 op = FETCH2;
740 if (NILP (TOP))
742 BYTE_CODE_QUIT;
743 CHECK_RANGE (op);
744 stack.pc = stack.byte_string_start + op;
746 else DISCARD (1);
747 break;
749 case Bgotoifnonnilelsepop:
750 MAYBE_GC ();
751 op = FETCH2;
752 if (!NILP (TOP))
754 BYTE_CODE_QUIT;
755 CHECK_RANGE (op);
756 stack.pc = stack.byte_string_start + op;
758 else DISCARD (1);
759 break;
761 case BRgoto:
762 MAYBE_GC ();
763 BYTE_CODE_QUIT;
764 stack.pc += (int) *stack.pc - 127;
765 break;
767 case BRgotoifnil:
769 Lisp_Object v1;
770 MAYBE_GC ();
771 v1 = POP;
772 if (NILP (v1))
774 BYTE_CODE_QUIT;
775 stack.pc += (int) *stack.pc - 128;
777 stack.pc++;
778 break;
781 case BRgotoifnonnil:
783 Lisp_Object v1;
784 MAYBE_GC ();
785 v1 = POP;
786 if (!NILP (v1))
788 BYTE_CODE_QUIT;
789 stack.pc += (int) *stack.pc - 128;
791 stack.pc++;
792 break;
795 case BRgotoifnilelsepop:
796 MAYBE_GC ();
797 op = *stack.pc++;
798 if (NILP (TOP))
800 BYTE_CODE_QUIT;
801 stack.pc += op - 128;
803 else DISCARD (1);
804 break;
806 case BRgotoifnonnilelsepop:
807 MAYBE_GC ();
808 op = *stack.pc++;
809 if (!NILP (TOP))
811 BYTE_CODE_QUIT;
812 stack.pc += op - 128;
814 else DISCARD (1);
815 break;
817 case Breturn:
818 result = POP;
819 goto exit;
821 case Bdiscard:
822 DISCARD (1);
823 break;
825 case Bconstant2:
826 PUSH (vectorp[FETCH2]);
827 break;
829 case Bsave_excursion:
830 record_unwind_protect (save_excursion_restore,
831 save_excursion_save ());
832 break;
834 case Bsave_current_buffer:
835 case Bsave_current_buffer_1:
836 record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ());
837 break;
839 case Bsave_window_excursion:
840 BEFORE_POTENTIAL_GC ();
841 TOP = Fsave_window_excursion (TOP);
842 AFTER_POTENTIAL_GC ();
843 break;
845 case Bsave_restriction:
846 record_unwind_protect (save_restriction_restore,
847 save_restriction_save ());
848 break;
850 case Bcatch:
852 Lisp_Object v1;
853 BEFORE_POTENTIAL_GC ();
854 v1 = POP;
855 TOP = internal_catch (TOP, Feval, v1);
856 AFTER_POTENTIAL_GC ();
857 break;
860 case Bunwind_protect:
861 record_unwind_protect (Fprogn, POP);
862 break;
864 case Bcondition_case:
866 Lisp_Object handlers, body;
867 handlers = POP;
868 body = POP;
869 BEFORE_POTENTIAL_GC ();
870 TOP = internal_lisp_condition_case (TOP, body, handlers);
871 AFTER_POTENTIAL_GC ();
872 break;
875 case Btemp_output_buffer_setup:
876 BEFORE_POTENTIAL_GC ();
877 CHECK_STRING (TOP);
878 temp_output_buffer_setup (SDATA (TOP));
879 AFTER_POTENTIAL_GC ();
880 TOP = Vstandard_output;
881 break;
883 case Btemp_output_buffer_show:
885 Lisp_Object v1;
886 BEFORE_POTENTIAL_GC ();
887 v1 = POP;
888 temp_output_buffer_show (TOP);
889 TOP = v1;
890 /* pop binding of standard-output */
891 unbind_to (SPECPDL_INDEX () - 1, Qnil);
892 AFTER_POTENTIAL_GC ();
893 break;
896 case Bnth:
898 Lisp_Object v1, v2;
899 BEFORE_POTENTIAL_GC ();
900 v1 = POP;
901 v2 = TOP;
902 CHECK_NUMBER (v2);
903 AFTER_POTENTIAL_GC ();
904 op = XINT (v2);
905 immediate_quit = 1;
906 while (--op >= 0 && CONSP (v1))
907 v1 = XCDR (v1);
908 immediate_quit = 0;
909 TOP = CAR (v1);
910 break;
913 case Bsymbolp:
914 TOP = SYMBOLP (TOP) ? Qt : Qnil;
915 break;
917 case Bconsp:
918 TOP = CONSP (TOP) ? Qt : Qnil;
919 break;
921 case Bstringp:
922 TOP = STRINGP (TOP) ? Qt : Qnil;
923 break;
925 case Blistp:
926 TOP = CONSP (TOP) || NILP (TOP) ? Qt : Qnil;
927 break;
929 case Bnot:
930 TOP = NILP (TOP) ? Qt : Qnil;
931 break;
933 case Bcons:
935 Lisp_Object v1;
936 v1 = POP;
937 TOP = Fcons (TOP, v1);
938 break;
941 case Blist1:
942 TOP = Fcons (TOP, Qnil);
943 break;
945 case Blist2:
947 Lisp_Object v1;
948 v1 = POP;
949 TOP = Fcons (TOP, Fcons (v1, Qnil));
950 break;
953 case Blist3:
954 DISCARD (2);
955 TOP = Flist (3, &TOP);
956 break;
958 case Blist4:
959 DISCARD (3);
960 TOP = Flist (4, &TOP);
961 break;
963 case BlistN:
964 op = FETCH;
965 DISCARD (op - 1);
966 TOP = Flist (op, &TOP);
967 break;
969 case Blength:
970 BEFORE_POTENTIAL_GC ();
971 TOP = Flength (TOP);
972 AFTER_POTENTIAL_GC ();
973 break;
975 case Baref:
977 Lisp_Object v1;
978 BEFORE_POTENTIAL_GC ();
979 v1 = POP;
980 TOP = Faref (TOP, v1);
981 AFTER_POTENTIAL_GC ();
982 break;
985 case Baset:
987 Lisp_Object v1, v2;
988 BEFORE_POTENTIAL_GC ();
989 v2 = POP; v1 = POP;
990 TOP = Faset (TOP, v1, v2);
991 AFTER_POTENTIAL_GC ();
992 break;
995 case Bsymbol_value:
996 BEFORE_POTENTIAL_GC ();
997 TOP = Fsymbol_value (TOP);
998 AFTER_POTENTIAL_GC ();
999 break;
1001 case Bsymbol_function:
1002 BEFORE_POTENTIAL_GC ();
1003 TOP = Fsymbol_function (TOP);
1004 AFTER_POTENTIAL_GC ();
1005 break;
1007 case Bset:
1009 Lisp_Object v1;
1010 BEFORE_POTENTIAL_GC ();
1011 v1 = POP;
1012 TOP = Fset (TOP, v1);
1013 AFTER_POTENTIAL_GC ();
1014 break;
1017 case Bfset:
1019 Lisp_Object v1;
1020 BEFORE_POTENTIAL_GC ();
1021 v1 = POP;
1022 TOP = Ffset (TOP, v1);
1023 AFTER_POTENTIAL_GC ();
1024 break;
1027 case Bget:
1029 Lisp_Object v1;
1030 BEFORE_POTENTIAL_GC ();
1031 v1 = POP;
1032 TOP = Fget (TOP, v1);
1033 AFTER_POTENTIAL_GC ();
1034 break;
1037 case Bsubstring:
1039 Lisp_Object v1, v2;
1040 BEFORE_POTENTIAL_GC ();
1041 v2 = POP; v1 = POP;
1042 TOP = Fsubstring (TOP, v1, v2);
1043 AFTER_POTENTIAL_GC ();
1044 break;
1047 case Bconcat2:
1048 BEFORE_POTENTIAL_GC ();
1049 DISCARD (1);
1050 TOP = Fconcat (2, &TOP);
1051 AFTER_POTENTIAL_GC ();
1052 break;
1054 case Bconcat3:
1055 BEFORE_POTENTIAL_GC ();
1056 DISCARD (2);
1057 TOP = Fconcat (3, &TOP);
1058 AFTER_POTENTIAL_GC ();
1059 break;
1061 case Bconcat4:
1062 BEFORE_POTENTIAL_GC ();
1063 DISCARD (3);
1064 TOP = Fconcat (4, &TOP);
1065 AFTER_POTENTIAL_GC ();
1066 break;
1068 case BconcatN:
1069 op = FETCH;
1070 BEFORE_POTENTIAL_GC ();
1071 DISCARD (op - 1);
1072 TOP = Fconcat (op, &TOP);
1073 AFTER_POTENTIAL_GC ();
1074 break;
1076 case Bsub1:
1078 Lisp_Object v1;
1079 v1 = TOP;
1080 if (INTEGERP (v1))
1082 XSETINT (v1, XINT (v1) - 1);
1083 TOP = v1;
1085 else
1087 BEFORE_POTENTIAL_GC ();
1088 TOP = Fsub1 (v1);
1089 AFTER_POTENTIAL_GC ();
1091 break;
1094 case Badd1:
1096 Lisp_Object v1;
1097 v1 = TOP;
1098 if (INTEGERP (v1))
1100 XSETINT (v1, XINT (v1) + 1);
1101 TOP = v1;
1103 else
1105 BEFORE_POTENTIAL_GC ();
1106 TOP = Fadd1 (v1);
1107 AFTER_POTENTIAL_GC ();
1109 break;
1112 case Beqlsign:
1114 Lisp_Object v1, v2;
1115 BEFORE_POTENTIAL_GC ();
1116 v2 = POP; v1 = TOP;
1117 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v1);
1118 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v2);
1119 AFTER_POTENTIAL_GC ();
1120 if (FLOATP (v1) || FLOATP (v2))
1122 double f1, f2;
1124 f1 = (FLOATP (v1) ? XFLOAT_DATA (v1) : XINT (v1));
1125 f2 = (FLOATP (v2) ? XFLOAT_DATA (v2) : XINT (v2));
1126 TOP = (f1 == f2 ? Qt : Qnil);
1128 else
1129 TOP = (XINT (v1) == XINT (v2) ? Qt : Qnil);
1130 break;
1133 case Bgtr:
1135 Lisp_Object v1;
1136 BEFORE_POTENTIAL_GC ();
1137 v1 = POP;
1138 TOP = Fgtr (TOP, v1);
1139 AFTER_POTENTIAL_GC ();
1140 break;
1143 case Blss:
1145 Lisp_Object v1;
1146 BEFORE_POTENTIAL_GC ();
1147 v1 = POP;
1148 TOP = Flss (TOP, v1);
1149 AFTER_POTENTIAL_GC ();
1150 break;
1153 case Bleq:
1155 Lisp_Object v1;
1156 BEFORE_POTENTIAL_GC ();
1157 v1 = POP;
1158 TOP = Fleq (TOP, v1);
1159 AFTER_POTENTIAL_GC ();
1160 break;
1163 case Bgeq:
1165 Lisp_Object v1;
1166 BEFORE_POTENTIAL_GC ();
1167 v1 = POP;
1168 TOP = Fgeq (TOP, v1);
1169 AFTER_POTENTIAL_GC ();
1170 break;
1173 case Bdiff:
1174 BEFORE_POTENTIAL_GC ();
1175 DISCARD (1);
1176 TOP = Fminus (2, &TOP);
1177 AFTER_POTENTIAL_GC ();
1178 break;
1180 case Bnegate:
1182 Lisp_Object v1;
1183 v1 = TOP;
1184 if (INTEGERP (v1))
1186 XSETINT (v1, - XINT (v1));
1187 TOP = v1;
1189 else
1191 BEFORE_POTENTIAL_GC ();
1192 TOP = Fminus (1, &TOP);
1193 AFTER_POTENTIAL_GC ();
1195 break;
1198 case Bplus:
1199 BEFORE_POTENTIAL_GC ();
1200 DISCARD (1);
1201 TOP = Fplus (2, &TOP);
1202 AFTER_POTENTIAL_GC ();
1203 break;
1205 case Bmax:
1206 BEFORE_POTENTIAL_GC ();
1207 DISCARD (1);
1208 TOP = Fmax (2, &TOP);
1209 AFTER_POTENTIAL_GC ();
1210 break;
1212 case Bmin:
1213 BEFORE_POTENTIAL_GC ();
1214 DISCARD (1);
1215 TOP = Fmin (2, &TOP);
1216 AFTER_POTENTIAL_GC ();
1217 break;
1219 case Bmult:
1220 BEFORE_POTENTIAL_GC ();
1221 DISCARD (1);
1222 TOP = Ftimes (2, &TOP);
1223 AFTER_POTENTIAL_GC ();
1224 break;
1226 case Bquo:
1227 BEFORE_POTENTIAL_GC ();
1228 DISCARD (1);
1229 TOP = Fquo (2, &TOP);
1230 AFTER_POTENTIAL_GC ();
1231 break;
1233 case Brem:
1235 Lisp_Object v1;
1236 BEFORE_POTENTIAL_GC ();
1237 v1 = POP;
1238 TOP = Frem (TOP, v1);
1239 AFTER_POTENTIAL_GC ();
1240 break;
1243 case Bpoint:
1245 Lisp_Object v1;
1246 XSETFASTINT (v1, PT);
1247 PUSH (v1);
1248 break;
1251 case Bgoto_char:
1252 BEFORE_POTENTIAL_GC ();
1253 TOP = Fgoto_char (TOP);
1254 AFTER_POTENTIAL_GC ();
1255 break;
1257 case Binsert:
1258 BEFORE_POTENTIAL_GC ();
1259 TOP = Finsert (1, &TOP);
1260 AFTER_POTENTIAL_GC ();
1261 break;
1263 case BinsertN:
1264 op = FETCH;
1265 BEFORE_POTENTIAL_GC ();
1266 DISCARD (op - 1);
1267 TOP = Finsert (op, &TOP);
1268 AFTER_POTENTIAL_GC ();
1269 break;
1271 case Bpoint_max:
1273 Lisp_Object v1;
1274 XSETFASTINT (v1, ZV);
1275 PUSH (v1);
1276 break;
1279 case Bpoint_min:
1281 Lisp_Object v1;
1282 XSETFASTINT (v1, BEGV);
1283 PUSH (v1);
1284 break;
1287 case Bchar_after:
1288 BEFORE_POTENTIAL_GC ();
1289 TOP = Fchar_after (TOP);
1290 AFTER_POTENTIAL_GC ();
1291 break;
1293 case Bfollowing_char:
1295 Lisp_Object v1;
1296 BEFORE_POTENTIAL_GC ();
1297 v1 = Ffollowing_char ();
1298 AFTER_POTENTIAL_GC ();
1299 PUSH (v1);
1300 break;
1303 case Bpreceding_char:
1305 Lisp_Object v1;
1306 BEFORE_POTENTIAL_GC ();
1307 v1 = Fprevious_char ();
1308 AFTER_POTENTIAL_GC ();
1309 PUSH (v1);
1310 break;
1313 case Bcurrent_column:
1315 Lisp_Object v1;
1316 BEFORE_POTENTIAL_GC ();
1317 XSETFASTINT (v1, (int) current_column ()); /* iftc */
1318 AFTER_POTENTIAL_GC ();
1319 PUSH (v1);
1320 break;
1323 case Bindent_to:
1324 BEFORE_POTENTIAL_GC ();
1325 TOP = Findent_to (TOP, Qnil);
1326 AFTER_POTENTIAL_GC ();
1327 break;
1329 case Beolp:
1330 PUSH (Feolp ());
1331 break;
1333 case Beobp:
1334 PUSH (Feobp ());
1335 break;
1337 case Bbolp:
1338 PUSH (Fbolp ());
1339 break;
1341 case Bbobp:
1342 PUSH (Fbobp ());
1343 break;
1345 case Bcurrent_buffer:
1346 PUSH (Fcurrent_buffer ());
1347 break;
1349 case Bset_buffer:
1350 BEFORE_POTENTIAL_GC ();
1351 TOP = Fset_buffer (TOP);
1352 AFTER_POTENTIAL_GC ();
1353 break;
1355 case Binteractive_p:
1356 PUSH (Finteractive_p ());
1357 break;
1359 case Bforward_char:
1360 BEFORE_POTENTIAL_GC ();
1361 TOP = Fforward_char (TOP);
1362 AFTER_POTENTIAL_GC ();
1363 break;
1365 case Bforward_word:
1366 BEFORE_POTENTIAL_GC ();
1367 TOP = Fforward_word (TOP);
1368 AFTER_POTENTIAL_GC ();
1369 break;
1371 case Bskip_chars_forward:
1373 Lisp_Object v1;
1374 BEFORE_POTENTIAL_GC ();
1375 v1 = POP;
1376 TOP = Fskip_chars_forward (TOP, v1);
1377 AFTER_POTENTIAL_GC ();
1378 break;
1381 case Bskip_chars_backward:
1383 Lisp_Object v1;
1384 BEFORE_POTENTIAL_GC ();
1385 v1 = POP;
1386 TOP = Fskip_chars_backward (TOP, v1);
1387 AFTER_POTENTIAL_GC ();
1388 break;
1391 case Bforward_line:
1392 BEFORE_POTENTIAL_GC ();
1393 TOP = Fforward_line (TOP);
1394 AFTER_POTENTIAL_GC ();
1395 break;
1397 case Bchar_syntax:
1399 int c;
1401 BEFORE_POTENTIAL_GC ();
1402 CHECK_CHARACTER (TOP);
1403 AFTER_POTENTIAL_GC ();
1404 c = XFASTINT (TOP);
1405 if (NILP (current_buffer->enable_multibyte_characters))
1406 MAKE_CHAR_MULTIBYTE (c);
1407 XSETFASTINT (TOP, syntax_code_spec[(int) SYNTAX (c)]);
1409 break;
1411 case Bbuffer_substring:
1413 Lisp_Object v1;
1414 BEFORE_POTENTIAL_GC ();
1415 v1 = POP;
1416 TOP = Fbuffer_substring (TOP, v1);
1417 AFTER_POTENTIAL_GC ();
1418 break;
1421 case Bdelete_region:
1423 Lisp_Object v1;
1424 BEFORE_POTENTIAL_GC ();
1425 v1 = POP;
1426 TOP = Fdelete_region (TOP, v1);
1427 AFTER_POTENTIAL_GC ();
1428 break;
1431 case Bnarrow_to_region:
1433 Lisp_Object v1;
1434 BEFORE_POTENTIAL_GC ();
1435 v1 = POP;
1436 TOP = Fnarrow_to_region (TOP, v1);
1437 AFTER_POTENTIAL_GC ();
1438 break;
1441 case Bwiden:
1442 BEFORE_POTENTIAL_GC ();
1443 PUSH (Fwiden ());
1444 AFTER_POTENTIAL_GC ();
1445 break;
1447 case Bend_of_line:
1448 BEFORE_POTENTIAL_GC ();
1449 TOP = Fend_of_line (TOP);
1450 AFTER_POTENTIAL_GC ();
1451 break;
1453 case Bset_marker:
1455 Lisp_Object v1, v2;
1456 BEFORE_POTENTIAL_GC ();
1457 v1 = POP;
1458 v2 = POP;
1459 TOP = Fset_marker (TOP, v2, v1);
1460 AFTER_POTENTIAL_GC ();
1461 break;
1464 case Bmatch_beginning:
1465 BEFORE_POTENTIAL_GC ();
1466 TOP = Fmatch_beginning (TOP);
1467 AFTER_POTENTIAL_GC ();
1468 break;
1470 case Bmatch_end:
1471 BEFORE_POTENTIAL_GC ();
1472 TOP = Fmatch_end (TOP);
1473 AFTER_POTENTIAL_GC ();
1474 break;
1476 case Bupcase:
1477 BEFORE_POTENTIAL_GC ();
1478 TOP = Fupcase (TOP);
1479 AFTER_POTENTIAL_GC ();
1480 break;
1482 case Bdowncase:
1483 BEFORE_POTENTIAL_GC ();
1484 TOP = Fdowncase (TOP);
1485 AFTER_POTENTIAL_GC ();
1486 break;
1488 case Bstringeqlsign:
1490 Lisp_Object v1;
1491 BEFORE_POTENTIAL_GC ();
1492 v1 = POP;
1493 TOP = Fstring_equal (TOP, v1);
1494 AFTER_POTENTIAL_GC ();
1495 break;
1498 case Bstringlss:
1500 Lisp_Object v1;
1501 BEFORE_POTENTIAL_GC ();
1502 v1 = POP;
1503 TOP = Fstring_lessp (TOP, v1);
1504 AFTER_POTENTIAL_GC ();
1505 break;
1508 case Bequal:
1510 Lisp_Object v1;
1511 v1 = POP;
1512 TOP = Fequal (TOP, v1);
1513 break;
1516 case Bnthcdr:
1518 Lisp_Object v1;
1519 BEFORE_POTENTIAL_GC ();
1520 v1 = POP;
1521 TOP = Fnthcdr (TOP, v1);
1522 AFTER_POTENTIAL_GC ();
1523 break;
1526 case Belt:
1528 Lisp_Object v1, v2;
1529 if (CONSP (TOP))
1531 /* Exchange args and then do nth. */
1532 BEFORE_POTENTIAL_GC ();
1533 v2 = POP;
1534 v1 = TOP;
1535 CHECK_NUMBER (v2);
1536 AFTER_POTENTIAL_GC ();
1537 op = XINT (v2);
1538 immediate_quit = 1;
1539 while (--op >= 0 && CONSP (v1))
1540 v1 = XCDR (v1);
1541 immediate_quit = 0;
1542 TOP = CAR (v1);
1544 else
1546 BEFORE_POTENTIAL_GC ();
1547 v1 = POP;
1548 TOP = Felt (TOP, v1);
1549 AFTER_POTENTIAL_GC ();
1551 break;
1554 case Bmember:
1556 Lisp_Object v1;
1557 BEFORE_POTENTIAL_GC ();
1558 v1 = POP;
1559 TOP = Fmember (TOP, v1);
1560 AFTER_POTENTIAL_GC ();
1561 break;
1564 case Bassq:
1566 Lisp_Object v1;
1567 BEFORE_POTENTIAL_GC ();
1568 v1 = POP;
1569 TOP = Fassq (TOP, v1);
1570 AFTER_POTENTIAL_GC ();
1571 break;
1574 case Bnreverse:
1575 BEFORE_POTENTIAL_GC ();
1576 TOP = Fnreverse (TOP);
1577 AFTER_POTENTIAL_GC ();
1578 break;
1580 case Bsetcar:
1582 Lisp_Object v1;
1583 BEFORE_POTENTIAL_GC ();
1584 v1 = POP;
1585 TOP = Fsetcar (TOP, v1);
1586 AFTER_POTENTIAL_GC ();
1587 break;
1590 case Bsetcdr:
1592 Lisp_Object v1;
1593 BEFORE_POTENTIAL_GC ();
1594 v1 = POP;
1595 TOP = Fsetcdr (TOP, v1);
1596 AFTER_POTENTIAL_GC ();
1597 break;
1600 case Bcar_safe:
1602 Lisp_Object v1;
1603 v1 = TOP;
1604 TOP = CAR_SAFE (v1);
1605 break;
1608 case Bcdr_safe:
1610 Lisp_Object v1;
1611 v1 = TOP;
1612 TOP = CDR_SAFE (v1);
1613 break;
1616 case Bnconc:
1617 BEFORE_POTENTIAL_GC ();
1618 DISCARD (1);
1619 TOP = Fnconc (2, &TOP);
1620 AFTER_POTENTIAL_GC ();
1621 break;
1623 case Bnumberp:
1624 TOP = (NUMBERP (TOP) ? Qt : Qnil);
1625 break;
1627 case Bintegerp:
1628 TOP = INTEGERP (TOP) ? Qt : Qnil;
1629 break;
1631 #ifdef BYTE_CODE_SAFE
1632 case Bset_mark:
1633 BEFORE_POTENTIAL_GC ();
1634 error ("set-mark is an obsolete bytecode");
1635 AFTER_POTENTIAL_GC ();
1636 break;
1637 case Bscan_buffer:
1638 BEFORE_POTENTIAL_GC ();
1639 error ("scan-buffer is an obsolete bytecode");
1640 AFTER_POTENTIAL_GC ();
1641 break;
1642 #endif
1644 case 0:
1645 abort ();
1647 case 255:
1648 default:
1649 #ifdef BYTE_CODE_SAFE
1650 if (op < Bconstant)
1652 abort ();
1654 if ((op -= Bconstant) >= const_length)
1656 abort ();
1658 PUSH (vectorp[op]);
1659 #else
1660 PUSH (vectorp[op - Bconstant]);
1661 #endif
1665 exit:
1667 byte_stack_list = byte_stack_list->next;
1669 /* Binds and unbinds are supposed to be compiled balanced. */
1670 if (SPECPDL_INDEX () != count)
1671 #ifdef BYTE_CODE_SAFE
1672 error ("binding stack not balanced (serious byte compiler bug)");
1673 #else
1674 abort ();
1675 #endif
1677 return result;
1680 void
1681 syms_of_bytecode ()
1683 Qbytecode = intern_c_string ("byte-code");
1684 staticpro (&Qbytecode);
1686 defsubr (&Sbyte_code);
1688 #ifdef BYTE_CODE_METER
1690 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter,
1691 doc: /* A vector of vectors which holds a histogram of byte-code usage.
1692 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
1693 opcode CODE has been executed.
1694 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
1695 indicates how many times the byte opcodes CODE1 and CODE2 have been
1696 executed in succession. */);
1698 DEFVAR_BOOL ("byte-metering-on", &byte_metering_on,
1699 doc: /* If non-nil, keep profiling information on byte code usage.
1700 The variable byte-code-meter indicates how often each byte opcode is used.
1701 If a symbol has a property named `byte-code-meter' whose value is an
1702 integer, it is incremented each time that symbol's function is called. */);
1704 byte_metering_on = 0;
1705 Vbyte_code_meter = Fmake_vector (make_number (256), make_number (0));
1706 Qbyte_code_meter = intern_c_string ("byte-code-meter");
1707 staticpro (&Qbyte_code_meter);
1709 int i = 256;
1710 while (i--)
1711 XVECTOR (Vbyte_code_meter)->contents[i] =
1712 Fmake_vector (make_number (256), make_number (0));
1714 #endif
1717 /* arch-tag: b9803b6f-1ed6-4190-8adf-33fd3a9d10e9
1718 (do not change this comment) */