make the minibuffer mutex recursive.
[emacs.git] / src / bytecode.c
blob4f0d326dd9d329d638106fc2a1b2b31ecd92b5ad
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 impl_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;
264 /* Mark objects on byte_stack_list. Called during GC. */
266 void
267 mark_byte_stack (struct byte_stack *stack)
269 Lisp_Object *obj;
271 for (; stack; stack = stack->next)
273 /* If STACK->top is null here, this means there's an opcode in
274 Fbyte_code that wasn't expected to GC, but did. To find out
275 which opcode this is, record the value of `stack', and walk
276 up the stack in a debugger, stopping in frames of Fbyte_code.
277 The culprit is found in the frame of Fbyte_code where the
278 address of its local variable `stack' is equal to the
279 recorded value of `stack' here. */
280 eassert (stack->top);
282 for (obj = stack->bottom; obj <= stack->top; ++obj)
283 mark_object (*obj);
285 mark_object (stack->byte_string);
286 mark_object (stack->constants);
291 /* Unmark objects in the stacks on byte_stack_list. Relocate program
292 counters. Called when GC has completed. */
294 void
295 unmark_byte_stack (struct byte_stack *stack)
297 for (; stack; stack = stack->next)
299 if (stack->byte_string_start != SDATA (stack->byte_string))
301 int offset = stack->pc - stack->byte_string_start;
302 stack->byte_string_start = SDATA (stack->byte_string);
303 stack->pc = stack->byte_string_start + offset;
309 /* Fetch the next byte from the bytecode stream */
311 #define FETCH *stack.pc++
313 /* Fetch two bytes from the bytecode stream and make a 16-bit number
314 out of them */
316 #define FETCH2 (op = FETCH, op + (FETCH << 8))
318 /* Push x onto the execution stack. This used to be #define PUSH(x)
319 (*++stackp = (x)) This oddity is necessary because Alliant can't be
320 bothered to compile the preincrement operator properly, as of 4/91.
321 -JimB */
323 #define PUSH(x) (top++, *top = (x))
325 /* Pop a value off the execution stack. */
327 #define POP (*top--)
329 /* Discard n values from the execution stack. */
331 #define DISCARD(n) (top -= (n))
333 /* Get the value which is at the top of the execution stack, but don't
334 pop it. */
336 #define TOP (*top)
338 /* Actions that must be performed before and after calling a function
339 that might GC. */
341 #define BEFORE_POTENTIAL_GC() stack.top = top
342 #define AFTER_POTENTIAL_GC() stack.top = NULL
344 /* Garbage collect if we have consed enough since the last time.
345 We do this at every branch, to avoid loops that never GC. */
347 #define MAYBE_GC() \
348 if (consing_since_gc > gc_cons_threshold \
349 && consing_since_gc > gc_relative_threshold) \
351 BEFORE_POTENTIAL_GC (); \
352 Fgarbage_collect (); \
353 AFTER_POTENTIAL_GC (); \
355 else
357 /* Check for jumping out of range. */
359 #ifdef BYTE_CODE_SAFE
361 #define CHECK_RANGE(ARG) \
362 if (ARG >= bytestr_length) abort ()
364 #else /* not BYTE_CODE_SAFE */
366 #define CHECK_RANGE(ARG)
368 #endif /* not BYTE_CODE_SAFE */
370 /* A version of the QUIT macro which makes sure that the stack top is
371 set before signaling `quit'. */
373 #define BYTE_CODE_QUIT \
374 do { \
375 if (!NILP (Vquit_flag) && NILP (Vinhibit_quit)) \
377 Lisp_Object flag = Vquit_flag; \
378 Vquit_flag = Qnil; \
379 BEFORE_POTENTIAL_GC (); \
380 if (EQ (Vthrow_on_input, flag)) \
381 Fthrow (Vthrow_on_input, Qt); \
382 Fsignal (Qquit, Qnil); \
383 AFTER_POTENTIAL_GC (); \
385 ELSE_PENDING_SIGNALS \
386 } while (0)
389 DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0,
390 doc: /* Function used internally in byte-compiled code.
391 The first argument, BYTESTR, is a string of byte code;
392 the second, VECTOR, a vector of constants;
393 the third, MAXDEPTH, the maximum stack depth used in this function.
394 If the third argument is incorrect, Emacs may crash. */)
395 (bytestr, vector, maxdepth)
396 Lisp_Object bytestr, vector, maxdepth;
398 int count = SPECPDL_INDEX ();
399 #ifdef BYTE_CODE_METER
400 int this_op = 0;
401 int prev_op;
402 #endif
403 int op;
404 /* Lisp_Object v1, v2; */
405 Lisp_Object *vectorp;
406 #ifdef BYTE_CODE_SAFE
407 int const_length = XVECTOR (vector)->size;
408 Lisp_Object *stacke;
409 #endif
410 int bytestr_length;
411 struct byte_stack stack;
412 Lisp_Object *top;
413 Lisp_Object result;
415 #if 0 /* CHECK_FRAME_FONT */
417 struct frame *f = SELECTED_FRAME ();
418 if (FRAME_X_P (f)
419 && FRAME_FONT (f)->direction != 0
420 && FRAME_FONT (f)->direction != 1)
421 abort ();
423 #endif
425 CHECK_STRING (bytestr);
426 CHECK_VECTOR (vector);
427 CHECK_NUMBER (maxdepth);
429 if (STRING_MULTIBYTE (bytestr))
430 /* BYTESTR must have been produced by Emacs 20.2 or the earlier
431 because they produced a raw 8-bit string for byte-code and now
432 such a byte-code string is loaded as multibyte while raw 8-bit
433 characters converted to multibyte form. Thus, now we must
434 convert them back to the originally intended unibyte form. */
435 bytestr = Fstring_as_unibyte (bytestr);
437 bytestr_length = SBYTES (bytestr);
438 vectorp = XVECTOR (vector)->contents;
440 stack.byte_string = bytestr;
441 stack.pc = stack.byte_string_start = SDATA (bytestr);
442 stack.constants = vector;
443 stack.bottom = (Lisp_Object *) alloca (XFASTINT (maxdepth)
444 * sizeof (Lisp_Object));
445 top = stack.bottom - 1;
446 stack.top = NULL;
447 stack.next = byte_stack_list;
448 byte_stack_list = &stack;
450 #ifdef BYTE_CODE_SAFE
451 stacke = stack.bottom - 1 + XFASTINT (maxdepth);
452 #endif
454 while (1)
456 #ifdef BYTE_CODE_SAFE
457 if (top > stacke)
458 abort ();
459 else if (top < stack.bottom - 1)
460 abort ();
461 #endif
463 #ifdef BYTE_CODE_METER
464 prev_op = this_op;
465 this_op = op = FETCH;
466 METER_CODE (prev_op, op);
467 #else
468 op = FETCH;
469 #endif
471 switch (op)
473 case Bvarref + 7:
474 op = FETCH2;
475 goto varref;
477 case Bvarref:
478 case Bvarref + 1:
479 case Bvarref + 2:
480 case Bvarref + 3:
481 case Bvarref + 4:
482 case Bvarref + 5:
483 op = op - Bvarref;
484 goto varref;
486 /* This seems to be the most frequently executed byte-code
487 among the Bvarref's, so avoid a goto here. */
488 case Bvarref+6:
489 op = FETCH;
490 varref:
492 Lisp_Object v1, v2;
494 v1 = vectorp[op];
495 if (SYMBOLP (v1))
497 v2 = SYMBOL_VALUE (v1);
498 if (MISCP (v2) || EQ (v2, Qunbound))
500 BEFORE_POTENTIAL_GC ();
501 v2 = Fsymbol_value (v1);
502 AFTER_POTENTIAL_GC ();
505 else
507 BEFORE_POTENTIAL_GC ();
508 v2 = Fsymbol_value (v1);
509 AFTER_POTENTIAL_GC ();
511 PUSH (v2);
512 break;
515 case Bgotoifnil:
517 Lisp_Object v1;
518 MAYBE_GC ();
519 op = FETCH2;
520 v1 = POP;
521 if (NILP (v1))
523 BYTE_CODE_QUIT;
524 CHECK_RANGE (op);
525 stack.pc = stack.byte_string_start + op;
527 break;
530 case Bcar:
532 Lisp_Object v1;
533 v1 = TOP;
534 TOP = CAR (v1);
535 break;
538 case Beq:
540 Lisp_Object v1;
541 v1 = POP;
542 TOP = EQ (v1, TOP) ? Qt : Qnil;
543 break;
546 case Bmemq:
548 Lisp_Object v1;
549 BEFORE_POTENTIAL_GC ();
550 v1 = POP;
551 TOP = Fmemq (TOP, v1);
552 AFTER_POTENTIAL_GC ();
553 break;
556 case Bcdr:
558 Lisp_Object v1;
559 v1 = TOP;
560 TOP = CDR (v1);
561 break;
564 case Bvarset:
565 case Bvarset+1:
566 case Bvarset+2:
567 case Bvarset+3:
568 case Bvarset+4:
569 case Bvarset+5:
570 op -= Bvarset;
571 goto varset;
573 case Bvarset+7:
574 op = FETCH2;
575 goto varset;
577 case Bvarset+6:
578 op = FETCH;
579 varset:
581 Lisp_Object sym, val;
583 sym = vectorp[op];
584 val = TOP;
586 /* Inline the most common case. */
587 if (SYMBOLP (sym)
588 && !EQ (val, Qunbound)
589 && !XSYMBOL (sym)->indirect_variable
590 && !SYMBOL_CONSTANT_P (sym)
591 && !MISCP (XSYMBOL (sym)->value))
592 XSYMBOL (sym)->value = val;
593 else
595 BEFORE_POTENTIAL_GC ();
596 set_internal (sym, val, current_buffer, 0);
597 AFTER_POTENTIAL_GC ();
600 (void) POP;
601 break;
603 case Bdup:
605 Lisp_Object v1;
606 v1 = TOP;
607 PUSH (v1);
608 break;
611 /* ------------------ */
613 case Bvarbind+6:
614 op = FETCH;
615 goto varbind;
617 case Bvarbind+7:
618 op = FETCH2;
619 goto varbind;
621 case Bvarbind:
622 case Bvarbind+1:
623 case Bvarbind+2:
624 case Bvarbind+3:
625 case Bvarbind+4:
626 case Bvarbind+5:
627 op -= Bvarbind;
628 varbind:
629 /* Specbind can signal and thus GC. */
630 BEFORE_POTENTIAL_GC ();
631 specbind (vectorp[op], POP);
632 AFTER_POTENTIAL_GC ();
633 break;
635 case Bcall+6:
636 op = FETCH;
637 goto docall;
639 case Bcall+7:
640 op = FETCH2;
641 goto docall;
643 case Bcall:
644 case Bcall+1:
645 case Bcall+2:
646 case Bcall+3:
647 case Bcall+4:
648 case Bcall+5:
649 op -= Bcall;
650 docall:
652 BEFORE_POTENTIAL_GC ();
653 DISCARD (op);
654 #ifdef BYTE_CODE_METER
655 if (byte_metering_on && SYMBOLP (TOP))
657 Lisp_Object v1, v2;
659 v1 = TOP;
660 v2 = Fget (v1, Qbyte_code_meter);
661 if (INTEGERP (v2)
662 && XINT (v2) < MOST_POSITIVE_FIXNUM)
664 XSETINT (v2, XINT (v2) + 1);
665 Fput (v1, Qbyte_code_meter, v2);
668 #endif
669 TOP = Ffuncall (op + 1, &TOP);
670 AFTER_POTENTIAL_GC ();
671 break;
674 case Bunbind+6:
675 op = FETCH;
676 goto dounbind;
678 case Bunbind+7:
679 op = FETCH2;
680 goto dounbind;
682 case Bunbind:
683 case Bunbind+1:
684 case Bunbind+2:
685 case Bunbind+3:
686 case Bunbind+4:
687 case Bunbind+5:
688 op -= Bunbind;
689 dounbind:
690 BEFORE_POTENTIAL_GC ();
691 unbind_to (SPECPDL_INDEX () - op, Qnil);
692 AFTER_POTENTIAL_GC ();
693 break;
695 case Bunbind_all:
696 /* To unbind back to the beginning of this frame. Not used yet,
697 but will be needed for tail-recursion elimination. */
698 BEFORE_POTENTIAL_GC ();
699 unbind_to (count, Qnil);
700 AFTER_POTENTIAL_GC ();
701 break;
703 case Bgoto:
704 MAYBE_GC ();
705 BYTE_CODE_QUIT;
706 op = FETCH2; /* pc = FETCH2 loses since FETCH2 contains pc++ */
707 CHECK_RANGE (op);
708 stack.pc = stack.byte_string_start + op;
709 break;
711 case Bgotoifnonnil:
713 Lisp_Object v1;
714 MAYBE_GC ();
715 op = FETCH2;
716 v1 = POP;
717 if (!NILP (v1))
719 BYTE_CODE_QUIT;
720 CHECK_RANGE (op);
721 stack.pc = stack.byte_string_start + op;
723 break;
726 case Bgotoifnilelsepop:
727 MAYBE_GC ();
728 op = FETCH2;
729 if (NILP (TOP))
731 BYTE_CODE_QUIT;
732 CHECK_RANGE (op);
733 stack.pc = stack.byte_string_start + op;
735 else DISCARD (1);
736 break;
738 case Bgotoifnonnilelsepop:
739 MAYBE_GC ();
740 op = FETCH2;
741 if (!NILP (TOP))
743 BYTE_CODE_QUIT;
744 CHECK_RANGE (op);
745 stack.pc = stack.byte_string_start + op;
747 else DISCARD (1);
748 break;
750 case BRgoto:
751 MAYBE_GC ();
752 BYTE_CODE_QUIT;
753 stack.pc += (int) *stack.pc - 127;
754 break;
756 case BRgotoifnil:
758 Lisp_Object v1;
759 MAYBE_GC ();
760 v1 = POP;
761 if (NILP (v1))
763 BYTE_CODE_QUIT;
764 stack.pc += (int) *stack.pc - 128;
766 stack.pc++;
767 break;
770 case BRgotoifnonnil:
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 BRgotoifnilelsepop:
785 MAYBE_GC ();
786 op = *stack.pc++;
787 if (NILP (TOP))
789 BYTE_CODE_QUIT;
790 stack.pc += op - 128;
792 else DISCARD (1);
793 break;
795 case BRgotoifnonnilelsepop:
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 Breturn:
807 result = POP;
808 goto exit;
810 case Bdiscard:
811 DISCARD (1);
812 break;
814 case Bconstant2:
815 PUSH (vectorp[FETCH2]);
816 break;
818 case Bsave_excursion:
819 record_unwind_protect (save_excursion_restore,
820 save_excursion_save ());
821 break;
823 case Bsave_current_buffer:
824 case Bsave_current_buffer_1:
825 record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ());
826 break;
828 case Bsave_window_excursion:
829 BEFORE_POTENTIAL_GC ();
830 TOP = Fsave_window_excursion (TOP);
831 AFTER_POTENTIAL_GC ();
832 break;
834 case Bsave_restriction:
835 record_unwind_protect (save_restriction_restore,
836 save_restriction_save ());
837 break;
839 case Bcatch:
841 Lisp_Object v1;
842 BEFORE_POTENTIAL_GC ();
843 v1 = POP;
844 TOP = internal_catch (TOP, Feval, v1);
845 AFTER_POTENTIAL_GC ();
846 break;
849 case Bunwind_protect:
850 record_unwind_protect (Fprogn, POP);
851 break;
853 case Bcondition_case:
855 Lisp_Object handlers, body;
856 handlers = POP;
857 body = POP;
858 BEFORE_POTENTIAL_GC ();
859 TOP = internal_lisp_condition_case (TOP, body, handlers);
860 AFTER_POTENTIAL_GC ();
861 break;
864 case Btemp_output_buffer_setup:
865 BEFORE_POTENTIAL_GC ();
866 CHECK_STRING (TOP);
867 temp_output_buffer_setup (SDATA (TOP));
868 AFTER_POTENTIAL_GC ();
869 TOP = Vstandard_output;
870 break;
872 case Btemp_output_buffer_show:
874 Lisp_Object v1;
875 BEFORE_POTENTIAL_GC ();
876 v1 = POP;
877 temp_output_buffer_show (TOP);
878 TOP = v1;
879 /* pop binding of standard-output */
880 unbind_to (SPECPDL_INDEX () - 1, Qnil);
881 AFTER_POTENTIAL_GC ();
882 break;
885 case Bnth:
887 Lisp_Object v1, v2;
888 BEFORE_POTENTIAL_GC ();
889 v1 = POP;
890 v2 = TOP;
891 CHECK_NUMBER (v2);
892 AFTER_POTENTIAL_GC ();
893 op = XINT (v2);
894 immediate_quit = 1;
895 while (--op >= 0 && CONSP (v1))
896 v1 = XCDR (v1);
897 immediate_quit = 0;
898 TOP = CAR (v1);
899 break;
902 case Bsymbolp:
903 TOP = SYMBOLP (TOP) ? Qt : Qnil;
904 break;
906 case Bconsp:
907 TOP = CONSP (TOP) ? Qt : Qnil;
908 break;
910 case Bstringp:
911 TOP = STRINGP (TOP) ? Qt : Qnil;
912 break;
914 case Blistp:
915 TOP = CONSP (TOP) || NILP (TOP) ? Qt : Qnil;
916 break;
918 case Bnot:
919 TOP = NILP (TOP) ? Qt : Qnil;
920 break;
922 case Bcons:
924 Lisp_Object v1;
925 v1 = POP;
926 TOP = Fcons (TOP, v1);
927 break;
930 case Blist1:
931 TOP = Fcons (TOP, Qnil);
932 break;
934 case Blist2:
936 Lisp_Object v1;
937 v1 = POP;
938 TOP = Fcons (TOP, Fcons (v1, Qnil));
939 break;
942 case Blist3:
943 DISCARD (2);
944 TOP = Flist (3, &TOP);
945 break;
947 case Blist4:
948 DISCARD (3);
949 TOP = Flist (4, &TOP);
950 break;
952 case BlistN:
953 op = FETCH;
954 DISCARD (op - 1);
955 TOP = Flist (op, &TOP);
956 break;
958 case Blength:
959 BEFORE_POTENTIAL_GC ();
960 TOP = Flength (TOP);
961 AFTER_POTENTIAL_GC ();
962 break;
964 case Baref:
966 Lisp_Object v1;
967 BEFORE_POTENTIAL_GC ();
968 v1 = POP;
969 TOP = Faref (TOP, v1);
970 AFTER_POTENTIAL_GC ();
971 break;
974 case Baset:
976 Lisp_Object v1, v2;
977 BEFORE_POTENTIAL_GC ();
978 v2 = POP; v1 = POP;
979 TOP = Faset (TOP, v1, v2);
980 AFTER_POTENTIAL_GC ();
981 break;
984 case Bsymbol_value:
985 BEFORE_POTENTIAL_GC ();
986 TOP = Fsymbol_value (TOP);
987 AFTER_POTENTIAL_GC ();
988 break;
990 case Bsymbol_function:
991 BEFORE_POTENTIAL_GC ();
992 TOP = Fsymbol_function (TOP);
993 AFTER_POTENTIAL_GC ();
994 break;
996 case Bset:
998 Lisp_Object v1;
999 BEFORE_POTENTIAL_GC ();
1000 v1 = POP;
1001 TOP = Fset (TOP, v1);
1002 AFTER_POTENTIAL_GC ();
1003 break;
1006 case Bfset:
1008 Lisp_Object v1;
1009 BEFORE_POTENTIAL_GC ();
1010 v1 = POP;
1011 TOP = Ffset (TOP, v1);
1012 AFTER_POTENTIAL_GC ();
1013 break;
1016 case Bget:
1018 Lisp_Object v1;
1019 BEFORE_POTENTIAL_GC ();
1020 v1 = POP;
1021 TOP = Fget (TOP, v1);
1022 AFTER_POTENTIAL_GC ();
1023 break;
1026 case Bsubstring:
1028 Lisp_Object v1, v2;
1029 BEFORE_POTENTIAL_GC ();
1030 v2 = POP; v1 = POP;
1031 TOP = Fsubstring (TOP, v1, v2);
1032 AFTER_POTENTIAL_GC ();
1033 break;
1036 case Bconcat2:
1037 BEFORE_POTENTIAL_GC ();
1038 DISCARD (1);
1039 TOP = Fconcat (2, &TOP);
1040 AFTER_POTENTIAL_GC ();
1041 break;
1043 case Bconcat3:
1044 BEFORE_POTENTIAL_GC ();
1045 DISCARD (2);
1046 TOP = Fconcat (3, &TOP);
1047 AFTER_POTENTIAL_GC ();
1048 break;
1050 case Bconcat4:
1051 BEFORE_POTENTIAL_GC ();
1052 DISCARD (3);
1053 TOP = Fconcat (4, &TOP);
1054 AFTER_POTENTIAL_GC ();
1055 break;
1057 case BconcatN:
1058 op = FETCH;
1059 BEFORE_POTENTIAL_GC ();
1060 DISCARD (op - 1);
1061 TOP = Fconcat (op, &TOP);
1062 AFTER_POTENTIAL_GC ();
1063 break;
1065 case Bsub1:
1067 Lisp_Object v1;
1068 v1 = TOP;
1069 if (INTEGERP (v1))
1071 XSETINT (v1, XINT (v1) - 1);
1072 TOP = v1;
1074 else
1076 BEFORE_POTENTIAL_GC ();
1077 TOP = Fsub1 (v1);
1078 AFTER_POTENTIAL_GC ();
1080 break;
1083 case Badd1:
1085 Lisp_Object v1;
1086 v1 = TOP;
1087 if (INTEGERP (v1))
1089 XSETINT (v1, XINT (v1) + 1);
1090 TOP = v1;
1092 else
1094 BEFORE_POTENTIAL_GC ();
1095 TOP = Fadd1 (v1);
1096 AFTER_POTENTIAL_GC ();
1098 break;
1101 case Beqlsign:
1103 Lisp_Object v1, v2;
1104 BEFORE_POTENTIAL_GC ();
1105 v2 = POP; v1 = TOP;
1106 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v1);
1107 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v2);
1108 AFTER_POTENTIAL_GC ();
1109 if (FLOATP (v1) || FLOATP (v2))
1111 double f1, f2;
1113 f1 = (FLOATP (v1) ? XFLOAT_DATA (v1) : XINT (v1));
1114 f2 = (FLOATP (v2) ? XFLOAT_DATA (v2) : XINT (v2));
1115 TOP = (f1 == f2 ? Qt : Qnil);
1117 else
1118 TOP = (XINT (v1) == XINT (v2) ? Qt : Qnil);
1119 break;
1122 case Bgtr:
1124 Lisp_Object v1;
1125 BEFORE_POTENTIAL_GC ();
1126 v1 = POP;
1127 TOP = Fgtr (TOP, v1);
1128 AFTER_POTENTIAL_GC ();
1129 break;
1132 case Blss:
1134 Lisp_Object v1;
1135 BEFORE_POTENTIAL_GC ();
1136 v1 = POP;
1137 TOP = Flss (TOP, v1);
1138 AFTER_POTENTIAL_GC ();
1139 break;
1142 case Bleq:
1144 Lisp_Object v1;
1145 BEFORE_POTENTIAL_GC ();
1146 v1 = POP;
1147 TOP = Fleq (TOP, v1);
1148 AFTER_POTENTIAL_GC ();
1149 break;
1152 case Bgeq:
1154 Lisp_Object v1;
1155 BEFORE_POTENTIAL_GC ();
1156 v1 = POP;
1157 TOP = Fgeq (TOP, v1);
1158 AFTER_POTENTIAL_GC ();
1159 break;
1162 case Bdiff:
1163 BEFORE_POTENTIAL_GC ();
1164 DISCARD (1);
1165 TOP = Fminus (2, &TOP);
1166 AFTER_POTENTIAL_GC ();
1167 break;
1169 case Bnegate:
1171 Lisp_Object v1;
1172 v1 = TOP;
1173 if (INTEGERP (v1))
1175 XSETINT (v1, - XINT (v1));
1176 TOP = v1;
1178 else
1180 BEFORE_POTENTIAL_GC ();
1181 TOP = Fminus (1, &TOP);
1182 AFTER_POTENTIAL_GC ();
1184 break;
1187 case Bplus:
1188 BEFORE_POTENTIAL_GC ();
1189 DISCARD (1);
1190 TOP = Fplus (2, &TOP);
1191 AFTER_POTENTIAL_GC ();
1192 break;
1194 case Bmax:
1195 BEFORE_POTENTIAL_GC ();
1196 DISCARD (1);
1197 TOP = Fmax (2, &TOP);
1198 AFTER_POTENTIAL_GC ();
1199 break;
1201 case Bmin:
1202 BEFORE_POTENTIAL_GC ();
1203 DISCARD (1);
1204 TOP = Fmin (2, &TOP);
1205 AFTER_POTENTIAL_GC ();
1206 break;
1208 case Bmult:
1209 BEFORE_POTENTIAL_GC ();
1210 DISCARD (1);
1211 TOP = Ftimes (2, &TOP);
1212 AFTER_POTENTIAL_GC ();
1213 break;
1215 case Bquo:
1216 BEFORE_POTENTIAL_GC ();
1217 DISCARD (1);
1218 TOP = Fquo (2, &TOP);
1219 AFTER_POTENTIAL_GC ();
1220 break;
1222 case Brem:
1224 Lisp_Object v1;
1225 BEFORE_POTENTIAL_GC ();
1226 v1 = POP;
1227 TOP = Frem (TOP, v1);
1228 AFTER_POTENTIAL_GC ();
1229 break;
1232 case Bpoint:
1234 Lisp_Object v1;
1235 XSETFASTINT (v1, PT);
1236 PUSH (v1);
1237 break;
1240 case Bgoto_char:
1241 BEFORE_POTENTIAL_GC ();
1242 TOP = Fgoto_char (TOP);
1243 AFTER_POTENTIAL_GC ();
1244 break;
1246 case Binsert:
1247 BEFORE_POTENTIAL_GC ();
1248 TOP = Finsert (1, &TOP);
1249 AFTER_POTENTIAL_GC ();
1250 break;
1252 case BinsertN:
1253 op = FETCH;
1254 BEFORE_POTENTIAL_GC ();
1255 DISCARD (op - 1);
1256 TOP = Finsert (op, &TOP);
1257 AFTER_POTENTIAL_GC ();
1258 break;
1260 case Bpoint_max:
1262 Lisp_Object v1;
1263 XSETFASTINT (v1, ZV);
1264 PUSH (v1);
1265 break;
1268 case Bpoint_min:
1270 Lisp_Object v1;
1271 XSETFASTINT (v1, BEGV);
1272 PUSH (v1);
1273 break;
1276 case Bchar_after:
1277 BEFORE_POTENTIAL_GC ();
1278 TOP = Fchar_after (TOP);
1279 AFTER_POTENTIAL_GC ();
1280 break;
1282 case Bfollowing_char:
1284 Lisp_Object v1;
1285 BEFORE_POTENTIAL_GC ();
1286 v1 = Ffollowing_char ();
1287 AFTER_POTENTIAL_GC ();
1288 PUSH (v1);
1289 break;
1292 case Bpreceding_char:
1294 Lisp_Object v1;
1295 BEFORE_POTENTIAL_GC ();
1296 v1 = Fprevious_char ();
1297 AFTER_POTENTIAL_GC ();
1298 PUSH (v1);
1299 break;
1302 case Bcurrent_column:
1304 Lisp_Object v1;
1305 BEFORE_POTENTIAL_GC ();
1306 XSETFASTINT (v1, (int) current_column ()); /* iftc */
1307 AFTER_POTENTIAL_GC ();
1308 PUSH (v1);
1309 break;
1312 case Bindent_to:
1313 BEFORE_POTENTIAL_GC ();
1314 TOP = Findent_to (TOP, Qnil);
1315 AFTER_POTENTIAL_GC ();
1316 break;
1318 case Beolp:
1319 PUSH (Feolp ());
1320 break;
1322 case Beobp:
1323 PUSH (Feobp ());
1324 break;
1326 case Bbolp:
1327 PUSH (Fbolp ());
1328 break;
1330 case Bbobp:
1331 PUSH (Fbobp ());
1332 break;
1334 case Bcurrent_buffer:
1335 PUSH (Fcurrent_buffer ());
1336 break;
1338 case Bset_buffer:
1339 BEFORE_POTENTIAL_GC ();
1340 TOP = Fset_buffer (TOP);
1341 AFTER_POTENTIAL_GC ();
1342 break;
1344 case Binteractive_p:
1345 PUSH (Finteractive_p ());
1346 break;
1348 case Bforward_char:
1349 BEFORE_POTENTIAL_GC ();
1350 TOP = Fforward_char (TOP);
1351 AFTER_POTENTIAL_GC ();
1352 break;
1354 case Bforward_word:
1355 BEFORE_POTENTIAL_GC ();
1356 TOP = Fforward_word (TOP);
1357 AFTER_POTENTIAL_GC ();
1358 break;
1360 case Bskip_chars_forward:
1362 Lisp_Object v1;
1363 BEFORE_POTENTIAL_GC ();
1364 v1 = POP;
1365 TOP = Fskip_chars_forward (TOP, v1);
1366 AFTER_POTENTIAL_GC ();
1367 break;
1370 case Bskip_chars_backward:
1372 Lisp_Object v1;
1373 BEFORE_POTENTIAL_GC ();
1374 v1 = POP;
1375 TOP = Fskip_chars_backward (TOP, v1);
1376 AFTER_POTENTIAL_GC ();
1377 break;
1380 case Bforward_line:
1381 BEFORE_POTENTIAL_GC ();
1382 TOP = Fforward_line (TOP);
1383 AFTER_POTENTIAL_GC ();
1384 break;
1386 case Bchar_syntax:
1388 int c;
1390 BEFORE_POTENTIAL_GC ();
1391 CHECK_CHARACTER (TOP);
1392 AFTER_POTENTIAL_GC ();
1393 c = XFASTINT (TOP);
1394 if (NILP (BUF_ENABLE_MULTIBYTE_CHARACTERS (current_buffer)))
1395 MAKE_CHAR_MULTIBYTE (c);
1396 XSETFASTINT (TOP, syntax_code_spec[(int) SYNTAX (c)]);
1398 break;
1400 case Bbuffer_substring:
1402 Lisp_Object v1;
1403 BEFORE_POTENTIAL_GC ();
1404 v1 = POP;
1405 TOP = Fbuffer_substring (TOP, v1);
1406 AFTER_POTENTIAL_GC ();
1407 break;
1410 case Bdelete_region:
1412 Lisp_Object v1;
1413 BEFORE_POTENTIAL_GC ();
1414 v1 = POP;
1415 TOP = Fdelete_region (TOP, v1);
1416 AFTER_POTENTIAL_GC ();
1417 break;
1420 case Bnarrow_to_region:
1422 Lisp_Object v1;
1423 BEFORE_POTENTIAL_GC ();
1424 v1 = POP;
1425 TOP = Fnarrow_to_region (TOP, v1);
1426 AFTER_POTENTIAL_GC ();
1427 break;
1430 case Bwiden:
1431 BEFORE_POTENTIAL_GC ();
1432 PUSH (Fwiden ());
1433 AFTER_POTENTIAL_GC ();
1434 break;
1436 case Bend_of_line:
1437 BEFORE_POTENTIAL_GC ();
1438 TOP = Fend_of_line (TOP);
1439 AFTER_POTENTIAL_GC ();
1440 break;
1442 case Bset_marker:
1444 Lisp_Object v1, v2;
1445 BEFORE_POTENTIAL_GC ();
1446 v1 = POP;
1447 v2 = POP;
1448 TOP = Fset_marker (TOP, v2, v1);
1449 AFTER_POTENTIAL_GC ();
1450 break;
1453 case Bmatch_beginning:
1454 BEFORE_POTENTIAL_GC ();
1455 TOP = Fmatch_beginning (TOP);
1456 AFTER_POTENTIAL_GC ();
1457 break;
1459 case Bmatch_end:
1460 BEFORE_POTENTIAL_GC ();
1461 TOP = Fmatch_end (TOP);
1462 AFTER_POTENTIAL_GC ();
1463 break;
1465 case Bupcase:
1466 BEFORE_POTENTIAL_GC ();
1467 TOP = Fupcase (TOP);
1468 AFTER_POTENTIAL_GC ();
1469 break;
1471 case Bdowncase:
1472 BEFORE_POTENTIAL_GC ();
1473 TOP = Fdowncase (TOP);
1474 AFTER_POTENTIAL_GC ();
1475 break;
1477 case Bstringeqlsign:
1479 Lisp_Object v1;
1480 BEFORE_POTENTIAL_GC ();
1481 v1 = POP;
1482 TOP = Fstring_equal (TOP, v1);
1483 AFTER_POTENTIAL_GC ();
1484 break;
1487 case Bstringlss:
1489 Lisp_Object v1;
1490 BEFORE_POTENTIAL_GC ();
1491 v1 = POP;
1492 TOP = Fstring_lessp (TOP, v1);
1493 AFTER_POTENTIAL_GC ();
1494 break;
1497 case Bequal:
1499 Lisp_Object v1;
1500 v1 = POP;
1501 TOP = Fequal (TOP, v1);
1502 break;
1505 case Bnthcdr:
1507 Lisp_Object v1;
1508 BEFORE_POTENTIAL_GC ();
1509 v1 = POP;
1510 TOP = Fnthcdr (TOP, v1);
1511 AFTER_POTENTIAL_GC ();
1512 break;
1515 case Belt:
1517 Lisp_Object v1, v2;
1518 if (CONSP (TOP))
1520 /* Exchange args and then do nth. */
1521 BEFORE_POTENTIAL_GC ();
1522 v2 = POP;
1523 v1 = TOP;
1524 CHECK_NUMBER (v2);
1525 AFTER_POTENTIAL_GC ();
1526 op = XINT (v2);
1527 immediate_quit = 1;
1528 while (--op >= 0 && CONSP (v1))
1529 v1 = XCDR (v1);
1530 immediate_quit = 0;
1531 TOP = CAR (v1);
1533 else
1535 BEFORE_POTENTIAL_GC ();
1536 v1 = POP;
1537 TOP = Felt (TOP, v1);
1538 AFTER_POTENTIAL_GC ();
1540 break;
1543 case Bmember:
1545 Lisp_Object v1;
1546 BEFORE_POTENTIAL_GC ();
1547 v1 = POP;
1548 TOP = Fmember (TOP, v1);
1549 AFTER_POTENTIAL_GC ();
1550 break;
1553 case Bassq:
1555 Lisp_Object v1;
1556 BEFORE_POTENTIAL_GC ();
1557 v1 = POP;
1558 TOP = Fassq (TOP, v1);
1559 AFTER_POTENTIAL_GC ();
1560 break;
1563 case Bnreverse:
1564 BEFORE_POTENTIAL_GC ();
1565 TOP = Fnreverse (TOP);
1566 AFTER_POTENTIAL_GC ();
1567 break;
1569 case Bsetcar:
1571 Lisp_Object v1;
1572 BEFORE_POTENTIAL_GC ();
1573 v1 = POP;
1574 TOP = Fsetcar (TOP, v1);
1575 AFTER_POTENTIAL_GC ();
1576 break;
1579 case Bsetcdr:
1581 Lisp_Object v1;
1582 BEFORE_POTENTIAL_GC ();
1583 v1 = POP;
1584 TOP = Fsetcdr (TOP, v1);
1585 AFTER_POTENTIAL_GC ();
1586 break;
1589 case Bcar_safe:
1591 Lisp_Object v1;
1592 v1 = TOP;
1593 TOP = CAR_SAFE (v1);
1594 break;
1597 case Bcdr_safe:
1599 Lisp_Object v1;
1600 v1 = TOP;
1601 TOP = CDR_SAFE (v1);
1602 break;
1605 case Bnconc:
1606 BEFORE_POTENTIAL_GC ();
1607 DISCARD (1);
1608 TOP = Fnconc (2, &TOP);
1609 AFTER_POTENTIAL_GC ();
1610 break;
1612 case Bnumberp:
1613 TOP = (NUMBERP (TOP) ? Qt : Qnil);
1614 break;
1616 case Bintegerp:
1617 TOP = INTEGERP (TOP) ? Qt : Qnil;
1618 break;
1620 #ifdef BYTE_CODE_SAFE
1621 case Bset_mark:
1622 BEFORE_POTENTIAL_GC ();
1623 error ("set-mark is an obsolete bytecode");
1624 AFTER_POTENTIAL_GC ();
1625 break;
1626 case Bscan_buffer:
1627 BEFORE_POTENTIAL_GC ();
1628 error ("scan-buffer is an obsolete bytecode");
1629 AFTER_POTENTIAL_GC ();
1630 break;
1631 #endif
1633 case 0:
1634 abort ();
1636 case 255:
1637 default:
1638 #ifdef BYTE_CODE_SAFE
1639 if (op < Bconstant)
1641 abort ();
1643 if ((op -= Bconstant) >= const_length)
1645 abort ();
1647 PUSH (vectorp[op]);
1648 #else
1649 PUSH (vectorp[op - Bconstant]);
1650 #endif
1654 exit:
1656 byte_stack_list = byte_stack_list->next;
1658 /* Binds and unbinds are supposed to be compiled balanced. */
1659 if (SPECPDL_INDEX () != count)
1660 #ifdef BYTE_CODE_SAFE
1661 error ("binding stack not balanced (serious byte compiler bug)");
1662 #else
1663 abort ();
1664 #endif
1666 return result;
1669 void
1670 syms_of_bytecode ()
1672 Qbytecode = intern_c_string ("byte-code");
1673 staticpro (&Qbytecode);
1675 defsubr (&Sbyte_code);
1677 #ifdef BYTE_CODE_METER
1679 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter,
1680 doc: /* A vector of vectors which holds a histogram of byte-code usage.
1681 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
1682 opcode CODE has been executed.
1683 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
1684 indicates how many times the byte opcodes CODE1 and CODE2 have been
1685 executed in succession. */);
1687 DEFVAR_BOOL ("byte-metering-on", &byte_metering_on,
1688 doc: /* If non-nil, keep profiling information on byte code usage.
1689 The variable byte-code-meter indicates how often each byte opcode is used.
1690 If a symbol has a property named `byte-code-meter' whose value is an
1691 integer, it is incremented each time that symbol's function is called. */);
1693 byte_metering_on = 0;
1694 Vbyte_code_meter = Fmake_vector (make_number (256), make_number (0));
1695 Qbyte_code_meter = intern_c_string ("byte-code-meter");
1696 staticpro (&Qbyte_code_meter);
1698 int i = 256;
1699 while (i--)
1700 XVECTOR (Vbyte_code_meter)->contents[i] =
1701 Fmake_vector (make_number (256), make_number (0));
1703 #endif
1706 /* arch-tag: b9803b6f-1ed6-4190-8adf-33fd3a9d10e9
1707 (do not change this comment) */