(custom-add-parent-links): Filter out custom-group-link,
[emacs.git] / src / bytecode.c
blobaf09061dbc3cb129d7e6cb4d72bad310fba0b3ba
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:
528 Lisp_Object v1;
529 MAYBE_GC ();
530 op = FETCH2;
531 v1 = POP;
532 if (NILP (v1))
534 BYTE_CODE_QUIT;
535 CHECK_RANGE (op);
536 stack.pc = stack.byte_string_start + op;
538 break;
541 case Bcar:
543 Lisp_Object v1;
544 v1 = TOP;
545 if (CONSP (v1))
546 TOP = XCAR (v1);
547 else if (NILP (v1))
548 TOP = Qnil;
549 else
551 wrong_type_argument (Qlistp, v1);
553 break;
556 case Beq:
558 Lisp_Object v1;
559 v1 = POP;
560 TOP = EQ (v1, TOP) ? Qt : Qnil;
561 break;
564 case Bmemq:
566 Lisp_Object v1;
567 BEFORE_POTENTIAL_GC ();
568 v1 = POP;
569 TOP = Fmemq (TOP, v1);
570 AFTER_POTENTIAL_GC ();
571 break;
574 case Bcdr:
576 Lisp_Object v1;
577 v1 = TOP;
578 if (CONSP (v1))
579 TOP = XCDR (v1);
580 else if (NILP (v1))
581 TOP = Qnil;
582 else
584 wrong_type_argument (Qlistp, v1);
586 break;
589 case Bvarset:
590 case Bvarset+1:
591 case Bvarset+2:
592 case Bvarset+3:
593 case Bvarset+4:
594 case Bvarset+5:
595 op -= Bvarset;
596 goto varset;
598 case Bvarset+7:
599 op = FETCH2;
600 goto varset;
602 case Bvarset+6:
603 op = FETCH;
604 varset:
606 Lisp_Object sym, val;
608 sym = vectorp[op];
609 val = TOP;
611 /* Inline the most common case. */
612 if (SYMBOLP (sym)
613 && !EQ (val, Qunbound)
614 && !XSYMBOL (sym)->indirect_variable
615 && !XSYMBOL (sym)->constant
616 && !MISCP (XSYMBOL (sym)->value))
617 XSYMBOL (sym)->value = val;
618 else
620 BEFORE_POTENTIAL_GC ();
621 set_internal (sym, val, current_buffer, 0);
622 AFTER_POTENTIAL_GC ();
625 (void) POP;
626 break;
628 case Bdup:
630 Lisp_Object v1;
631 v1 = TOP;
632 PUSH (v1);
633 break;
636 /* ------------------ */
638 case Bvarbind+6:
639 op = FETCH;
640 goto varbind;
642 case Bvarbind+7:
643 op = FETCH2;
644 goto varbind;
646 case Bvarbind:
647 case Bvarbind+1:
648 case Bvarbind+2:
649 case Bvarbind+3:
650 case Bvarbind+4:
651 case Bvarbind+5:
652 op -= Bvarbind;
653 varbind:
654 /* Specbind can signal and thus GC. */
655 BEFORE_POTENTIAL_GC ();
656 specbind (vectorp[op], POP);
657 AFTER_POTENTIAL_GC ();
658 break;
660 case Bcall+6:
661 op = FETCH;
662 goto docall;
664 case Bcall+7:
665 op = FETCH2;
666 goto docall;
668 case Bcall:
669 case Bcall+1:
670 case Bcall+2:
671 case Bcall+3:
672 case Bcall+4:
673 case Bcall+5:
674 op -= Bcall;
675 docall:
677 BEFORE_POTENTIAL_GC ();
678 DISCARD (op);
679 #ifdef BYTE_CODE_METER
680 if (byte_metering_on && SYMBOLP (TOP))
682 Lisp_Object v1, v2;
684 v1 = TOP;
685 v2 = Fget (v1, Qbyte_code_meter);
686 if (INTEGERP (v2)
687 && XINT (v2) < MOST_POSITIVE_FIXNUM)
689 XSETINT (v2, XINT (v2) + 1);
690 Fput (v1, Qbyte_code_meter, v2);
693 #endif
694 TOP = Ffuncall (op + 1, &TOP);
695 AFTER_POTENTIAL_GC ();
696 break;
699 case Bunbind+6:
700 op = FETCH;
701 goto dounbind;
703 case Bunbind+7:
704 op = FETCH2;
705 goto dounbind;
707 case Bunbind:
708 case Bunbind+1:
709 case Bunbind+2:
710 case Bunbind+3:
711 case Bunbind+4:
712 case Bunbind+5:
713 op -= Bunbind;
714 dounbind:
715 BEFORE_POTENTIAL_GC ();
716 unbind_to (SPECPDL_INDEX () - op, Qnil);
717 AFTER_POTENTIAL_GC ();
718 break;
720 case Bunbind_all:
721 /* To unbind back to the beginning of this frame. Not used yet,
722 but will be needed for tail-recursion elimination. */
723 BEFORE_POTENTIAL_GC ();
724 unbind_to (count, Qnil);
725 AFTER_POTENTIAL_GC ();
726 break;
728 case Bgoto:
729 MAYBE_GC ();
730 BYTE_CODE_QUIT;
731 op = FETCH2; /* pc = FETCH2 loses since FETCH2 contains pc++ */
732 CHECK_RANGE (op);
733 stack.pc = stack.byte_string_start + op;
734 break;
736 case Bgotoifnonnil:
738 Lisp_Object v1;
739 MAYBE_GC ();
740 op = FETCH2;
741 v1 = POP;
742 if (!NILP (v1))
744 BYTE_CODE_QUIT;
745 CHECK_RANGE (op);
746 stack.pc = stack.byte_string_start + op;
748 break;
751 case Bgotoifnilelsepop:
752 MAYBE_GC ();
753 op = FETCH2;
754 if (NILP (TOP))
756 BYTE_CODE_QUIT;
757 CHECK_RANGE (op);
758 stack.pc = stack.byte_string_start + op;
760 else DISCARD (1);
761 break;
763 case Bgotoifnonnilelsepop:
764 MAYBE_GC ();
765 op = FETCH2;
766 if (!NILP (TOP))
768 BYTE_CODE_QUIT;
769 CHECK_RANGE (op);
770 stack.pc = stack.byte_string_start + op;
772 else DISCARD (1);
773 break;
775 case BRgoto:
776 MAYBE_GC ();
777 BYTE_CODE_QUIT;
778 stack.pc += (int) *stack.pc - 127;
779 break;
781 case BRgotoifnil:
783 Lisp_Object v1;
784 MAYBE_GC ();
785 v1 = POP;
786 if (NILP (v1))
788 BYTE_CODE_QUIT;
789 stack.pc += (int) *stack.pc - 128;
791 stack.pc++;
792 break;
795 case BRgotoifnonnil:
797 Lisp_Object v1;
798 MAYBE_GC ();
799 v1 = POP;
800 if (!NILP (v1))
802 BYTE_CODE_QUIT;
803 stack.pc += (int) *stack.pc - 128;
805 stack.pc++;
806 break;
809 case BRgotoifnilelsepop:
810 MAYBE_GC ();
811 op = *stack.pc++;
812 if (NILP (TOP))
814 BYTE_CODE_QUIT;
815 stack.pc += op - 128;
817 else DISCARD (1);
818 break;
820 case BRgotoifnonnilelsepop:
821 MAYBE_GC ();
822 op = *stack.pc++;
823 if (!NILP (TOP))
825 BYTE_CODE_QUIT;
826 stack.pc += op - 128;
828 else DISCARD (1);
829 break;
831 case Breturn:
832 result = POP;
833 goto exit;
835 case Bdiscard:
836 DISCARD (1);
837 break;
839 case Bconstant2:
840 PUSH (vectorp[FETCH2]);
841 break;
843 case Bsave_excursion:
844 record_unwind_protect (save_excursion_restore,
845 save_excursion_save ());
846 break;
848 case Bsave_current_buffer:
849 case Bsave_current_buffer_1:
850 record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ());
851 break;
853 case Bsave_window_excursion:
854 BEFORE_POTENTIAL_GC ();
855 TOP = Fsave_window_excursion (TOP);
856 AFTER_POTENTIAL_GC ();
857 break;
859 case Bsave_restriction:
860 record_unwind_protect (save_restriction_restore,
861 save_restriction_save ());
862 break;
864 case Bcatch:
866 Lisp_Object v1;
867 BEFORE_POTENTIAL_GC ();
868 v1 = POP;
869 TOP = internal_catch (TOP, Feval, v1);
870 AFTER_POTENTIAL_GC ();
871 break;
874 case Bunwind_protect:
875 record_unwind_protect (Fprogn, POP);
876 break;
878 case Bcondition_case:
880 Lisp_Object handlers, body;
881 handlers = POP;
882 body = POP;
883 BEFORE_POTENTIAL_GC ();
884 TOP = internal_lisp_condition_case (TOP, body, handlers);
885 AFTER_POTENTIAL_GC ();
886 break;
889 case Btemp_output_buffer_setup:
890 BEFORE_POTENTIAL_GC ();
891 CHECK_STRING (TOP);
892 temp_output_buffer_setup (SDATA (TOP));
893 AFTER_POTENTIAL_GC ();
894 TOP = Vstandard_output;
895 break;
897 case Btemp_output_buffer_show:
899 Lisp_Object v1;
900 BEFORE_POTENTIAL_GC ();
901 v1 = POP;
902 temp_output_buffer_show (TOP);
903 TOP = v1;
904 /* pop binding of standard-output */
905 unbind_to (SPECPDL_INDEX () - 1, Qnil);
906 AFTER_POTENTIAL_GC ();
907 break;
910 case Bnth:
912 Lisp_Object v1, v2;
913 BEFORE_POTENTIAL_GC ();
914 v1 = POP;
915 v2 = TOP;
916 CHECK_NUMBER (v2);
917 AFTER_POTENTIAL_GC ();
918 op = XINT (v2);
919 immediate_quit = 1;
920 while (--op >= 0)
922 if (CONSP (v1))
923 v1 = XCDR (v1);
924 else if (!NILP (v1))
926 immediate_quit = 0;
927 wrong_type_argument (Qlistp, v1);
930 immediate_quit = 0;
931 if (CONSP (v1))
932 TOP = XCAR (v1);
933 else if (NILP (v1))
934 TOP = Qnil;
935 else
936 wrong_type_argument (Qlistp, v1);
937 break;
940 case Bsymbolp:
941 TOP = SYMBOLP (TOP) ? Qt : Qnil;
942 break;
944 case Bconsp:
945 TOP = CONSP (TOP) ? Qt : Qnil;
946 break;
948 case Bstringp:
949 TOP = STRINGP (TOP) ? Qt : Qnil;
950 break;
952 case Blistp:
953 TOP = CONSP (TOP) || NILP (TOP) ? Qt : Qnil;
954 break;
956 case Bnot:
957 TOP = NILP (TOP) ? Qt : Qnil;
958 break;
960 case Bcons:
962 Lisp_Object v1;
963 v1 = POP;
964 TOP = Fcons (TOP, v1);
965 break;
968 case Blist1:
969 TOP = Fcons (TOP, Qnil);
970 break;
972 case Blist2:
974 Lisp_Object v1;
975 v1 = POP;
976 TOP = Fcons (TOP, Fcons (v1, Qnil));
977 break;
980 case Blist3:
981 DISCARD (2);
982 TOP = Flist (3, &TOP);
983 break;
985 case Blist4:
986 DISCARD (3);
987 TOP = Flist (4, &TOP);
988 break;
990 case BlistN:
991 op = FETCH;
992 DISCARD (op - 1);
993 TOP = Flist (op, &TOP);
994 break;
996 case Blength:
997 BEFORE_POTENTIAL_GC ();
998 TOP = Flength (TOP);
999 AFTER_POTENTIAL_GC ();
1000 break;
1002 case Baref:
1004 Lisp_Object v1;
1005 BEFORE_POTENTIAL_GC ();
1006 v1 = POP;
1007 TOP = Faref (TOP, v1);
1008 AFTER_POTENTIAL_GC ();
1009 break;
1012 case Baset:
1014 Lisp_Object v1, v2;
1015 BEFORE_POTENTIAL_GC ();
1016 v2 = POP; v1 = POP;
1017 TOP = Faset (TOP, v1, v2);
1018 AFTER_POTENTIAL_GC ();
1019 break;
1022 case Bsymbol_value:
1023 BEFORE_POTENTIAL_GC ();
1024 TOP = Fsymbol_value (TOP);
1025 AFTER_POTENTIAL_GC ();
1026 break;
1028 case Bsymbol_function:
1029 BEFORE_POTENTIAL_GC ();
1030 TOP = Fsymbol_function (TOP);
1031 AFTER_POTENTIAL_GC ();
1032 break;
1034 case Bset:
1036 Lisp_Object v1;
1037 BEFORE_POTENTIAL_GC ();
1038 v1 = POP;
1039 TOP = Fset (TOP, v1);
1040 AFTER_POTENTIAL_GC ();
1041 break;
1044 case Bfset:
1046 Lisp_Object v1;
1047 BEFORE_POTENTIAL_GC ();
1048 v1 = POP;
1049 TOP = Ffset (TOP, v1);
1050 AFTER_POTENTIAL_GC ();
1051 break;
1054 case Bget:
1056 Lisp_Object v1;
1057 BEFORE_POTENTIAL_GC ();
1058 v1 = POP;
1059 TOP = Fget (TOP, v1);
1060 AFTER_POTENTIAL_GC ();
1061 break;
1064 case Bsubstring:
1066 Lisp_Object v1, v2;
1067 BEFORE_POTENTIAL_GC ();
1068 v2 = POP; v1 = POP;
1069 TOP = Fsubstring (TOP, v1, v2);
1070 AFTER_POTENTIAL_GC ();
1071 break;
1074 case Bconcat2:
1075 BEFORE_POTENTIAL_GC ();
1076 DISCARD (1);
1077 TOP = Fconcat (2, &TOP);
1078 AFTER_POTENTIAL_GC ();
1079 break;
1081 case Bconcat3:
1082 BEFORE_POTENTIAL_GC ();
1083 DISCARD (2);
1084 TOP = Fconcat (3, &TOP);
1085 AFTER_POTENTIAL_GC ();
1086 break;
1088 case Bconcat4:
1089 BEFORE_POTENTIAL_GC ();
1090 DISCARD (3);
1091 TOP = Fconcat (4, &TOP);
1092 AFTER_POTENTIAL_GC ();
1093 break;
1095 case BconcatN:
1096 op = FETCH;
1097 BEFORE_POTENTIAL_GC ();
1098 DISCARD (op - 1);
1099 TOP = Fconcat (op, &TOP);
1100 AFTER_POTENTIAL_GC ();
1101 break;
1103 case Bsub1:
1105 Lisp_Object v1;
1106 v1 = TOP;
1107 if (INTEGERP (v1))
1109 XSETINT (v1, XINT (v1) - 1);
1110 TOP = v1;
1112 else
1114 BEFORE_POTENTIAL_GC ();
1115 TOP = Fsub1 (v1);
1116 AFTER_POTENTIAL_GC ();
1118 break;
1121 case Badd1:
1123 Lisp_Object v1;
1124 v1 = TOP;
1125 if (INTEGERP (v1))
1127 XSETINT (v1, XINT (v1) + 1);
1128 TOP = v1;
1130 else
1132 BEFORE_POTENTIAL_GC ();
1133 TOP = Fadd1 (v1);
1134 AFTER_POTENTIAL_GC ();
1136 break;
1139 case Beqlsign:
1141 Lisp_Object v1, v2;
1142 BEFORE_POTENTIAL_GC ();
1143 v2 = POP; v1 = TOP;
1144 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v1);
1145 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v2);
1146 AFTER_POTENTIAL_GC ();
1147 if (FLOATP (v1) || FLOATP (v2))
1149 double f1, f2;
1151 f1 = (FLOATP (v1) ? XFLOAT_DATA (v1) : XINT (v1));
1152 f2 = (FLOATP (v2) ? XFLOAT_DATA (v2) : XINT (v2));
1153 TOP = (f1 == f2 ? Qt : Qnil);
1155 else
1156 TOP = (XINT (v1) == XINT (v2) ? Qt : Qnil);
1157 break;
1160 case Bgtr:
1162 Lisp_Object v1;
1163 BEFORE_POTENTIAL_GC ();
1164 v1 = POP;
1165 TOP = Fgtr (TOP, v1);
1166 AFTER_POTENTIAL_GC ();
1167 break;
1170 case Blss:
1172 Lisp_Object v1;
1173 BEFORE_POTENTIAL_GC ();
1174 v1 = POP;
1175 TOP = Flss (TOP, v1);
1176 AFTER_POTENTIAL_GC ();
1177 break;
1180 case Bleq:
1182 Lisp_Object v1;
1183 BEFORE_POTENTIAL_GC ();
1184 v1 = POP;
1185 TOP = Fleq (TOP, v1);
1186 AFTER_POTENTIAL_GC ();
1187 break;
1190 case Bgeq:
1192 Lisp_Object v1;
1193 BEFORE_POTENTIAL_GC ();
1194 v1 = POP;
1195 TOP = Fgeq (TOP, v1);
1196 AFTER_POTENTIAL_GC ();
1197 break;
1200 case Bdiff:
1201 BEFORE_POTENTIAL_GC ();
1202 DISCARD (1);
1203 TOP = Fminus (2, &TOP);
1204 AFTER_POTENTIAL_GC ();
1205 break;
1207 case Bnegate:
1209 Lisp_Object v1;
1210 v1 = TOP;
1211 if (INTEGERP (v1))
1213 XSETINT (v1, - XINT (v1));
1214 TOP = v1;
1216 else
1218 BEFORE_POTENTIAL_GC ();
1219 TOP = Fminus (1, &TOP);
1220 AFTER_POTENTIAL_GC ();
1222 break;
1225 case Bplus:
1226 BEFORE_POTENTIAL_GC ();
1227 DISCARD (1);
1228 TOP = Fplus (2, &TOP);
1229 AFTER_POTENTIAL_GC ();
1230 break;
1232 case Bmax:
1233 BEFORE_POTENTIAL_GC ();
1234 DISCARD (1);
1235 TOP = Fmax (2, &TOP);
1236 AFTER_POTENTIAL_GC ();
1237 break;
1239 case Bmin:
1240 BEFORE_POTENTIAL_GC ();
1241 DISCARD (1);
1242 TOP = Fmin (2, &TOP);
1243 AFTER_POTENTIAL_GC ();
1244 break;
1246 case Bmult:
1247 BEFORE_POTENTIAL_GC ();
1248 DISCARD (1);
1249 TOP = Ftimes (2, &TOP);
1250 AFTER_POTENTIAL_GC ();
1251 break;
1253 case Bquo:
1254 BEFORE_POTENTIAL_GC ();
1255 DISCARD (1);
1256 TOP = Fquo (2, &TOP);
1257 AFTER_POTENTIAL_GC ();
1258 break;
1260 case Brem:
1262 Lisp_Object v1;
1263 BEFORE_POTENTIAL_GC ();
1264 v1 = POP;
1265 TOP = Frem (TOP, v1);
1266 AFTER_POTENTIAL_GC ();
1267 break;
1270 case Bpoint:
1272 Lisp_Object v1;
1273 XSETFASTINT (v1, PT);
1274 PUSH (v1);
1275 break;
1278 case Bgoto_char:
1279 BEFORE_POTENTIAL_GC ();
1280 TOP = Fgoto_char (TOP);
1281 AFTER_POTENTIAL_GC ();
1282 break;
1284 case Binsert:
1285 BEFORE_POTENTIAL_GC ();
1286 TOP = Finsert (1, &TOP);
1287 AFTER_POTENTIAL_GC ();
1288 break;
1290 case BinsertN:
1291 op = FETCH;
1292 BEFORE_POTENTIAL_GC ();
1293 DISCARD (op - 1);
1294 TOP = Finsert (op, &TOP);
1295 AFTER_POTENTIAL_GC ();
1296 break;
1298 case Bpoint_max:
1300 Lisp_Object v1;
1301 XSETFASTINT (v1, ZV);
1302 PUSH (v1);
1303 break;
1306 case Bpoint_min:
1308 Lisp_Object v1;
1309 XSETFASTINT (v1, BEGV);
1310 PUSH (v1);
1311 break;
1314 case Bchar_after:
1315 BEFORE_POTENTIAL_GC ();
1316 TOP = Fchar_after (TOP);
1317 AFTER_POTENTIAL_GC ();
1318 break;
1320 case Bfollowing_char:
1322 Lisp_Object v1;
1323 BEFORE_POTENTIAL_GC ();
1324 v1 = Ffollowing_char ();
1325 AFTER_POTENTIAL_GC ();
1326 PUSH (v1);
1327 break;
1330 case Bpreceding_char:
1332 Lisp_Object v1;
1333 BEFORE_POTENTIAL_GC ();
1334 v1 = Fprevious_char ();
1335 AFTER_POTENTIAL_GC ();
1336 PUSH (v1);
1337 break;
1340 case Bcurrent_column:
1342 Lisp_Object v1;
1343 BEFORE_POTENTIAL_GC ();
1344 XSETFASTINT (v1, (int) current_column ()); /* iftc */
1345 AFTER_POTENTIAL_GC ();
1346 PUSH (v1);
1347 break;
1350 case Bindent_to:
1351 BEFORE_POTENTIAL_GC ();
1352 TOP = Findent_to (TOP, Qnil);
1353 AFTER_POTENTIAL_GC ();
1354 break;
1356 case Beolp:
1357 PUSH (Feolp ());
1358 break;
1360 case Beobp:
1361 PUSH (Feobp ());
1362 break;
1364 case Bbolp:
1365 PUSH (Fbolp ());
1366 break;
1368 case Bbobp:
1369 PUSH (Fbobp ());
1370 break;
1372 case Bcurrent_buffer:
1373 PUSH (Fcurrent_buffer ());
1374 break;
1376 case Bset_buffer:
1377 BEFORE_POTENTIAL_GC ();
1378 TOP = Fset_buffer (TOP);
1379 AFTER_POTENTIAL_GC ();
1380 break;
1382 case Binteractive_p:
1383 PUSH (Finteractive_p ());
1384 break;
1386 case Bforward_char:
1387 BEFORE_POTENTIAL_GC ();
1388 TOP = Fforward_char (TOP);
1389 AFTER_POTENTIAL_GC ();
1390 break;
1392 case Bforward_word:
1393 BEFORE_POTENTIAL_GC ();
1394 TOP = Fforward_word (TOP);
1395 AFTER_POTENTIAL_GC ();
1396 break;
1398 case Bskip_chars_forward:
1400 Lisp_Object v1;
1401 BEFORE_POTENTIAL_GC ();
1402 v1 = POP;
1403 TOP = Fskip_chars_forward (TOP, v1);
1404 AFTER_POTENTIAL_GC ();
1405 break;
1408 case Bskip_chars_backward:
1410 Lisp_Object v1;
1411 BEFORE_POTENTIAL_GC ();
1412 v1 = POP;
1413 TOP = Fskip_chars_backward (TOP, v1);
1414 AFTER_POTENTIAL_GC ();
1415 break;
1418 case Bforward_line:
1419 BEFORE_POTENTIAL_GC ();
1420 TOP = Fforward_line (TOP);
1421 AFTER_POTENTIAL_GC ();
1422 break;
1424 case Bchar_syntax:
1425 BEFORE_POTENTIAL_GC ();
1426 CHECK_NUMBER (TOP);
1427 AFTER_POTENTIAL_GC ();
1428 XSETFASTINT (TOP, syntax_code_spec[(int) SYNTAX (XINT (TOP))]);
1429 break;
1431 case Bbuffer_substring:
1433 Lisp_Object v1;
1434 BEFORE_POTENTIAL_GC ();
1435 v1 = POP;
1436 TOP = Fbuffer_substring (TOP, v1);
1437 AFTER_POTENTIAL_GC ();
1438 break;
1441 case Bdelete_region:
1443 Lisp_Object v1;
1444 BEFORE_POTENTIAL_GC ();
1445 v1 = POP;
1446 TOP = Fdelete_region (TOP, v1);
1447 AFTER_POTENTIAL_GC ();
1448 break;
1451 case Bnarrow_to_region:
1453 Lisp_Object v1;
1454 BEFORE_POTENTIAL_GC ();
1455 v1 = POP;
1456 TOP = Fnarrow_to_region (TOP, v1);
1457 AFTER_POTENTIAL_GC ();
1458 break;
1461 case Bwiden:
1462 BEFORE_POTENTIAL_GC ();
1463 PUSH (Fwiden ());
1464 AFTER_POTENTIAL_GC ();
1465 break;
1467 case Bend_of_line:
1468 BEFORE_POTENTIAL_GC ();
1469 TOP = Fend_of_line (TOP);
1470 AFTER_POTENTIAL_GC ();
1471 break;
1473 case Bset_marker:
1475 Lisp_Object v1, v2;
1476 BEFORE_POTENTIAL_GC ();
1477 v1 = POP;
1478 v2 = POP;
1479 TOP = Fset_marker (TOP, v2, v1);
1480 AFTER_POTENTIAL_GC ();
1481 break;
1484 case Bmatch_beginning:
1485 BEFORE_POTENTIAL_GC ();
1486 TOP = Fmatch_beginning (TOP);
1487 AFTER_POTENTIAL_GC ();
1488 break;
1490 case Bmatch_end:
1491 BEFORE_POTENTIAL_GC ();
1492 TOP = Fmatch_end (TOP);
1493 AFTER_POTENTIAL_GC ();
1494 break;
1496 case Bupcase:
1497 BEFORE_POTENTIAL_GC ();
1498 TOP = Fupcase (TOP);
1499 AFTER_POTENTIAL_GC ();
1500 break;
1502 case Bdowncase:
1503 BEFORE_POTENTIAL_GC ();
1504 TOP = Fdowncase (TOP);
1505 AFTER_POTENTIAL_GC ();
1506 break;
1508 case Bstringeqlsign:
1510 Lisp_Object v1;
1511 BEFORE_POTENTIAL_GC ();
1512 v1 = POP;
1513 TOP = Fstring_equal (TOP, v1);
1514 AFTER_POTENTIAL_GC ();
1515 break;
1518 case Bstringlss:
1520 Lisp_Object v1;
1521 BEFORE_POTENTIAL_GC ();
1522 v1 = POP;
1523 TOP = Fstring_lessp (TOP, v1);
1524 AFTER_POTENTIAL_GC ();
1525 break;
1528 case Bequal:
1530 Lisp_Object v1;
1531 v1 = POP;
1532 TOP = Fequal (TOP, v1);
1533 break;
1536 case Bnthcdr:
1538 Lisp_Object v1;
1539 BEFORE_POTENTIAL_GC ();
1540 v1 = POP;
1541 TOP = Fnthcdr (TOP, v1);
1542 AFTER_POTENTIAL_GC ();
1543 break;
1546 case Belt:
1548 Lisp_Object v1, v2;
1549 if (CONSP (TOP))
1551 /* Exchange args and then do nth. */
1552 BEFORE_POTENTIAL_GC ();
1553 v2 = POP;
1554 v1 = TOP;
1555 CHECK_NUMBER (v2);
1556 AFTER_POTENTIAL_GC ();
1557 op = XINT (v2);
1558 immediate_quit = 1;
1559 while (--op >= 0)
1561 if (CONSP (v1))
1562 v1 = XCDR (v1);
1563 else if (!NILP (v1))
1565 immediate_quit = 0;
1566 wrong_type_argument (Qlistp, v1);
1569 immediate_quit = 0;
1570 if (CONSP (v1))
1571 TOP = XCAR (v1);
1572 else if (NILP (v1))
1573 TOP = Qnil;
1574 else
1575 wrong_type_argument (Qlistp, v1);
1577 else
1579 BEFORE_POTENTIAL_GC ();
1580 v1 = POP;
1581 TOP = Felt (TOP, v1);
1582 AFTER_POTENTIAL_GC ();
1584 break;
1587 case Bmember:
1589 Lisp_Object v1;
1590 BEFORE_POTENTIAL_GC ();
1591 v1 = POP;
1592 TOP = Fmember (TOP, v1);
1593 AFTER_POTENTIAL_GC ();
1594 break;
1597 case Bassq:
1599 Lisp_Object v1;
1600 BEFORE_POTENTIAL_GC ();
1601 v1 = POP;
1602 TOP = Fassq (TOP, v1);
1603 AFTER_POTENTIAL_GC ();
1604 break;
1607 case Bnreverse:
1608 BEFORE_POTENTIAL_GC ();
1609 TOP = Fnreverse (TOP);
1610 AFTER_POTENTIAL_GC ();
1611 break;
1613 case Bsetcar:
1615 Lisp_Object v1;
1616 BEFORE_POTENTIAL_GC ();
1617 v1 = POP;
1618 TOP = Fsetcar (TOP, v1);
1619 AFTER_POTENTIAL_GC ();
1620 break;
1623 case Bsetcdr:
1625 Lisp_Object v1;
1626 BEFORE_POTENTIAL_GC ();
1627 v1 = POP;
1628 TOP = Fsetcdr (TOP, v1);
1629 AFTER_POTENTIAL_GC ();
1630 break;
1633 case Bcar_safe:
1635 Lisp_Object v1;
1636 v1 = TOP;
1637 if (CONSP (v1))
1638 TOP = XCAR (v1);
1639 else
1640 TOP = Qnil;
1641 break;
1644 case Bcdr_safe:
1646 Lisp_Object v1;
1647 v1 = TOP;
1648 if (CONSP (v1))
1649 TOP = XCDR (v1);
1650 else
1651 TOP = Qnil;
1652 break;
1655 case Bnconc:
1656 BEFORE_POTENTIAL_GC ();
1657 DISCARD (1);
1658 TOP = Fnconc (2, &TOP);
1659 AFTER_POTENTIAL_GC ();
1660 break;
1662 case Bnumberp:
1663 TOP = (NUMBERP (TOP) ? Qt : Qnil);
1664 break;
1666 case Bintegerp:
1667 TOP = INTEGERP (TOP) ? Qt : Qnil;
1668 break;
1670 #ifdef BYTE_CODE_SAFE
1671 case Bset_mark:
1672 BEFORE_POTENTIAL_GC ();
1673 error ("set-mark is an obsolete bytecode");
1674 AFTER_POTENTIAL_GC ();
1675 break;
1676 case Bscan_buffer:
1677 BEFORE_POTENTIAL_GC ();
1678 error ("scan-buffer is an obsolete bytecode");
1679 AFTER_POTENTIAL_GC ();
1680 break;
1681 #endif
1683 case 0:
1684 abort ();
1686 case 255:
1687 default:
1688 #ifdef BYTE_CODE_SAFE
1689 if (op < Bconstant)
1691 abort ();
1693 if ((op -= Bconstant) >= const_length)
1695 abort ();
1697 PUSH (vectorp[op]);
1698 #else
1699 PUSH (vectorp[op - Bconstant]);
1700 #endif
1704 exit:
1706 byte_stack_list = byte_stack_list->next;
1708 /* Binds and unbinds are supposed to be compiled balanced. */
1709 if (SPECPDL_INDEX () != count)
1710 #ifdef BYTE_CODE_SAFE
1711 error ("binding stack not balanced (serious byte compiler bug)");
1712 #else
1713 abort ();
1714 #endif
1716 return result;
1719 void
1720 syms_of_bytecode ()
1722 Qbytecode = intern ("byte-code");
1723 staticpro (&Qbytecode);
1725 defsubr (&Sbyte_code);
1727 #ifdef BYTE_CODE_METER
1729 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter,
1730 doc: /* A vector of vectors which holds a histogram of byte-code usage.
1731 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
1732 opcode CODE has been executed.
1733 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
1734 indicates how many times the byte opcodes CODE1 and CODE2 have been
1735 executed in succession. */);
1737 DEFVAR_BOOL ("byte-metering-on", &byte_metering_on,
1738 doc: /* If non-nil, keep profiling information on byte code usage.
1739 The variable byte-code-meter indicates how often each byte opcode is used.
1740 If a symbol has a property named `byte-code-meter' whose value is an
1741 integer, it is incremented each time that symbol's function is called. */);
1743 byte_metering_on = 0;
1744 Vbyte_code_meter = Fmake_vector (make_number (256), make_number (0));
1745 Qbyte_code_meter = intern ("byte-code-meter");
1746 staticpro (&Qbyte_code_meter);
1748 int i = 256;
1749 while (i--)
1750 XVECTOR (Vbyte_code_meter)->contents[i] =
1751 Fmake_vector (make_number (256), make_number (0));
1753 #endif
1756 /* arch-tag: b9803b6f-1ed6-4190-8adf-33fd3a9d10e9
1757 (do not change this comment) */