(Info-fontify-node): Set 2nd arg `noerror' of `Info-find-file' to t.
[emacs.git] / src / bytecode.c
blobe23d835cf10e2cffebe75f24865f8ed9d0b902fc
1 /* Execution of byte code produced by bytecomp.el.
2 Copyright (C) 1985, 1986, 1987, 1988, 1993, 2000, 2001, 2002, 2003, 2004,
3 2005 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 2, or (at your option)
10 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; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
20 Boston, MA 02110-1301, USA.
22 hacked on by jwz@lucid.com 17-jun-91
23 o added a compile-time switch to turn on simple sanity checking;
24 o put back the obsolete byte-codes for error-detection;
25 o added a new instruction, unbind_all, which I will use for
26 tail-recursion elimination;
27 o made temp_output_buffer_show be called with the right number
28 of args;
29 o made the new bytecodes be called with args in the right order;
30 o added metering support.
32 by Hallvard:
33 o added relative jump instructions;
34 o all conditionals now only do QUIT if they jump.
37 #include <config.h>
38 #include "lisp.h"
39 #include "buffer.h"
40 #include "charset.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 } while (0)
399 DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0,
400 doc: /* Function used internally in byte-compiled code.
401 The first argument, BYTESTR, is a string of byte code;
402 the second, VECTOR, a vector of constants;
403 the third, MAXDEPTH, the maximum stack depth used in this function.
404 If the third argument is incorrect, Emacs may crash. */)
405 (bytestr, vector, maxdepth)
406 Lisp_Object bytestr, vector, maxdepth;
408 int count = SPECPDL_INDEX ();
409 #ifdef BYTE_CODE_METER
410 int this_op = 0;
411 int prev_op;
412 #endif
413 int op;
414 /* Lisp_Object v1, v2; */
415 Lisp_Object *vectorp;
416 #ifdef BYTE_CODE_SAFE
417 int const_length = XVECTOR (vector)->size;
418 Lisp_Object *stacke;
419 #endif
420 int bytestr_length;
421 struct byte_stack stack;
422 Lisp_Object *top;
423 Lisp_Object result;
425 #ifdef CHECK_FRAME_FONT
427 struct frame *f = SELECTED_FRAME ();
428 if (FRAME_X_P (f)
429 && FRAME_FONT (f)->direction != 0
430 && FRAME_FONT (f)->direction != 1)
431 abort ();
433 #endif
435 CHECK_STRING (bytestr);
436 if (!VECTORP (vector))
437 vector = wrong_type_argument (Qvectorp, 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 v2 = SYMBOL_VALUE (v1);
509 if (MISCP (v2) || EQ (v2, Qunbound))
511 BEFORE_POTENTIAL_GC ();
512 v2 = Fsymbol_value (v1);
513 AFTER_POTENTIAL_GC ();
516 else
518 BEFORE_POTENTIAL_GC ();
519 v2 = Fsymbol_value (v1);
520 AFTER_POTENTIAL_GC ();
522 PUSH (v2);
523 break;
526 case Bgotoifnil:
527 MAYBE_GC ();
528 op = FETCH2;
529 if (NILP (POP))
531 BYTE_CODE_QUIT;
532 CHECK_RANGE (op);
533 stack.pc = stack.byte_string_start + op;
535 break;
537 case Bcar:
539 Lisp_Object v1;
540 v1 = TOP;
541 if (CONSP (v1))
542 TOP = XCAR (v1);
543 else if (NILP (v1))
544 TOP = Qnil;
545 else
547 wrong_type_argument (Qlistp, v1);
549 break;
552 case Beq:
554 Lisp_Object v1;
555 v1 = POP;
556 TOP = EQ (v1, TOP) ? Qt : Qnil;
557 break;
560 case Bmemq:
562 Lisp_Object v1;
563 BEFORE_POTENTIAL_GC ();
564 v1 = POP;
565 TOP = Fmemq (TOP, v1);
566 AFTER_POTENTIAL_GC ();
567 break;
570 case Bcdr:
572 Lisp_Object v1;
573 v1 = TOP;
574 if (CONSP (v1))
575 TOP = XCDR (v1);
576 else if (NILP (v1))
577 TOP = Qnil;
578 else
580 wrong_type_argument (Qlistp, v1);
582 break;
585 case Bvarset:
586 case Bvarset+1:
587 case Bvarset+2:
588 case Bvarset+3:
589 case Bvarset+4:
590 case Bvarset+5:
591 op -= Bvarset;
592 goto varset;
594 case Bvarset+7:
595 op = FETCH2;
596 goto varset;
598 case Bvarset+6:
599 op = FETCH;
600 varset:
602 Lisp_Object sym, val;
604 sym = vectorp[op];
605 val = TOP;
607 /* Inline the most common case. */
608 if (SYMBOLP (sym)
609 && !EQ (val, Qunbound)
610 && !XSYMBOL (sym)->indirect_variable
611 && !XSYMBOL (sym)->constant
612 && !MISCP (XSYMBOL (sym)->value))
613 XSYMBOL (sym)->value = val;
614 else
616 BEFORE_POTENTIAL_GC ();
617 set_internal (sym, val, current_buffer, 0);
618 AFTER_POTENTIAL_GC ();
621 (void) POP;
622 break;
624 case Bdup:
626 Lisp_Object v1;
627 v1 = TOP;
628 PUSH (v1);
629 break;
632 /* ------------------ */
634 case Bvarbind+6:
635 op = FETCH;
636 goto varbind;
638 case Bvarbind+7:
639 op = FETCH2;
640 goto varbind;
642 case Bvarbind:
643 case Bvarbind+1:
644 case Bvarbind+2:
645 case Bvarbind+3:
646 case Bvarbind+4:
647 case Bvarbind+5:
648 op -= Bvarbind;
649 varbind:
650 /* Specbind can signal and thus GC. */
651 BEFORE_POTENTIAL_GC ();
652 specbind (vectorp[op], POP);
653 AFTER_POTENTIAL_GC ();
654 break;
656 case Bcall+6:
657 op = FETCH;
658 goto docall;
660 case Bcall+7:
661 op = FETCH2;
662 goto docall;
664 case Bcall:
665 case Bcall+1:
666 case Bcall+2:
667 case Bcall+3:
668 case Bcall+4:
669 case Bcall+5:
670 op -= Bcall;
671 docall:
673 BEFORE_POTENTIAL_GC ();
674 DISCARD (op);
675 #ifdef BYTE_CODE_METER
676 if (byte_metering_on && SYMBOLP (TOP))
678 Lisp_Object v1, v2;
680 v1 = TOP;
681 v2 = Fget (v1, Qbyte_code_meter);
682 if (INTEGERP (v2)
683 && XINT (v2) < MOST_POSITIVE_FIXNUM)
685 XSETINT (v2, XINT (v2) + 1);
686 Fput (v1, Qbyte_code_meter, v2);
689 #endif
690 TOP = Ffuncall (op + 1, &TOP);
691 AFTER_POTENTIAL_GC ();
692 break;
695 case Bunbind+6:
696 op = FETCH;
697 goto dounbind;
699 case Bunbind+7:
700 op = FETCH2;
701 goto dounbind;
703 case Bunbind:
704 case Bunbind+1:
705 case Bunbind+2:
706 case Bunbind+3:
707 case Bunbind+4:
708 case Bunbind+5:
709 op -= Bunbind;
710 dounbind:
711 BEFORE_POTENTIAL_GC ();
712 unbind_to (SPECPDL_INDEX () - op, Qnil);
713 AFTER_POTENTIAL_GC ();
714 break;
716 case Bunbind_all:
717 /* To unbind back to the beginning of this frame. Not used yet,
718 but will be needed for tail-recursion elimination. */
719 BEFORE_POTENTIAL_GC ();
720 unbind_to (count, Qnil);
721 AFTER_POTENTIAL_GC ();
722 break;
724 case Bgoto:
725 MAYBE_GC ();
726 BYTE_CODE_QUIT;
727 op = FETCH2; /* pc = FETCH2 loses since FETCH2 contains pc++ */
728 CHECK_RANGE (op);
729 stack.pc = stack.byte_string_start + op;
730 break;
732 case Bgotoifnonnil:
733 MAYBE_GC ();
734 op = FETCH2;
735 if (!NILP (POP))
737 BYTE_CODE_QUIT;
738 CHECK_RANGE (op);
739 stack.pc = stack.byte_string_start + op;
741 break;
743 case Bgotoifnilelsepop:
744 MAYBE_GC ();
745 op = FETCH2;
746 if (NILP (TOP))
748 BYTE_CODE_QUIT;
749 CHECK_RANGE (op);
750 stack.pc = stack.byte_string_start + op;
752 else DISCARD (1);
753 break;
755 case Bgotoifnonnilelsepop:
756 MAYBE_GC ();
757 op = FETCH2;
758 if (!NILP (TOP))
760 BYTE_CODE_QUIT;
761 CHECK_RANGE (op);
762 stack.pc = stack.byte_string_start + op;
764 else DISCARD (1);
765 break;
767 case BRgoto:
768 MAYBE_GC ();
769 BYTE_CODE_QUIT;
770 stack.pc += (int) *stack.pc - 127;
771 break;
773 case BRgotoifnil:
774 MAYBE_GC ();
775 if (NILP (POP))
777 BYTE_CODE_QUIT;
778 stack.pc += (int) *stack.pc - 128;
780 stack.pc++;
781 break;
783 case BRgotoifnonnil:
784 MAYBE_GC ();
785 if (!NILP (POP))
787 BYTE_CODE_QUIT;
788 stack.pc += (int) *stack.pc - 128;
790 stack.pc++;
791 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)
906 if (CONSP (v1))
907 v1 = XCDR (v1);
908 else if (!NILP (v1))
910 immediate_quit = 0;
911 wrong_type_argument (Qlistp, v1);
914 immediate_quit = 0;
915 if (CONSP (v1))
916 TOP = XCAR (v1);
917 else if (NILP (v1))
918 TOP = Qnil;
919 else
920 wrong_type_argument (Qlistp, v1);
921 break;
924 case Bsymbolp:
925 TOP = SYMBOLP (TOP) ? Qt : Qnil;
926 break;
928 case Bconsp:
929 TOP = CONSP (TOP) ? Qt : Qnil;
930 break;
932 case Bstringp:
933 TOP = STRINGP (TOP) ? Qt : Qnil;
934 break;
936 case Blistp:
937 TOP = CONSP (TOP) || NILP (TOP) ? Qt : Qnil;
938 break;
940 case Bnot:
941 TOP = NILP (TOP) ? Qt : Qnil;
942 break;
944 case Bcons:
946 Lisp_Object v1;
947 v1 = POP;
948 TOP = Fcons (TOP, v1);
949 break;
952 case Blist1:
953 TOP = Fcons (TOP, Qnil);
954 break;
956 case Blist2:
958 Lisp_Object v1;
959 v1 = POP;
960 TOP = Fcons (TOP, Fcons (v1, Qnil));
961 break;
964 case Blist3:
965 DISCARD (2);
966 TOP = Flist (3, &TOP);
967 break;
969 case Blist4:
970 DISCARD (3);
971 TOP = Flist (4, &TOP);
972 break;
974 case BlistN:
975 op = FETCH;
976 DISCARD (op - 1);
977 TOP = Flist (op, &TOP);
978 break;
980 case Blength:
981 BEFORE_POTENTIAL_GC ();
982 TOP = Flength (TOP);
983 AFTER_POTENTIAL_GC ();
984 break;
986 case Baref:
988 Lisp_Object v1;
989 BEFORE_POTENTIAL_GC ();
990 v1 = POP;
991 TOP = Faref (TOP, v1);
992 AFTER_POTENTIAL_GC ();
993 break;
996 case Baset:
998 Lisp_Object v1, v2;
999 BEFORE_POTENTIAL_GC ();
1000 v2 = POP; v1 = POP;
1001 TOP = Faset (TOP, v1, v2);
1002 AFTER_POTENTIAL_GC ();
1003 break;
1006 case Bsymbol_value:
1007 BEFORE_POTENTIAL_GC ();
1008 TOP = Fsymbol_value (TOP);
1009 AFTER_POTENTIAL_GC ();
1010 break;
1012 case Bsymbol_function:
1013 BEFORE_POTENTIAL_GC ();
1014 TOP = Fsymbol_function (TOP);
1015 AFTER_POTENTIAL_GC ();
1016 break;
1018 case Bset:
1020 Lisp_Object v1;
1021 BEFORE_POTENTIAL_GC ();
1022 v1 = POP;
1023 TOP = Fset (TOP, v1);
1024 AFTER_POTENTIAL_GC ();
1025 break;
1028 case Bfset:
1030 Lisp_Object v1;
1031 BEFORE_POTENTIAL_GC ();
1032 v1 = POP;
1033 TOP = Ffset (TOP, v1);
1034 AFTER_POTENTIAL_GC ();
1035 break;
1038 case Bget:
1040 Lisp_Object v1;
1041 BEFORE_POTENTIAL_GC ();
1042 v1 = POP;
1043 TOP = Fget (TOP, v1);
1044 AFTER_POTENTIAL_GC ();
1045 break;
1048 case Bsubstring:
1050 Lisp_Object v1, v2;
1051 BEFORE_POTENTIAL_GC ();
1052 v2 = POP; v1 = POP;
1053 TOP = Fsubstring (TOP, v1, v2);
1054 AFTER_POTENTIAL_GC ();
1055 break;
1058 case Bconcat2:
1059 BEFORE_POTENTIAL_GC ();
1060 DISCARD (1);
1061 TOP = Fconcat (2, &TOP);
1062 AFTER_POTENTIAL_GC ();
1063 break;
1065 case Bconcat3:
1066 BEFORE_POTENTIAL_GC ();
1067 DISCARD (2);
1068 TOP = Fconcat (3, &TOP);
1069 AFTER_POTENTIAL_GC ();
1070 break;
1072 case Bconcat4:
1073 BEFORE_POTENTIAL_GC ();
1074 DISCARD (3);
1075 TOP = Fconcat (4, &TOP);
1076 AFTER_POTENTIAL_GC ();
1077 break;
1079 case BconcatN:
1080 op = FETCH;
1081 BEFORE_POTENTIAL_GC ();
1082 DISCARD (op - 1);
1083 TOP = Fconcat (op, &TOP);
1084 AFTER_POTENTIAL_GC ();
1085 break;
1087 case Bsub1:
1089 Lisp_Object v1;
1090 v1 = TOP;
1091 if (INTEGERP (v1))
1093 XSETINT (v1, XINT (v1) - 1);
1094 TOP = v1;
1096 else
1098 BEFORE_POTENTIAL_GC ();
1099 TOP = Fsub1 (v1);
1100 AFTER_POTENTIAL_GC ();
1102 break;
1105 case Badd1:
1107 Lisp_Object v1;
1108 v1 = TOP;
1109 if (INTEGERP (v1))
1111 XSETINT (v1, XINT (v1) + 1);
1112 TOP = v1;
1114 else
1116 BEFORE_POTENTIAL_GC ();
1117 TOP = Fadd1 (v1);
1118 AFTER_POTENTIAL_GC ();
1120 break;
1123 case Beqlsign:
1125 Lisp_Object v1, v2;
1126 BEFORE_POTENTIAL_GC ();
1127 v2 = POP; v1 = TOP;
1128 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v1);
1129 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v2);
1130 AFTER_POTENTIAL_GC ();
1131 if (FLOATP (v1) || FLOATP (v2))
1133 double f1, f2;
1135 f1 = (FLOATP (v1) ? XFLOAT_DATA (v1) : XINT (v1));
1136 f2 = (FLOATP (v2) ? XFLOAT_DATA (v2) : XINT (v2));
1137 TOP = (f1 == f2 ? Qt : Qnil);
1139 else
1140 TOP = (XINT (v1) == XINT (v2) ? Qt : Qnil);
1141 break;
1144 case Bgtr:
1146 Lisp_Object v1;
1147 BEFORE_POTENTIAL_GC ();
1148 v1 = POP;
1149 TOP = Fgtr (TOP, v1);
1150 AFTER_POTENTIAL_GC ();
1151 break;
1154 case Blss:
1156 Lisp_Object v1;
1157 BEFORE_POTENTIAL_GC ();
1158 v1 = POP;
1159 TOP = Flss (TOP, v1);
1160 AFTER_POTENTIAL_GC ();
1161 break;
1164 case Bleq:
1166 Lisp_Object v1;
1167 BEFORE_POTENTIAL_GC ();
1168 v1 = POP;
1169 TOP = Fleq (TOP, v1);
1170 AFTER_POTENTIAL_GC ();
1171 break;
1174 case Bgeq:
1176 Lisp_Object v1;
1177 BEFORE_POTENTIAL_GC ();
1178 v1 = POP;
1179 TOP = Fgeq (TOP, v1);
1180 AFTER_POTENTIAL_GC ();
1181 break;
1184 case Bdiff:
1185 BEFORE_POTENTIAL_GC ();
1186 DISCARD (1);
1187 TOP = Fminus (2, &TOP);
1188 AFTER_POTENTIAL_GC ();
1189 break;
1191 case Bnegate:
1193 Lisp_Object v1;
1194 v1 = TOP;
1195 if (INTEGERP (v1))
1197 XSETINT (v1, - XINT (v1));
1198 TOP = v1;
1200 else
1202 BEFORE_POTENTIAL_GC ();
1203 TOP = Fminus (1, &TOP);
1204 AFTER_POTENTIAL_GC ();
1206 break;
1209 case Bplus:
1210 BEFORE_POTENTIAL_GC ();
1211 DISCARD (1);
1212 TOP = Fplus (2, &TOP);
1213 AFTER_POTENTIAL_GC ();
1214 break;
1216 case Bmax:
1217 BEFORE_POTENTIAL_GC ();
1218 DISCARD (1);
1219 TOP = Fmax (2, &TOP);
1220 AFTER_POTENTIAL_GC ();
1221 break;
1223 case Bmin:
1224 BEFORE_POTENTIAL_GC ();
1225 DISCARD (1);
1226 TOP = Fmin (2, &TOP);
1227 AFTER_POTENTIAL_GC ();
1228 break;
1230 case Bmult:
1231 BEFORE_POTENTIAL_GC ();
1232 DISCARD (1);
1233 TOP = Ftimes (2, &TOP);
1234 AFTER_POTENTIAL_GC ();
1235 break;
1237 case Bquo:
1238 BEFORE_POTENTIAL_GC ();
1239 DISCARD (1);
1240 TOP = Fquo (2, &TOP);
1241 AFTER_POTENTIAL_GC ();
1242 break;
1244 case Brem:
1246 Lisp_Object v1;
1247 BEFORE_POTENTIAL_GC ();
1248 v1 = POP;
1249 TOP = Frem (TOP, v1);
1250 AFTER_POTENTIAL_GC ();
1251 break;
1254 case Bpoint:
1256 Lisp_Object v1;
1257 XSETFASTINT (v1, PT);
1258 PUSH (v1);
1259 break;
1262 case Bgoto_char:
1263 BEFORE_POTENTIAL_GC ();
1264 TOP = Fgoto_char (TOP);
1265 AFTER_POTENTIAL_GC ();
1266 break;
1268 case Binsert:
1269 BEFORE_POTENTIAL_GC ();
1270 TOP = Finsert (1, &TOP);
1271 AFTER_POTENTIAL_GC ();
1272 break;
1274 case BinsertN:
1275 op = FETCH;
1276 BEFORE_POTENTIAL_GC ();
1277 DISCARD (op - 1);
1278 TOP = Finsert (op, &TOP);
1279 AFTER_POTENTIAL_GC ();
1280 break;
1282 case Bpoint_max:
1284 Lisp_Object v1;
1285 XSETFASTINT (v1, ZV);
1286 PUSH (v1);
1287 break;
1290 case Bpoint_min:
1292 Lisp_Object v1;
1293 XSETFASTINT (v1, BEGV);
1294 PUSH (v1);
1295 break;
1298 case Bchar_after:
1299 BEFORE_POTENTIAL_GC ();
1300 TOP = Fchar_after (TOP);
1301 AFTER_POTENTIAL_GC ();
1302 break;
1304 case Bfollowing_char:
1306 Lisp_Object v1;
1307 BEFORE_POTENTIAL_GC ();
1308 v1 = Ffollowing_char ();
1309 AFTER_POTENTIAL_GC ();
1310 PUSH (v1);
1311 break;
1314 case Bpreceding_char:
1316 Lisp_Object v1;
1317 BEFORE_POTENTIAL_GC ();
1318 v1 = Fprevious_char ();
1319 AFTER_POTENTIAL_GC ();
1320 PUSH (v1);
1321 break;
1324 case Bcurrent_column:
1326 Lisp_Object v1;
1327 BEFORE_POTENTIAL_GC ();
1328 XSETFASTINT (v1, (int) current_column ()); /* iftc */
1329 AFTER_POTENTIAL_GC ();
1330 PUSH (v1);
1331 break;
1334 case Bindent_to:
1335 BEFORE_POTENTIAL_GC ();
1336 TOP = Findent_to (TOP, Qnil);
1337 AFTER_POTENTIAL_GC ();
1338 break;
1340 case Beolp:
1341 PUSH (Feolp ());
1342 break;
1344 case Beobp:
1345 PUSH (Feobp ());
1346 break;
1348 case Bbolp:
1349 PUSH (Fbolp ());
1350 break;
1352 case Bbobp:
1353 PUSH (Fbobp ());
1354 break;
1356 case Bcurrent_buffer:
1357 PUSH (Fcurrent_buffer ());
1358 break;
1360 case Bset_buffer:
1361 BEFORE_POTENTIAL_GC ();
1362 TOP = Fset_buffer (TOP);
1363 AFTER_POTENTIAL_GC ();
1364 break;
1366 case Binteractive_p:
1367 PUSH (Finteractive_p ());
1368 break;
1370 case Bforward_char:
1371 BEFORE_POTENTIAL_GC ();
1372 TOP = Fforward_char (TOP);
1373 AFTER_POTENTIAL_GC ();
1374 break;
1376 case Bforward_word:
1377 BEFORE_POTENTIAL_GC ();
1378 TOP = Fforward_word (TOP);
1379 AFTER_POTENTIAL_GC ();
1380 break;
1382 case Bskip_chars_forward:
1384 Lisp_Object v1;
1385 BEFORE_POTENTIAL_GC ();
1386 v1 = POP;
1387 TOP = Fskip_chars_forward (TOP, v1);
1388 AFTER_POTENTIAL_GC ();
1389 break;
1392 case Bskip_chars_backward:
1394 Lisp_Object v1;
1395 BEFORE_POTENTIAL_GC ();
1396 v1 = POP;
1397 TOP = Fskip_chars_backward (TOP, v1);
1398 AFTER_POTENTIAL_GC ();
1399 break;
1402 case Bforward_line:
1403 BEFORE_POTENTIAL_GC ();
1404 TOP = Fforward_line (TOP);
1405 AFTER_POTENTIAL_GC ();
1406 break;
1408 case Bchar_syntax:
1409 BEFORE_POTENTIAL_GC ();
1410 CHECK_NUMBER (TOP);
1411 AFTER_POTENTIAL_GC ();
1412 XSETFASTINT (TOP, syntax_code_spec[(int) SYNTAX (XINT (TOP))]);
1413 break;
1415 case Bbuffer_substring:
1417 Lisp_Object v1;
1418 BEFORE_POTENTIAL_GC ();
1419 v1 = POP;
1420 TOP = Fbuffer_substring (TOP, v1);
1421 AFTER_POTENTIAL_GC ();
1422 break;
1425 case Bdelete_region:
1427 Lisp_Object v1;
1428 BEFORE_POTENTIAL_GC ();
1429 v1 = POP;
1430 TOP = Fdelete_region (TOP, v1);
1431 AFTER_POTENTIAL_GC ();
1432 break;
1435 case Bnarrow_to_region:
1437 Lisp_Object v1;
1438 BEFORE_POTENTIAL_GC ();
1439 v1 = POP;
1440 TOP = Fnarrow_to_region (TOP, v1);
1441 AFTER_POTENTIAL_GC ();
1442 break;
1445 case Bwiden:
1446 BEFORE_POTENTIAL_GC ();
1447 PUSH (Fwiden ());
1448 AFTER_POTENTIAL_GC ();
1449 break;
1451 case Bend_of_line:
1452 BEFORE_POTENTIAL_GC ();
1453 TOP = Fend_of_line (TOP);
1454 AFTER_POTENTIAL_GC ();
1455 break;
1457 case Bset_marker:
1459 Lisp_Object v1, v2;
1460 BEFORE_POTENTIAL_GC ();
1461 v1 = POP;
1462 v2 = POP;
1463 TOP = Fset_marker (TOP, v2, v1);
1464 AFTER_POTENTIAL_GC ();
1465 break;
1468 case Bmatch_beginning:
1469 BEFORE_POTENTIAL_GC ();
1470 TOP = Fmatch_beginning (TOP);
1471 AFTER_POTENTIAL_GC ();
1472 break;
1474 case Bmatch_end:
1475 BEFORE_POTENTIAL_GC ();
1476 TOP = Fmatch_end (TOP);
1477 AFTER_POTENTIAL_GC ();
1478 break;
1480 case Bupcase:
1481 BEFORE_POTENTIAL_GC ();
1482 TOP = Fupcase (TOP);
1483 AFTER_POTENTIAL_GC ();
1484 break;
1486 case Bdowncase:
1487 BEFORE_POTENTIAL_GC ();
1488 TOP = Fdowncase (TOP);
1489 AFTER_POTENTIAL_GC ();
1490 break;
1492 case Bstringeqlsign:
1494 Lisp_Object v1;
1495 BEFORE_POTENTIAL_GC ();
1496 v1 = POP;
1497 TOP = Fstring_equal (TOP, v1);
1498 AFTER_POTENTIAL_GC ();
1499 break;
1502 case Bstringlss:
1504 Lisp_Object v1;
1505 BEFORE_POTENTIAL_GC ();
1506 v1 = POP;
1507 TOP = Fstring_lessp (TOP, v1);
1508 AFTER_POTENTIAL_GC ();
1509 break;
1512 case Bequal:
1514 Lisp_Object v1;
1515 v1 = POP;
1516 TOP = Fequal (TOP, v1);
1517 break;
1520 case Bnthcdr:
1522 Lisp_Object v1;
1523 BEFORE_POTENTIAL_GC ();
1524 v1 = POP;
1525 TOP = Fnthcdr (TOP, v1);
1526 AFTER_POTENTIAL_GC ();
1527 break;
1530 case Belt:
1532 Lisp_Object v1, v2;
1533 if (CONSP (TOP))
1535 /* Exchange args and then do nth. */
1536 BEFORE_POTENTIAL_GC ();
1537 v2 = POP;
1538 v1 = TOP;
1539 CHECK_NUMBER (v2);
1540 AFTER_POTENTIAL_GC ();
1541 op = XINT (v2);
1542 immediate_quit = 1;
1543 while (--op >= 0)
1545 if (CONSP (v1))
1546 v1 = XCDR (v1);
1547 else if (!NILP (v1))
1549 immediate_quit = 0;
1550 wrong_type_argument (Qlistp, v1);
1553 immediate_quit = 0;
1554 if (CONSP (v1))
1555 TOP = XCAR (v1);
1556 else if (NILP (v1))
1557 TOP = Qnil;
1558 else
1559 wrong_type_argument (Qlistp, v1);
1561 else
1563 BEFORE_POTENTIAL_GC ();
1564 v1 = POP;
1565 TOP = Felt (TOP, v1);
1566 AFTER_POTENTIAL_GC ();
1568 break;
1571 case Bmember:
1573 Lisp_Object v1;
1574 BEFORE_POTENTIAL_GC ();
1575 v1 = POP;
1576 TOP = Fmember (TOP, v1);
1577 AFTER_POTENTIAL_GC ();
1578 break;
1581 case Bassq:
1583 Lisp_Object v1;
1584 BEFORE_POTENTIAL_GC ();
1585 v1 = POP;
1586 TOP = Fassq (TOP, v1);
1587 AFTER_POTENTIAL_GC ();
1588 break;
1591 case Bnreverse:
1592 BEFORE_POTENTIAL_GC ();
1593 TOP = Fnreverse (TOP);
1594 AFTER_POTENTIAL_GC ();
1595 break;
1597 case Bsetcar:
1599 Lisp_Object v1;
1600 BEFORE_POTENTIAL_GC ();
1601 v1 = POP;
1602 TOP = Fsetcar (TOP, v1);
1603 AFTER_POTENTIAL_GC ();
1604 break;
1607 case Bsetcdr:
1609 Lisp_Object v1;
1610 BEFORE_POTENTIAL_GC ();
1611 v1 = POP;
1612 TOP = Fsetcdr (TOP, v1);
1613 AFTER_POTENTIAL_GC ();
1614 break;
1617 case Bcar_safe:
1619 Lisp_Object v1;
1620 v1 = TOP;
1621 if (CONSP (v1))
1622 TOP = XCAR (v1);
1623 else
1624 TOP = Qnil;
1625 break;
1628 case Bcdr_safe:
1630 Lisp_Object v1;
1631 v1 = TOP;
1632 if (CONSP (v1))
1633 TOP = XCDR (v1);
1634 else
1635 TOP = Qnil;
1636 break;
1639 case Bnconc:
1640 BEFORE_POTENTIAL_GC ();
1641 DISCARD (1);
1642 TOP = Fnconc (2, &TOP);
1643 AFTER_POTENTIAL_GC ();
1644 break;
1646 case Bnumberp:
1647 TOP = (NUMBERP (TOP) ? Qt : Qnil);
1648 break;
1650 case Bintegerp:
1651 TOP = INTEGERP (TOP) ? Qt : Qnil;
1652 break;
1654 #ifdef BYTE_CODE_SAFE
1655 case Bset_mark:
1656 BEFORE_POTENTIAL_GC ();
1657 error ("set-mark is an obsolete bytecode");
1658 AFTER_POTENTIAL_GC ();
1659 break;
1660 case Bscan_buffer:
1661 BEFORE_POTENTIAL_GC ();
1662 error ("scan-buffer is an obsolete bytecode");
1663 AFTER_POTENTIAL_GC ();
1664 break;
1665 #endif
1667 case 0:
1668 abort ();
1670 case 255:
1671 default:
1672 #ifdef BYTE_CODE_SAFE
1673 if (op < Bconstant)
1675 abort ();
1677 if ((op -= Bconstant) >= const_length)
1679 abort ();
1681 PUSH (vectorp[op]);
1682 #else
1683 PUSH (vectorp[op - Bconstant]);
1684 #endif
1688 exit:
1690 byte_stack_list = byte_stack_list->next;
1692 /* Binds and unbinds are supposed to be compiled balanced. */
1693 if (SPECPDL_INDEX () != count)
1694 #ifdef BYTE_CODE_SAFE
1695 error ("binding stack not balanced (serious byte compiler bug)");
1696 #else
1697 abort ();
1698 #endif
1700 return result;
1703 void
1704 syms_of_bytecode ()
1706 Qbytecode = intern ("byte-code");
1707 staticpro (&Qbytecode);
1709 defsubr (&Sbyte_code);
1711 #ifdef BYTE_CODE_METER
1713 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter,
1714 doc: /* A vector of vectors which holds a histogram of byte-code usage.
1715 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
1716 opcode CODE has been executed.
1717 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
1718 indicates how many times the byte opcodes CODE1 and CODE2 have been
1719 executed in succession. */);
1721 DEFVAR_BOOL ("byte-metering-on", &byte_metering_on,
1722 doc: /* If non-nil, keep profiling information on byte code usage.
1723 The variable byte-code-meter indicates how often each byte opcode is used.
1724 If a symbol has a property named `byte-code-meter' whose value is an
1725 integer, it is incremented each time that symbol's function is called. */);
1727 byte_metering_on = 0;
1728 Vbyte_code_meter = Fmake_vector (make_number (256), make_number (0));
1729 Qbyte_code_meter = intern ("byte-code-meter");
1730 staticpro (&Qbyte_code_meter);
1732 int i = 256;
1733 while (i--)
1734 XVECTOR (Vbyte_code_meter)->contents[i] =
1735 Fmake_vector (make_number (256), make_number (0));
1737 #endif
1740 /* arch-tag: b9803b6f-1ed6-4190-8adf-33fd3a9d10e9
1741 (do not change this comment) */