(set_internal): Fix up call to let_shadows_buffer_binding_p.
[emacs.git] / src / bytecode.c
blob48a0be1ff58d531fbca9af1e3d6d8897732481a4
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 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 "lisp.h"
38 #include "buffer.h"
39 #include "character.h"
40 #include "syntax.h"
41 #include "window.h"
43 #ifdef CHECK_FRAME_FONT
44 #include "frame.h"
45 #include "xterm.h"
46 #endif
49 * define BYTE_CODE_SAFE to enable some minor sanity checking (useful for
50 * debugging the byte compiler...)
52 * define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
54 /* #define BYTE_CODE_SAFE */
55 /* #define BYTE_CODE_METER */
58 #ifdef BYTE_CODE_METER
60 Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
61 int byte_metering_on;
63 #define METER_2(code1, code2) \
64 XFASTINT (XVECTOR (XVECTOR (Vbyte_code_meter)->contents[(code1)]) \
65 ->contents[(code2)])
67 #define METER_1(code) METER_2 (0, (code))
69 #define METER_CODE(last_code, this_code) \
70 { \
71 if (byte_metering_on) \
72 { \
73 if (METER_1 (this_code) < MOST_POSITIVE_FIXNUM) \
74 METER_1 (this_code)++; \
75 if (last_code \
76 && METER_2 (last_code, this_code) < MOST_POSITIVE_FIXNUM) \
77 METER_2 (last_code, this_code)++; \
78 } \
81 #else /* no BYTE_CODE_METER */
83 #define METER_CODE(last_code, this_code)
85 #endif /* no BYTE_CODE_METER */
88 Lisp_Object Qbytecode;
90 /* Byte codes: */
92 #define Bvarref 010
93 #define Bvarset 020
94 #define Bvarbind 030
95 #define Bcall 040
96 #define Bunbind 050
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
139 #define Bpoint 0140
140 /* Was Bmark in v17. */
141 #define Bsave_current_buffer 0141
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 /* Needed since interactive-p takes unevalled args */
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
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
185 #define Bsave_excursion 0212
186 #define Bsave_window_excursion 0213
187 #define Bsave_restriction 0214
188 #define Bcatch 0215
190 #define Bunwind_protect 0216
191 #define Bcondition_case 0217
192 #define Btemp_output_buffer_setup 0220
193 #define Btemp_output_buffer_show 0221
195 #define Bunbind_all 0222
197 #define Bset_marker 0223
198 #define Bmatch_beginning 0224
199 #define Bmatch_end 0225
200 #define Bupcase 0226
201 #define Bdowncase 0227
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
221 #define BRgoto 0252
222 #define BRgotoifnil 0253
223 #define BRgotoifnonnil 0254
224 #define BRgotoifnilelsepop 0255
225 #define BRgotoifnonnilelsepop 0256
227 #define BlistN 0257
228 #define BconcatN 0260
229 #define BinsertN 0261
231 #define Bconstant 0300
232 #define CONSTANTLIM 0100
235 /* Structure describing a value stack used during byte-code execution
236 in Fbyte_code. */
238 struct byte_stack
240 /* Program counter. This points into the byte_string below
241 and is relocated when that string is relocated. */
242 const unsigned char *pc;
244 /* Top and bottom of stack. The bottom points to an area of memory
245 allocated with alloca in Fbyte_code. */
246 Lisp_Object *top, *bottom;
248 /* The string containing the byte-code, and its current address.
249 Storing this here protects it from GC because mark_byte_stack
250 marks it. */
251 Lisp_Object byte_string;
252 const unsigned char *byte_string_start;
254 /* The vector of constants used during byte-code execution. Storing
255 this here protects it from GC because mark_byte_stack marks it. */
256 Lisp_Object constants;
258 /* Next entry in byte_stack_list. */
259 struct byte_stack *next;
262 /* A list of currently active byte-code execution value stacks.
263 Fbyte_code adds an entry to the head of this list before it starts
264 processing byte-code, and it removed the entry again when it is
265 done. Signalling an error truncates the list analoguous to
266 gcprolist. */
268 struct byte_stack *byte_stack_list;
271 /* Mark objects on byte_stack_list. Called during GC. */
273 void
274 mark_byte_stack ()
276 struct byte_stack *stack;
277 Lisp_Object *obj;
279 for (stack = byte_stack_list; stack; stack = stack->next)
281 /* If STACK->top is null here, this means there's an opcode in
282 Fbyte_code that wasn't expected to GC, but did. To find out
283 which opcode this is, record the value of `stack', and walk
284 up the stack in a debugger, stopping in frames of Fbyte_code.
285 The culprit is found in the frame of Fbyte_code where the
286 address of its local variable `stack' is equal to the
287 recorded value of `stack' here. */
288 eassert (stack->top);
290 for (obj = stack->bottom; obj <= stack->top; ++obj)
291 mark_object (*obj);
293 mark_object (stack->byte_string);
294 mark_object (stack->constants);
299 /* Unmark objects in the stacks on byte_stack_list. Relocate program
300 counters. Called when GC has completed. */
302 void
303 unmark_byte_stack ()
305 struct byte_stack *stack;
307 for (stack = byte_stack_list; stack; stack = stack->next)
309 if (stack->byte_string_start != SDATA (stack->byte_string))
311 int offset = stack->pc - stack->byte_string_start;
312 stack->byte_string_start = SDATA (stack->byte_string);
313 stack->pc = stack->byte_string_start + offset;
319 /* Fetch the next byte from the bytecode stream */
321 #define FETCH *stack.pc++
323 /* Fetch two bytes from the bytecode stream and make a 16-bit number
324 out of them */
326 #define FETCH2 (op = FETCH, op + (FETCH << 8))
328 /* Push x onto the execution stack. This used to be #define PUSH(x)
329 (*++stackp = (x)) This oddity is necessary because Alliant can't be
330 bothered to compile the preincrement operator properly, as of 4/91.
331 -JimB */
333 #define PUSH(x) (top++, *top = (x))
335 /* Pop a value off the execution stack. */
337 #define POP (*top--)
339 /* Discard n values from the execution stack. */
341 #define DISCARD(n) (top -= (n))
343 /* Get the value which is at the top of the execution stack, but don't
344 pop it. */
346 #define TOP (*top)
348 /* Actions that must be performed before and after calling a function
349 that might GC. */
351 #define BEFORE_POTENTIAL_GC() stack.top = top
352 #define AFTER_POTENTIAL_GC() stack.top = NULL
354 /* Garbage collect if we have consed enough since the last time.
355 We do this at every branch, to avoid loops that never GC. */
357 #define MAYBE_GC() \
358 if (consing_since_gc > gc_cons_threshold \
359 && consing_since_gc > gc_relative_threshold) \
361 BEFORE_POTENTIAL_GC (); \
362 Fgarbage_collect (); \
363 AFTER_POTENTIAL_GC (); \
365 else
367 /* Check for jumping out of range. */
369 #ifdef BYTE_CODE_SAFE
371 #define CHECK_RANGE(ARG) \
372 if (ARG >= bytestr_length) abort ()
374 #else /* not BYTE_CODE_SAFE */
376 #define CHECK_RANGE(ARG)
378 #endif /* not BYTE_CODE_SAFE */
380 /* A version of the QUIT macro which makes sure that the stack top is
381 set before signaling `quit'. */
383 #define BYTE_CODE_QUIT \
384 do { \
385 if (!NILP (Vquit_flag) && NILP (Vinhibit_quit)) \
387 Lisp_Object flag = Vquit_flag; \
388 Vquit_flag = Qnil; \
389 BEFORE_POTENTIAL_GC (); \
390 if (EQ (Vthrow_on_input, flag)) \
391 Fthrow (Vthrow_on_input, Qt); \
392 Fsignal (Qquit, Qnil); \
393 AFTER_POTENTIAL_GC (); \
395 } while (0)
398 DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0,
399 doc: /* Function used internally in byte-compiled code.
400 The first argument, BYTESTR, is a string of byte code;
401 the second, VECTOR, a vector of constants;
402 the third, MAXDEPTH, the maximum stack depth used in this function.
403 If the third argument is incorrect, Emacs may crash. */)
404 (bytestr, vector, maxdepth)
405 Lisp_Object bytestr, vector, maxdepth;
407 int count = SPECPDL_INDEX ();
408 #ifdef BYTE_CODE_METER
409 int this_op = 0;
410 int prev_op;
411 #endif
412 int op;
413 /* Lisp_Object v1, v2; */
414 Lisp_Object *vectorp;
415 #ifdef BYTE_CODE_SAFE
416 int const_length = XVECTOR (vector)->size;
417 Lisp_Object *stacke;
418 #endif
419 int bytestr_length;
420 struct byte_stack stack;
421 Lisp_Object *top;
422 Lisp_Object result;
424 #ifdef CHECK_FRAME_FONT
426 struct frame *f = SELECTED_FRAME ();
427 if (FRAME_X_P (f)
428 && FRAME_FONT (f)->direction != 0
429 && FRAME_FONT (f)->direction != 1)
430 abort ();
432 #endif
434 CHECK_STRING (bytestr);
435 CHECK_VECTOR (vector);
436 CHECK_NUMBER (maxdepth);
438 if (STRING_MULTIBYTE (bytestr))
439 /* BYTESTR must have been produced by Emacs 20.2 or the earlier
440 because they produced a raw 8-bit string for byte-code and now
441 such a byte-code string is loaded as multibyte while raw 8-bit
442 characters converted to multibyte form. Thus, now we must
443 convert them back to the originally intended unibyte form. */
444 bytestr = Fstring_as_unibyte (bytestr);
446 bytestr_length = SBYTES (bytestr);
447 vectorp = XVECTOR (vector)->contents;
449 stack.byte_string = bytestr;
450 stack.pc = stack.byte_string_start = SDATA (bytestr);
451 stack.constants = vector;
452 stack.bottom = (Lisp_Object *) alloca (XFASTINT (maxdepth)
453 * sizeof (Lisp_Object));
454 top = stack.bottom - 1;
455 stack.top = NULL;
456 stack.next = byte_stack_list;
457 byte_stack_list = &stack;
459 #ifdef BYTE_CODE_SAFE
460 stacke = stack.bottom - 1 + XFASTINT (maxdepth);
461 #endif
463 while (1)
465 #ifdef BYTE_CODE_SAFE
466 if (top > stacke)
467 abort ();
468 else if (top < stack.bottom - 1)
469 abort ();
470 #endif
472 #ifdef BYTE_CODE_METER
473 prev_op = this_op;
474 this_op = op = FETCH;
475 METER_CODE (prev_op, op);
476 #else
477 op = FETCH;
478 #endif
480 switch (op)
482 case Bvarref + 7:
483 op = FETCH2;
484 goto varref;
486 case Bvarref:
487 case Bvarref + 1:
488 case Bvarref + 2:
489 case Bvarref + 3:
490 case Bvarref + 4:
491 case Bvarref + 5:
492 op = op - Bvarref;
493 goto varref;
495 /* This seems to be the most frequently executed byte-code
496 among the Bvarref's, so avoid a goto here. */
497 case Bvarref+6:
498 op = FETCH;
499 varref:
501 Lisp_Object v1, v2;
503 v1 = vectorp[op];
504 if (SYMBOLP (v1))
506 v2 = SYMBOL_VALUE (v1);
507 if (MISCP (v2) || EQ (v2, Qunbound))
509 BEFORE_POTENTIAL_GC ();
510 v2 = Fsymbol_value (v1);
511 AFTER_POTENTIAL_GC ();
514 else
516 BEFORE_POTENTIAL_GC ();
517 v2 = Fsymbol_value (v1);
518 AFTER_POTENTIAL_GC ();
520 PUSH (v2);
521 break;
524 case Bgotoifnil:
526 Lisp_Object v1;
527 MAYBE_GC ();
528 op = FETCH2;
529 v1 = POP;
530 if (NILP (v1))
532 BYTE_CODE_QUIT;
533 CHECK_RANGE (op);
534 stack.pc = stack.byte_string_start + op;
536 break;
539 case Bcar:
541 Lisp_Object v1;
542 v1 = TOP;
543 TOP = CAR (v1);
544 break;
547 case Beq:
549 Lisp_Object v1;
550 v1 = POP;
551 TOP = EQ (v1, TOP) ? Qt : Qnil;
552 break;
555 case Bmemq:
557 Lisp_Object v1;
558 BEFORE_POTENTIAL_GC ();
559 v1 = POP;
560 TOP = Fmemq (TOP, v1);
561 AFTER_POTENTIAL_GC ();
562 break;
565 case Bcdr:
567 Lisp_Object v1;
568 v1 = TOP;
569 TOP = CDR (v1);
570 break;
573 case Bvarset:
574 case Bvarset+1:
575 case Bvarset+2:
576 case Bvarset+3:
577 case Bvarset+4:
578 case Bvarset+5:
579 op -= Bvarset;
580 goto varset;
582 case Bvarset+7:
583 op = FETCH2;
584 goto varset;
586 case Bvarset+6:
587 op = FETCH;
588 varset:
590 Lisp_Object sym, val;
592 sym = vectorp[op];
593 val = TOP;
595 /* Inline the most common case. */
596 if (SYMBOLP (sym)
597 && !EQ (val, Qunbound)
598 && !XSYMBOL (sym)->indirect_variable
599 && !SYMBOL_CONSTANT_P (sym)
600 && !MISCP (XSYMBOL (sym)->value))
601 XSYMBOL (sym)->value = val;
602 else
604 BEFORE_POTENTIAL_GC ();
605 set_internal (sym, val, current_buffer, 0);
606 AFTER_POTENTIAL_GC ();
609 (void) POP;
610 break;
612 case Bdup:
614 Lisp_Object v1;
615 v1 = TOP;
616 PUSH (v1);
617 break;
620 /* ------------------ */
622 case Bvarbind+6:
623 op = FETCH;
624 goto varbind;
626 case Bvarbind+7:
627 op = FETCH2;
628 goto varbind;
630 case Bvarbind:
631 case Bvarbind+1:
632 case Bvarbind+2:
633 case Bvarbind+3:
634 case Bvarbind+4:
635 case Bvarbind+5:
636 op -= Bvarbind;
637 varbind:
638 /* Specbind can signal and thus GC. */
639 BEFORE_POTENTIAL_GC ();
640 specbind (vectorp[op], POP);
641 AFTER_POTENTIAL_GC ();
642 break;
644 case Bcall+6:
645 op = FETCH;
646 goto docall;
648 case Bcall+7:
649 op = FETCH2;
650 goto docall;
652 case Bcall:
653 case Bcall+1:
654 case Bcall+2:
655 case Bcall+3:
656 case Bcall+4:
657 case Bcall+5:
658 op -= Bcall;
659 docall:
661 BEFORE_POTENTIAL_GC ();
662 DISCARD (op);
663 #ifdef BYTE_CODE_METER
664 if (byte_metering_on && SYMBOLP (TOP))
666 Lisp_Object v1, v2;
668 v1 = TOP;
669 v2 = Fget (v1, Qbyte_code_meter);
670 if (INTEGERP (v2)
671 && XINT (v2) < MOST_POSITIVE_FIXNUM)
673 XSETINT (v2, XINT (v2) + 1);
674 Fput (v1, Qbyte_code_meter, v2);
677 #endif
678 TOP = Ffuncall (op + 1, &TOP);
679 AFTER_POTENTIAL_GC ();
680 break;
683 case Bunbind+6:
684 op = FETCH;
685 goto dounbind;
687 case Bunbind+7:
688 op = FETCH2;
689 goto dounbind;
691 case Bunbind:
692 case Bunbind+1:
693 case Bunbind+2:
694 case Bunbind+3:
695 case Bunbind+4:
696 case Bunbind+5:
697 op -= Bunbind;
698 dounbind:
699 BEFORE_POTENTIAL_GC ();
700 unbind_to (SPECPDL_INDEX () - op, Qnil);
701 AFTER_POTENTIAL_GC ();
702 break;
704 case Bunbind_all:
705 /* To unbind back to the beginning of this frame. Not used yet,
706 but will be needed for tail-recursion elimination. */
707 BEFORE_POTENTIAL_GC ();
708 unbind_to (count, Qnil);
709 AFTER_POTENTIAL_GC ();
710 break;
712 case Bgoto:
713 MAYBE_GC ();
714 BYTE_CODE_QUIT;
715 op = FETCH2; /* pc = FETCH2 loses since FETCH2 contains pc++ */
716 CHECK_RANGE (op);
717 stack.pc = stack.byte_string_start + op;
718 break;
720 case Bgotoifnonnil:
722 Lisp_Object v1;
723 MAYBE_GC ();
724 op = FETCH2;
725 v1 = POP;
726 if (!NILP (v1))
728 BYTE_CODE_QUIT;
729 CHECK_RANGE (op);
730 stack.pc = stack.byte_string_start + op;
732 break;
735 case Bgotoifnilelsepop:
736 MAYBE_GC ();
737 op = FETCH2;
738 if (NILP (TOP))
740 BYTE_CODE_QUIT;
741 CHECK_RANGE (op);
742 stack.pc = stack.byte_string_start + op;
744 else DISCARD (1);
745 break;
747 case Bgotoifnonnilelsepop:
748 MAYBE_GC ();
749 op = FETCH2;
750 if (!NILP (TOP))
752 BYTE_CODE_QUIT;
753 CHECK_RANGE (op);
754 stack.pc = stack.byte_string_start + op;
756 else DISCARD (1);
757 break;
759 case BRgoto:
760 MAYBE_GC ();
761 BYTE_CODE_QUIT;
762 stack.pc += (int) *stack.pc - 127;
763 break;
765 case BRgotoifnil:
767 Lisp_Object v1;
768 MAYBE_GC ();
769 v1 = POP;
770 if (NILP (v1))
772 BYTE_CODE_QUIT;
773 stack.pc += (int) *stack.pc - 128;
775 stack.pc++;
776 break;
779 case BRgotoifnonnil:
781 Lisp_Object v1;
782 MAYBE_GC ();
783 v1 = POP;
784 if (!NILP (v1))
786 BYTE_CODE_QUIT;
787 stack.pc += (int) *stack.pc - 128;
789 stack.pc++;
790 break;
793 case BRgotoifnilelsepop:
794 MAYBE_GC ();
795 op = *stack.pc++;
796 if (NILP (TOP))
798 BYTE_CODE_QUIT;
799 stack.pc += op - 128;
801 else DISCARD (1);
802 break;
804 case BRgotoifnonnilelsepop:
805 MAYBE_GC ();
806 op = *stack.pc++;
807 if (!NILP (TOP))
809 BYTE_CODE_QUIT;
810 stack.pc += op - 128;
812 else DISCARD (1);
813 break;
815 case Breturn:
816 result = POP;
817 goto exit;
819 case Bdiscard:
820 DISCARD (1);
821 break;
823 case Bconstant2:
824 PUSH (vectorp[FETCH2]);
825 break;
827 case Bsave_excursion:
828 record_unwind_protect (save_excursion_restore,
829 save_excursion_save ());
830 break;
832 case Bsave_current_buffer:
833 case Bsave_current_buffer_1:
834 record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ());
835 break;
837 case Bsave_window_excursion:
838 BEFORE_POTENTIAL_GC ();
839 TOP = Fsave_window_excursion (TOP);
840 AFTER_POTENTIAL_GC ();
841 break;
843 case Bsave_restriction:
844 record_unwind_protect (save_restriction_restore,
845 save_restriction_save ());
846 break;
848 case Bcatch:
850 Lisp_Object v1;
851 BEFORE_POTENTIAL_GC ();
852 v1 = POP;
853 TOP = internal_catch (TOP, Feval, v1);
854 AFTER_POTENTIAL_GC ();
855 break;
858 case Bunwind_protect:
859 record_unwind_protect (Fprogn, POP);
860 break;
862 case Bcondition_case:
864 Lisp_Object handlers, body;
865 handlers = POP;
866 body = POP;
867 BEFORE_POTENTIAL_GC ();
868 TOP = internal_lisp_condition_case (TOP, body, handlers);
869 AFTER_POTENTIAL_GC ();
870 break;
873 case Btemp_output_buffer_setup:
874 BEFORE_POTENTIAL_GC ();
875 CHECK_STRING (TOP);
876 temp_output_buffer_setup (SDATA (TOP));
877 AFTER_POTENTIAL_GC ();
878 TOP = Vstandard_output;
879 break;
881 case Btemp_output_buffer_show:
883 Lisp_Object v1;
884 BEFORE_POTENTIAL_GC ();
885 v1 = POP;
886 temp_output_buffer_show (TOP);
887 TOP = v1;
888 /* pop binding of standard-output */
889 unbind_to (SPECPDL_INDEX () - 1, Qnil);
890 AFTER_POTENTIAL_GC ();
891 break;
894 case Bnth:
896 Lisp_Object v1, v2;
897 BEFORE_POTENTIAL_GC ();
898 v1 = POP;
899 v2 = TOP;
900 CHECK_NUMBER (v2);
901 AFTER_POTENTIAL_GC ();
902 op = XINT (v2);
903 immediate_quit = 1;
904 while (--op >= 0 && CONSP (v1))
905 v1 = XCDR (v1);
906 immediate_quit = 0;
907 TOP = CAR (v1);
908 break;
911 case Bsymbolp:
912 TOP = SYMBOLP (TOP) ? Qt : Qnil;
913 break;
915 case Bconsp:
916 TOP = CONSP (TOP) ? Qt : Qnil;
917 break;
919 case Bstringp:
920 TOP = STRINGP (TOP) ? Qt : Qnil;
921 break;
923 case Blistp:
924 TOP = CONSP (TOP) || NILP (TOP) ? Qt : Qnil;
925 break;
927 case Bnot:
928 TOP = NILP (TOP) ? Qt : Qnil;
929 break;
931 case Bcons:
933 Lisp_Object v1;
934 v1 = POP;
935 TOP = Fcons (TOP, v1);
936 break;
939 case Blist1:
940 TOP = Fcons (TOP, Qnil);
941 break;
943 case Blist2:
945 Lisp_Object v1;
946 v1 = POP;
947 TOP = Fcons (TOP, Fcons (v1, Qnil));
948 break;
951 case Blist3:
952 DISCARD (2);
953 TOP = Flist (3, &TOP);
954 break;
956 case Blist4:
957 DISCARD (3);
958 TOP = Flist (4, &TOP);
959 break;
961 case BlistN:
962 op = FETCH;
963 DISCARD (op - 1);
964 TOP = Flist (op, &TOP);
965 break;
967 case Blength:
968 BEFORE_POTENTIAL_GC ();
969 TOP = Flength (TOP);
970 AFTER_POTENTIAL_GC ();
971 break;
973 case Baref:
975 Lisp_Object v1;
976 BEFORE_POTENTIAL_GC ();
977 v1 = POP;
978 TOP = Faref (TOP, v1);
979 AFTER_POTENTIAL_GC ();
980 break;
983 case Baset:
985 Lisp_Object v1, v2;
986 BEFORE_POTENTIAL_GC ();
987 v2 = POP; v1 = POP;
988 TOP = Faset (TOP, v1, v2);
989 AFTER_POTENTIAL_GC ();
990 break;
993 case Bsymbol_value:
994 BEFORE_POTENTIAL_GC ();
995 TOP = Fsymbol_value (TOP);
996 AFTER_POTENTIAL_GC ();
997 break;
999 case Bsymbol_function:
1000 BEFORE_POTENTIAL_GC ();
1001 TOP = Fsymbol_function (TOP);
1002 AFTER_POTENTIAL_GC ();
1003 break;
1005 case Bset:
1007 Lisp_Object v1;
1008 BEFORE_POTENTIAL_GC ();
1009 v1 = POP;
1010 TOP = Fset (TOP, v1);
1011 AFTER_POTENTIAL_GC ();
1012 break;
1015 case Bfset:
1017 Lisp_Object v1;
1018 BEFORE_POTENTIAL_GC ();
1019 v1 = POP;
1020 TOP = Ffset (TOP, v1);
1021 AFTER_POTENTIAL_GC ();
1022 break;
1025 case Bget:
1027 Lisp_Object v1;
1028 BEFORE_POTENTIAL_GC ();
1029 v1 = POP;
1030 TOP = Fget (TOP, v1);
1031 AFTER_POTENTIAL_GC ();
1032 break;
1035 case Bsubstring:
1037 Lisp_Object v1, v2;
1038 BEFORE_POTENTIAL_GC ();
1039 v2 = POP; v1 = POP;
1040 TOP = Fsubstring (TOP, v1, v2);
1041 AFTER_POTENTIAL_GC ();
1042 break;
1045 case Bconcat2:
1046 BEFORE_POTENTIAL_GC ();
1047 DISCARD (1);
1048 TOP = Fconcat (2, &TOP);
1049 AFTER_POTENTIAL_GC ();
1050 break;
1052 case Bconcat3:
1053 BEFORE_POTENTIAL_GC ();
1054 DISCARD (2);
1055 TOP = Fconcat (3, &TOP);
1056 AFTER_POTENTIAL_GC ();
1057 break;
1059 case Bconcat4:
1060 BEFORE_POTENTIAL_GC ();
1061 DISCARD (3);
1062 TOP = Fconcat (4, &TOP);
1063 AFTER_POTENTIAL_GC ();
1064 break;
1066 case BconcatN:
1067 op = FETCH;
1068 BEFORE_POTENTIAL_GC ();
1069 DISCARD (op - 1);
1070 TOP = Fconcat (op, &TOP);
1071 AFTER_POTENTIAL_GC ();
1072 break;
1074 case Bsub1:
1076 Lisp_Object v1;
1077 v1 = TOP;
1078 if (INTEGERP (v1))
1080 XSETINT (v1, XINT (v1) - 1);
1081 TOP = v1;
1083 else
1085 BEFORE_POTENTIAL_GC ();
1086 TOP = Fsub1 (v1);
1087 AFTER_POTENTIAL_GC ();
1089 break;
1092 case Badd1:
1094 Lisp_Object v1;
1095 v1 = TOP;
1096 if (INTEGERP (v1))
1098 XSETINT (v1, XINT (v1) + 1);
1099 TOP = v1;
1101 else
1103 BEFORE_POTENTIAL_GC ();
1104 TOP = Fadd1 (v1);
1105 AFTER_POTENTIAL_GC ();
1107 break;
1110 case Beqlsign:
1112 Lisp_Object v1, v2;
1113 BEFORE_POTENTIAL_GC ();
1114 v2 = POP; v1 = TOP;
1115 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v1);
1116 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v2);
1117 AFTER_POTENTIAL_GC ();
1118 if (FLOATP (v1) || FLOATP (v2))
1120 double f1, f2;
1122 f1 = (FLOATP (v1) ? XFLOAT_DATA (v1) : XINT (v1));
1123 f2 = (FLOATP (v2) ? XFLOAT_DATA (v2) : XINT (v2));
1124 TOP = (f1 == f2 ? Qt : Qnil);
1126 else
1127 TOP = (XINT (v1) == XINT (v2) ? Qt : Qnil);
1128 break;
1131 case Bgtr:
1133 Lisp_Object v1;
1134 BEFORE_POTENTIAL_GC ();
1135 v1 = POP;
1136 TOP = Fgtr (TOP, v1);
1137 AFTER_POTENTIAL_GC ();
1138 break;
1141 case Blss:
1143 Lisp_Object v1;
1144 BEFORE_POTENTIAL_GC ();
1145 v1 = POP;
1146 TOP = Flss (TOP, v1);
1147 AFTER_POTENTIAL_GC ();
1148 break;
1151 case Bleq:
1153 Lisp_Object v1;
1154 BEFORE_POTENTIAL_GC ();
1155 v1 = POP;
1156 TOP = Fleq (TOP, v1);
1157 AFTER_POTENTIAL_GC ();
1158 break;
1161 case Bgeq:
1163 Lisp_Object v1;
1164 BEFORE_POTENTIAL_GC ();
1165 v1 = POP;
1166 TOP = Fgeq (TOP, v1);
1167 AFTER_POTENTIAL_GC ();
1168 break;
1171 case Bdiff:
1172 BEFORE_POTENTIAL_GC ();
1173 DISCARD (1);
1174 TOP = Fminus (2, &TOP);
1175 AFTER_POTENTIAL_GC ();
1176 break;
1178 case Bnegate:
1180 Lisp_Object v1;
1181 v1 = TOP;
1182 if (INTEGERP (v1))
1184 XSETINT (v1, - XINT (v1));
1185 TOP = v1;
1187 else
1189 BEFORE_POTENTIAL_GC ();
1190 TOP = Fminus (1, &TOP);
1191 AFTER_POTENTIAL_GC ();
1193 break;
1196 case Bplus:
1197 BEFORE_POTENTIAL_GC ();
1198 DISCARD (1);
1199 TOP = Fplus (2, &TOP);
1200 AFTER_POTENTIAL_GC ();
1201 break;
1203 case Bmax:
1204 BEFORE_POTENTIAL_GC ();
1205 DISCARD (1);
1206 TOP = Fmax (2, &TOP);
1207 AFTER_POTENTIAL_GC ();
1208 break;
1210 case Bmin:
1211 BEFORE_POTENTIAL_GC ();
1212 DISCARD (1);
1213 TOP = Fmin (2, &TOP);
1214 AFTER_POTENTIAL_GC ();
1215 break;
1217 case Bmult:
1218 BEFORE_POTENTIAL_GC ();
1219 DISCARD (1);
1220 TOP = Ftimes (2, &TOP);
1221 AFTER_POTENTIAL_GC ();
1222 break;
1224 case Bquo:
1225 BEFORE_POTENTIAL_GC ();
1226 DISCARD (1);
1227 TOP = Fquo (2, &TOP);
1228 AFTER_POTENTIAL_GC ();
1229 break;
1231 case Brem:
1233 Lisp_Object v1;
1234 BEFORE_POTENTIAL_GC ();
1235 v1 = POP;
1236 TOP = Frem (TOP, v1);
1237 AFTER_POTENTIAL_GC ();
1238 break;
1241 case Bpoint:
1243 Lisp_Object v1;
1244 XSETFASTINT (v1, PT);
1245 PUSH (v1);
1246 break;
1249 case Bgoto_char:
1250 BEFORE_POTENTIAL_GC ();
1251 TOP = Fgoto_char (TOP);
1252 AFTER_POTENTIAL_GC ();
1253 break;
1255 case Binsert:
1256 BEFORE_POTENTIAL_GC ();
1257 TOP = Finsert (1, &TOP);
1258 AFTER_POTENTIAL_GC ();
1259 break;
1261 case BinsertN:
1262 op = FETCH;
1263 BEFORE_POTENTIAL_GC ();
1264 DISCARD (op - 1);
1265 TOP = Finsert (op, &TOP);
1266 AFTER_POTENTIAL_GC ();
1267 break;
1269 case Bpoint_max:
1271 Lisp_Object v1;
1272 XSETFASTINT (v1, ZV);
1273 PUSH (v1);
1274 break;
1277 case Bpoint_min:
1279 Lisp_Object v1;
1280 XSETFASTINT (v1, BEGV);
1281 PUSH (v1);
1282 break;
1285 case Bchar_after:
1286 BEFORE_POTENTIAL_GC ();
1287 TOP = Fchar_after (TOP);
1288 AFTER_POTENTIAL_GC ();
1289 break;
1291 case Bfollowing_char:
1293 Lisp_Object v1;
1294 BEFORE_POTENTIAL_GC ();
1295 v1 = Ffollowing_char ();
1296 AFTER_POTENTIAL_GC ();
1297 PUSH (v1);
1298 break;
1301 case Bpreceding_char:
1303 Lisp_Object v1;
1304 BEFORE_POTENTIAL_GC ();
1305 v1 = Fprevious_char ();
1306 AFTER_POTENTIAL_GC ();
1307 PUSH (v1);
1308 break;
1311 case Bcurrent_column:
1313 Lisp_Object v1;
1314 BEFORE_POTENTIAL_GC ();
1315 XSETFASTINT (v1, (int) current_column ()); /* iftc */
1316 AFTER_POTENTIAL_GC ();
1317 PUSH (v1);
1318 break;
1321 case Bindent_to:
1322 BEFORE_POTENTIAL_GC ();
1323 TOP = Findent_to (TOP, Qnil);
1324 AFTER_POTENTIAL_GC ();
1325 break;
1327 case Beolp:
1328 PUSH (Feolp ());
1329 break;
1331 case Beobp:
1332 PUSH (Feobp ());
1333 break;
1335 case Bbolp:
1336 PUSH (Fbolp ());
1337 break;
1339 case Bbobp:
1340 PUSH (Fbobp ());
1341 break;
1343 case Bcurrent_buffer:
1344 PUSH (Fcurrent_buffer ());
1345 break;
1347 case Bset_buffer:
1348 BEFORE_POTENTIAL_GC ();
1349 TOP = Fset_buffer (TOP);
1350 AFTER_POTENTIAL_GC ();
1351 break;
1353 case Binteractive_p:
1354 PUSH (Finteractive_p ());
1355 break;
1357 case Bforward_char:
1358 BEFORE_POTENTIAL_GC ();
1359 TOP = Fforward_char (TOP);
1360 AFTER_POTENTIAL_GC ();
1361 break;
1363 case Bforward_word:
1364 BEFORE_POTENTIAL_GC ();
1365 TOP = Fforward_word (TOP);
1366 AFTER_POTENTIAL_GC ();
1367 break;
1369 case Bskip_chars_forward:
1371 Lisp_Object v1;
1372 BEFORE_POTENTIAL_GC ();
1373 v1 = POP;
1374 TOP = Fskip_chars_forward (TOP, v1);
1375 AFTER_POTENTIAL_GC ();
1376 break;
1379 case Bskip_chars_backward:
1381 Lisp_Object v1;
1382 BEFORE_POTENTIAL_GC ();
1383 v1 = POP;
1384 TOP = Fskip_chars_backward (TOP, v1);
1385 AFTER_POTENTIAL_GC ();
1386 break;
1389 case Bforward_line:
1390 BEFORE_POTENTIAL_GC ();
1391 TOP = Fforward_line (TOP);
1392 AFTER_POTENTIAL_GC ();
1393 break;
1395 case Bchar_syntax:
1397 int c;
1399 BEFORE_POTENTIAL_GC ();
1400 CHECK_CHARACTER (TOP);
1401 AFTER_POTENTIAL_GC ();
1402 c = XFASTINT (TOP);
1403 if (NILP (current_buffer->enable_multibyte_characters))
1404 MAKE_CHAR_MULTIBYTE (c);
1405 XSETFASTINT (TOP, syntax_code_spec[(int) SYNTAX (c)]);
1407 break;
1409 case Bbuffer_substring:
1411 Lisp_Object v1;
1412 BEFORE_POTENTIAL_GC ();
1413 v1 = POP;
1414 TOP = Fbuffer_substring (TOP, v1);
1415 AFTER_POTENTIAL_GC ();
1416 break;
1419 case Bdelete_region:
1421 Lisp_Object v1;
1422 BEFORE_POTENTIAL_GC ();
1423 v1 = POP;
1424 TOP = Fdelete_region (TOP, v1);
1425 AFTER_POTENTIAL_GC ();
1426 break;
1429 case Bnarrow_to_region:
1431 Lisp_Object v1;
1432 BEFORE_POTENTIAL_GC ();
1433 v1 = POP;
1434 TOP = Fnarrow_to_region (TOP, v1);
1435 AFTER_POTENTIAL_GC ();
1436 break;
1439 case Bwiden:
1440 BEFORE_POTENTIAL_GC ();
1441 PUSH (Fwiden ());
1442 AFTER_POTENTIAL_GC ();
1443 break;
1445 case Bend_of_line:
1446 BEFORE_POTENTIAL_GC ();
1447 TOP = Fend_of_line (TOP);
1448 AFTER_POTENTIAL_GC ();
1449 break;
1451 case Bset_marker:
1453 Lisp_Object v1, v2;
1454 BEFORE_POTENTIAL_GC ();
1455 v1 = POP;
1456 v2 = POP;
1457 TOP = Fset_marker (TOP, v2, v1);
1458 AFTER_POTENTIAL_GC ();
1459 break;
1462 case Bmatch_beginning:
1463 BEFORE_POTENTIAL_GC ();
1464 TOP = Fmatch_beginning (TOP);
1465 AFTER_POTENTIAL_GC ();
1466 break;
1468 case Bmatch_end:
1469 BEFORE_POTENTIAL_GC ();
1470 TOP = Fmatch_end (TOP);
1471 AFTER_POTENTIAL_GC ();
1472 break;
1474 case Bupcase:
1475 BEFORE_POTENTIAL_GC ();
1476 TOP = Fupcase (TOP);
1477 AFTER_POTENTIAL_GC ();
1478 break;
1480 case Bdowncase:
1481 BEFORE_POTENTIAL_GC ();
1482 TOP = Fdowncase (TOP);
1483 AFTER_POTENTIAL_GC ();
1484 break;
1486 case Bstringeqlsign:
1488 Lisp_Object v1;
1489 BEFORE_POTENTIAL_GC ();
1490 v1 = POP;
1491 TOP = Fstring_equal (TOP, v1);
1492 AFTER_POTENTIAL_GC ();
1493 break;
1496 case Bstringlss:
1498 Lisp_Object v1;
1499 BEFORE_POTENTIAL_GC ();
1500 v1 = POP;
1501 TOP = Fstring_lessp (TOP, v1);
1502 AFTER_POTENTIAL_GC ();
1503 break;
1506 case Bequal:
1508 Lisp_Object v1;
1509 v1 = POP;
1510 TOP = Fequal (TOP, v1);
1511 break;
1514 case Bnthcdr:
1516 Lisp_Object v1;
1517 BEFORE_POTENTIAL_GC ();
1518 v1 = POP;
1519 TOP = Fnthcdr (TOP, v1);
1520 AFTER_POTENTIAL_GC ();
1521 break;
1524 case Belt:
1526 Lisp_Object v1, v2;
1527 if (CONSP (TOP))
1529 /* Exchange args and then do nth. */
1530 BEFORE_POTENTIAL_GC ();
1531 v2 = POP;
1532 v1 = TOP;
1533 CHECK_NUMBER (v2);
1534 AFTER_POTENTIAL_GC ();
1535 op = XINT (v2);
1536 immediate_quit = 1;
1537 while (--op >= 0 && CONSP (v1))
1538 v1 = XCDR (v1);
1539 immediate_quit = 0;
1540 TOP = CAR (v1);
1542 else
1544 BEFORE_POTENTIAL_GC ();
1545 v1 = POP;
1546 TOP = Felt (TOP, v1);
1547 AFTER_POTENTIAL_GC ();
1549 break;
1552 case Bmember:
1554 Lisp_Object v1;
1555 BEFORE_POTENTIAL_GC ();
1556 v1 = POP;
1557 TOP = Fmember (TOP, v1);
1558 AFTER_POTENTIAL_GC ();
1559 break;
1562 case Bassq:
1564 Lisp_Object v1;
1565 BEFORE_POTENTIAL_GC ();
1566 v1 = POP;
1567 TOP = Fassq (TOP, v1);
1568 AFTER_POTENTIAL_GC ();
1569 break;
1572 case Bnreverse:
1573 BEFORE_POTENTIAL_GC ();
1574 TOP = Fnreverse (TOP);
1575 AFTER_POTENTIAL_GC ();
1576 break;
1578 case Bsetcar:
1580 Lisp_Object v1;
1581 BEFORE_POTENTIAL_GC ();
1582 v1 = POP;
1583 TOP = Fsetcar (TOP, v1);
1584 AFTER_POTENTIAL_GC ();
1585 break;
1588 case Bsetcdr:
1590 Lisp_Object v1;
1591 BEFORE_POTENTIAL_GC ();
1592 v1 = POP;
1593 TOP = Fsetcdr (TOP, v1);
1594 AFTER_POTENTIAL_GC ();
1595 break;
1598 case Bcar_safe:
1600 Lisp_Object v1;
1601 v1 = TOP;
1602 TOP = CAR_SAFE (v1);
1603 break;
1606 case Bcdr_safe:
1608 Lisp_Object v1;
1609 v1 = TOP;
1610 TOP = CDR_SAFE (v1);
1611 break;
1614 case Bnconc:
1615 BEFORE_POTENTIAL_GC ();
1616 DISCARD (1);
1617 TOP = Fnconc (2, &TOP);
1618 AFTER_POTENTIAL_GC ();
1619 break;
1621 case Bnumberp:
1622 TOP = (NUMBERP (TOP) ? Qt : Qnil);
1623 break;
1625 case Bintegerp:
1626 TOP = INTEGERP (TOP) ? Qt : Qnil;
1627 break;
1629 #ifdef BYTE_CODE_SAFE
1630 case Bset_mark:
1631 BEFORE_POTENTIAL_GC ();
1632 error ("set-mark is an obsolete bytecode");
1633 AFTER_POTENTIAL_GC ();
1634 break;
1635 case Bscan_buffer:
1636 BEFORE_POTENTIAL_GC ();
1637 error ("scan-buffer is an obsolete bytecode");
1638 AFTER_POTENTIAL_GC ();
1639 break;
1640 #endif
1642 case 0:
1643 abort ();
1645 case 255:
1646 default:
1647 #ifdef BYTE_CODE_SAFE
1648 if (op < Bconstant)
1650 abort ();
1652 if ((op -= Bconstant) >= const_length)
1654 abort ();
1656 PUSH (vectorp[op]);
1657 #else
1658 PUSH (vectorp[op - Bconstant]);
1659 #endif
1663 exit:
1665 byte_stack_list = byte_stack_list->next;
1667 /* Binds and unbinds are supposed to be compiled balanced. */
1668 if (SPECPDL_INDEX () != count)
1669 #ifdef BYTE_CODE_SAFE
1670 error ("binding stack not balanced (serious byte compiler bug)");
1671 #else
1672 abort ();
1673 #endif
1675 return result;
1678 void
1679 syms_of_bytecode ()
1681 Qbytecode = intern ("byte-code");
1682 staticpro (&Qbytecode);
1684 defsubr (&Sbyte_code);
1686 #ifdef BYTE_CODE_METER
1688 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter,
1689 doc: /* A vector of vectors which holds a histogram of byte-code usage.
1690 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
1691 opcode CODE has been executed.
1692 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
1693 indicates how many times the byte opcodes CODE1 and CODE2 have been
1694 executed in succession. */);
1696 DEFVAR_BOOL ("byte-metering-on", &byte_metering_on,
1697 doc: /* If non-nil, keep profiling information on byte code usage.
1698 The variable byte-code-meter indicates how often each byte opcode is used.
1699 If a symbol has a property named `byte-code-meter' whose value is an
1700 integer, it is incremented each time that symbol's function is called. */);
1702 byte_metering_on = 0;
1703 Vbyte_code_meter = Fmake_vector (make_number (256), make_number (0));
1704 Qbyte_code_meter = intern ("byte-code-meter");
1705 staticpro (&Qbyte_code_meter);
1707 int i = 256;
1708 while (i--)
1709 XVECTOR (Vbyte_code_meter)->contents[i] =
1710 Fmake_vector (make_number (256), make_number (0));
1712 #endif
1715 /* arch-tag: b9803b6f-1ed6-4190-8adf-33fd3a9d10e9
1716 (do not change this comment) */