1 /* Execution of byte code produced by bytecomp.el.
2 Copyright (C) 1985, 1986, 1987, 1988 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 1, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
20 hacked on by jwz@lucid.com 17-jun-91
21 o added a compile-time switch to turn on simple sanity checking;
22 o put back the obsolete byte-codes for error-detection;
23 o put back fset, symbol-function, and read-char because I don't
24 see any reason for them to have been removed;
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
29 o made the new bytecodes be called with args in the right order;
30 o added metering support.
33 o added relative jump instructions.
34 o all conditionals now only do QUIT if they jump.
44 * define BYTE_CODE_SAFE to enable some minor sanity checking (useful for
45 * debugging the byte compiler...)
47 * define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
49 #define BYTE_CODE_SAFE
50 #define BYTE_CODE_METER
53 #ifdef BYTE_CODE_METER
55 Lisp_Object Vbyte_code_meter
, Qbyte_code_meter
;
58 # define METER_2(code1,code2) \
59 XFASTINT (XVECTOR (XVECTOR (Vbyte_code_meter)->contents[(code1)]) \
62 # define METER_1(code) METER_2 (0,(code))
64 # define METER_CODE(last_code, this_code) { \
65 if (byte_metering_on) { \
66 if (METER_1 (this_code) != ((1<<VALBITS)-1)) \
67 METER_1 (this_code) ++; \
69 METER_2 (last_code,this_code) != ((1<<VALBITS)-1)) \
70 METER_2 (last_code,this_code) ++; \
74 #else /* ! BYTE_CODE_METER */
76 # define meter_code(last_code, this_code)
81 Lisp_Object Qbytecode
;
109 #define Bsymbol_value 0112
110 #define Bsymbol_function 0113
114 #define Bsubstring 0117
115 #define Bconcat2 0120
116 #define Bconcat3 0121
117 #define Bconcat4 0122
120 #define Beqlsign 0125
133 #define Bmark 0141 /* no longer generated as of v18 */
134 #define Bgoto_char 0142
136 #define Bpoint_max 0144
137 #define Bpoint_min 0145
138 #define Bchar_after 0146
139 #define Bfollowing_char 0147
140 #define Bpreceding_char 0150
141 #define Bcurrent_column 0151
142 #define Bindent_to 0152
143 #define Bscan_buffer 0153 /* No longer generated as of v18 */
148 #define Bcurrent_buffer 0160
149 #define Bset_buffer 0161
150 #define Bread_char 0162 /* No longer generated as of v19 */
151 #define Bset_mark 0163 /* this loser is no longer generated as of v18 */
152 #define Binteractive_p 0164 /* Needed since interactive-p takes unevalled args */
154 #define Bforward_char 0165
155 #define Bforward_word 0166
156 #define Bskip_chars_forward 0167
157 #define Bskip_chars_backward 0170
158 #define Bforward_line 0171
159 #define Bchar_syntax 0172
160 #define Bbuffer_substring 0173
161 #define Bdelete_region 0174
162 #define Bnarrow_to_region 0175
164 #define Bend_of_line 0177
166 #define Bconstant2 0201
168 #define Bgotoifnil 0203
169 #define Bgotoifnonnil 0204
170 #define Bgotoifnilelsepop 0205
171 #define Bgotoifnonnilelsepop 0206
173 #define Bdiscard 0210
176 #define Bsave_excursion 0212
177 #define Bsave_window_excursion 0213
178 #define Bsave_restriction 0214
181 #define Bunwind_protect 0216
182 #define Bcondition_case 0217
183 #define Btemp_output_buffer_setup 0220
184 #define Btemp_output_buffer_show 0221
186 #define Bunbind_all 0222
188 #define Bset_marker 0223
189 #define Bmatch_beginning 0224
190 #define Bmatch_end 0225
192 #define Bdowncase 0227
194 #define Bstringeqlsign 0230
195 #define Bstringlss 0231
201 #define Bnreverse 0237
204 #define Bcar_safe 0242
205 #define Bcdr_safe 0243
209 #define Bnumberp 0247
210 #define Bintegerp 0250
213 #define BRgotoifnil 0253
214 #define BRgotoifnonnil 0254
215 #define BRgotoifnilelsepop 0255
216 #define BRgotoifnonnilelsepop 0256
219 #define BconcatN 0260
221 #define Bconstant 0300
222 #define CONSTANTLIM 0100
224 /* Fetch the next byte from the bytecode stream */
228 /* Fetch two bytes from the bytecode stream
229 and make a 16-bit number out of them */
231 #define FETCH2 (op = FETCH, op + (FETCH << 8))
233 /* Push x onto the execution stack. */
235 /* This used to be #define PUSH(x) (*++stackp = (x))
236 This oddity is necessary because Alliant can't be bothered to
237 compile the preincrement operator properly, as of 4/91. -JimB */
238 #define PUSH(x) (stackp++, *stackp = (x))
240 /* Pop a value off the execution stack. */
242 #define POP (*stackp--)
244 /* Discard n values from the execution stack. */
246 #define DISCARD(n) (stackp -= (n))
248 /* Get the value which is at the top of the execution stack, but don't pop it. */
250 #define TOP (*stackp)
252 DEFUN ("byte-code", Fbyte_code
, Sbyte_code
, 3, 3, 0,
253 "Function used internally in byte-compiled code.\n\
254 The first argument is a string of byte code; the second, a vector of constants;\n\
255 the third, the maximum stack depth used in this function.\n\
256 If the third argument is incorrect, Emacs may crash.")
257 (bytestr
, vector
, maxdepth
)
258 Lisp_Object bytestr
, vector
, maxdepth
;
260 struct gcpro gcpro1
, gcpro2
, gcpro3
;
261 int count
= specpdl_ptr
- specpdl
;
262 #ifdef BYTE_CODE_METER
269 register Lisp_Object
*stackp
;
271 register Lisp_Object v1
, v2
;
272 register Lisp_Object
*vectorp
= XVECTOR (vector
)->contents
;
273 #ifdef BYTE_CODE_SAFE
274 register int const_length
= XVECTOR (vector
)->size
;
276 /* Copy of BYTESTR, saved so we can tell if BYTESTR was relocated. */
277 Lisp_Object string_saved
;
278 /* Cached address of beginning of string,
279 valid if BYTESTR equals STRING_SAVED. */
280 register unsigned char *strbeg
;
282 CHECK_STRING (bytestr
, 0);
283 if (XTYPE (vector
) != Lisp_Vector
)
284 vector
= wrong_type_argument (Qvectorp
, vector
);
285 CHECK_NUMBER (maxdepth
, 2);
287 stackp
= (Lisp_Object
*) alloca (XFASTINT (maxdepth
) * sizeof (Lisp_Object
));
288 bzero (stackp
, XFASTINT (maxdepth
) * sizeof (Lisp_Object
));
289 GCPRO3 (bytestr
, vector
, *stackp
);
290 gcpro3
.nvars
= XFASTINT (maxdepth
);
294 stacke
= stackp
+ XFASTINT (maxdepth
);
296 /* Initialize the saved pc-pointer for fetching from the string. */
297 string_saved
= bytestr
;
298 pc
= XSTRING (string_saved
)->data
;
302 #ifdef BYTE_CODE_SAFE
305 "Stack overflow in byte code (byte compiler bug), pc = %d, depth = %d",
306 pc
- XSTRING (string_saved
)->data
, stacke
- stackp
);
308 error ("Stack underflow in byte code (byte compiler bug), pc = %d",
309 pc
- XSTRING (string_saved
)->data
);
312 if (string_saved
!= bytestr
)
314 pc
= pc
- XSTRING (string_saved
)->data
+ XSTRING (bytestr
)->data
;
315 string_saved
= bytestr
;
318 #ifdef BYTE_CODE_METER
320 this_op
= op
= FETCH
;
321 METER_CODE (prev_op
, op
);
335 case Bvarref
: case Bvarref
+1: case Bvarref
+2: case Bvarref
+3:
336 case Bvarref
+4: case Bvarref
+5:
340 if (XTYPE (v1
) != Lisp_Symbol
)
341 v2
= Fsymbol_value (v1
);
344 v2
= XSYMBOL (v1
)->value
;
345 #ifdef SWITCH_ENUM_BUG
346 switch ((int) XTYPE (v2
))
352 if (!EQ (v2
, Qunbound
))
357 case Lisp_Buffer_Local_Value
:
358 case Lisp_Some_Buffer_Local_Value
:
359 case Lisp_Buffer_Objfwd
:
361 v2
= Fsymbol_value (v1
);
375 case Bvarset
: case Bvarset
+1: case Bvarset
+2: case Bvarset
+3:
376 case Bvarset
+4: case Bvarset
+5:
379 Fset (vectorp
[op
], POP
);
390 case Bvarbind
: case Bvarbind
+1: case Bvarbind
+2: case Bvarbind
+3:
391 case Bvarbind
+4: case Bvarbind
+5:
394 specbind (vectorp
[op
], POP
);
405 case Bcall
: case Bcall
+1: case Bcall
+2: case Bcall
+3:
406 case Bcall
+4: case Bcall
+5:
410 #ifdef BYTE_CODE_METER
411 if (byte_metering_on
&& XTYPE (TOP
) == Lisp_Symbol
)
414 v2
= Fget (v1
, Qbyte_code_meter
);
415 if (XTYPE (v2
) == Lisp_Int
)
417 XSETINT (v2
, XINT (v2
) + 1);
418 Fput (v1
, Qbyte_code_meter
, v2
);
422 TOP
= Ffuncall (op
+ 1, &TOP
);
433 case Bunbind
: case Bunbind
+1: case Bunbind
+2: case Bunbind
+3:
434 case Bunbind
+4: case Bunbind
+5:
437 unbind_to (specpdl_ptr
- specpdl
- op
, Qnil
);
441 /* To unbind back to the beginning of this frame. Not used yet,
442 but wil be needed for tail-recursion elimination.
444 unbind_to (count
, Qnil
);
449 op
= FETCH2
; /* pc = FETCH2 loses since FETCH2 contains pc++ */
450 pc
= XSTRING (string_saved
)->data
+ op
;
458 pc
= XSTRING (string_saved
)->data
+ op
;
467 pc
= XSTRING (string_saved
)->data
+ op
;
471 case Bgotoifnilelsepop
:
476 pc
= XSTRING (string_saved
)->data
+ op
;
481 case Bgotoifnonnilelsepop
:
486 pc
= XSTRING (string_saved
)->data
+ op
;
514 case BRgotoifnilelsepop
:
524 case BRgotoifnonnilelsepop
:
548 PUSH (vectorp
[FETCH2
]);
551 case Bsave_excursion
:
552 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
555 case Bsave_window_excursion
:
556 TOP
= Fsave_window_excursion (TOP
);
559 case Bsave_restriction
:
560 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
565 TOP
= internal_catch (TOP
, Feval
, v1
);
568 case Bunwind_protect
:
569 record_unwind_protect (0, POP
);
570 (specpdl_ptr
- 1)->symbol
= Qnil
;
573 case Bcondition_case
:
575 v1
= Fcons (POP
, v1
);
576 TOP
= Fcondition_case (Fcons (TOP
, v1
));
579 case Btemp_output_buffer_setup
:
580 temp_output_buffer_setup (XSTRING (TOP
)->data
);
581 TOP
= Vstandard_output
;
584 case Btemp_output_buffer_show
:
586 temp_output_buffer_show (TOP
, Qnil
);
588 /* pop binding of standard-output */
589 unbind_to (specpdl_ptr
- specpdl
- 1, Qnil
);
596 CHECK_NUMBER (v2
, 0);
602 v1
= XCONS (v1
)->cdr
;
606 v1
= wrong_type_argument (Qlistp
, v1
);
615 TOP
= XTYPE (TOP
) == Lisp_Symbol
? Qt
: Qnil
;
619 TOP
= CONSP (TOP
) ? Qt
: Qnil
;
623 TOP
= XTYPE (TOP
) == Lisp_String
? Qt
: Qnil
;
627 TOP
= CONSP (TOP
) || NULL (TOP
) ? Qt
: Qnil
;
632 TOP
= EQ (v1
, TOP
) ? Qt
: Qnil
;
637 TOP
= Fmemq (TOP
, v1
);
641 TOP
= NULL (TOP
) ? Qt
: Qnil
;
647 if (CONSP (v1
)) TOP
= XCONS (v1
)->car
;
648 else if (NULL (v1
)) TOP
= Qnil
;
649 else Fcar (wrong_type_argument (Qlistp
, v1
));
654 if (CONSP (v1
)) TOP
= XCONS (v1
)->cdr
;
655 else if (NULL (v1
)) TOP
= Qnil
;
656 else Fcdr (wrong_type_argument (Qlistp
, v1
));
661 TOP
= Fcons (TOP
, v1
);
665 TOP
= Fcons (TOP
, Qnil
);
670 TOP
= Fcons (TOP
, Fcons (v1
, Qnil
));
675 TOP
= Flist (3, &TOP
);
680 TOP
= Flist (4, &TOP
);
686 TOP
= Flist (op
, &TOP
);
695 TOP
= Faref (TOP
, v1
);
700 TOP
= Faset (TOP
, v1
, v2
);
704 TOP
= Fsymbol_value (TOP
);
707 case Bsymbol_function
:
708 TOP
= Fsymbol_function (TOP
);
713 TOP
= Fset (TOP
, v1
);
718 TOP
= Ffset (TOP
, v1
);
723 TOP
= Fget (TOP
, v1
);
728 TOP
= Fsubstring (TOP
, v1
, v2
);
733 TOP
= Fconcat (2, &TOP
);
738 TOP
= Fconcat (3, &TOP
);
743 TOP
= Fconcat (4, &TOP
);
749 TOP
= Fconcat (op
, &TOP
);
754 if (XTYPE (v1
) == Lisp_Int
)
756 XSETINT (v1
, XINT (v1
) - 1);
765 if (XTYPE (v1
) == Lisp_Int
)
767 XSETINT (v1
, XINT (v1
) + 1);
776 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v1
, 0);
777 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v2
, 0);
778 TOP
= (XFLOATINT (v1
) == XFLOATINT (v2
)) ? Qt
: Qnil
;
783 TOP
= Fgtr (TOP
, v1
);
788 TOP
= Flss (TOP
, v1
);
793 TOP
= Fleq (TOP
, v1
);
798 TOP
= Fgeq (TOP
, v1
);
803 TOP
= Fminus (2, &TOP
);
808 if (XTYPE (v1
) == Lisp_Int
)
810 XSETINT (v1
, - XINT (v1
));
814 TOP
= Fminus (1, &TOP
);
819 TOP
= Fplus (2, &TOP
);
824 TOP
= Fmax (2, &TOP
);
829 TOP
= Fmin (2, &TOP
);
834 TOP
= Ftimes (2, &TOP
);
839 TOP
= Fquo (2, &TOP
);
844 TOP
= Frem (TOP
, v1
);
848 XFASTINT (v1
) = point
;
853 TOP
= Fgoto_char (TOP
);
857 TOP
= Finsert (1, &TOP
);
866 XFASTINT (v1
) = BEGV
;
871 TOP
= Fchar_after (TOP
);
874 case Bfollowing_char
:
875 XFASTINT (v1
) = PT
== ZV
? 0 : FETCH_CHAR (point
);
879 case Bpreceding_char
:
880 XFASTINT (v1
) = point
<= BEGV
? 0 : FETCH_CHAR (point
- 1);
884 case Bcurrent_column
:
885 XFASTINT (v1
) = current_column ();
890 TOP
= Findent_to (TOP
, Qnil
);
909 case Bcurrent_buffer
:
910 PUSH (Fcurrent_buffer ());
914 TOP
= Fset_buffer (TOP
);
918 PUSH (Fread_char ());
923 PUSH (Finteractive_p ());
927 TOP
= Fforward_char (TOP
);
931 TOP
= Fforward_word (TOP
);
934 case Bskip_chars_forward
:
936 TOP
= Fskip_chars_forward (TOP
, v1
);
939 case Bskip_chars_backward
:
941 TOP
= Fskip_chars_backward (TOP
, v1
);
945 TOP
= Fforward_line (TOP
);
949 CHECK_NUMBER (TOP
, 0);
950 XFASTINT (TOP
) = syntax_code_spec
[(int) SYNTAX (0xFF & XINT (TOP
))];
953 case Bbuffer_substring
:
955 TOP
= Fbuffer_substring (TOP
, v1
);
960 TOP
= Fdelete_region (TOP
, v1
);
963 case Bnarrow_to_region
:
965 TOP
= Fnarrow_to_region (TOP
, v1
);
973 TOP
= Fend_of_line (TOP
);
979 TOP
= Fset_marker (TOP
, v2
, v1
);
982 case Bmatch_beginning
:
983 TOP
= Fmatch_beginning (TOP
);
987 TOP
= Fmatch_end (TOP
);
995 TOP
= Fdowncase (TOP
);
1000 TOP
= Fstring_equal (TOP
, v1
);
1005 TOP
= Fstring_lessp (TOP
, v1
);
1010 TOP
= Fequal (TOP
, v1
);
1015 TOP
= Fnthcdr (TOP
, v1
);
1019 if (XTYPE (TOP
) == Lisp_Cons
)
1021 /* Exchange args and then do nth. */
1027 TOP
= Felt (TOP
, v1
);
1032 TOP
= Fmember (TOP
, v1
);
1037 TOP
= Fassq (TOP
, v1
);
1041 TOP
= Fnreverse (TOP
);
1046 TOP
= Fsetcar (TOP
, v1
);
1051 TOP
= Fsetcdr (TOP
, v1
);
1056 if (XTYPE (v1
) == Lisp_Cons
)
1057 TOP
= XCONS (v1
)->car
;
1064 if (XTYPE (v1
) == Lisp_Cons
)
1065 TOP
= XCONS (v1
)->cdr
;
1072 TOP
= Fnconc (2, &TOP
);
1076 TOP
= (XTYPE (TOP
) == Lisp_Int
|| XTYPE (TOP
) == Lisp_Float
1081 TOP
= XTYPE (TOP
) == Lisp_Int
? Qt
: Qnil
;
1084 #ifdef BYTE_CODE_SAFE
1086 error ("set-mark is an obsolete bytecode");
1089 error ("scan-buffer is an obsolete bytecode");
1092 error("mark is an obsolete bytecode");
1097 #ifdef BYTE_CODE_SAFE
1099 error ("unknown bytecode %d (byte compiler bug)", op
);
1100 if ((op
-= Bconstant
) >= const_length
)
1101 error ("no constant number %d (byte compiler bug)", op
);
1104 PUSH (vectorp
[op
- Bconstant
]);
1111 /* Binds and unbinds are supposed to be compiled balanced. */
1112 if (specpdl_ptr
- specpdl
!= count
)
1113 #ifdef BYTE_CODE_SAFE
1114 error ("binding stack not balanced (serious byte compiler bug)");
1123 Qbytecode
= intern ("byte-code");
1124 staticpro (&Qbytecode
);
1126 defsubr (&Sbyte_code
);
1128 #ifdef BYTE_CODE_METER
1130 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter
,
1131 "a vector of vectors which holds a histogram of byte-code usage.");
1132 DEFVAR_BOOL ("byte-metering-on", &byte_metering_on
, "");
1134 byte_metering_on
= 0;
1135 Vbyte_code_meter
= Fmake_vector(make_number(256), make_number(0));
1136 staticpro (&Qbyte_code_meter
);
1140 XVECTOR(Vbyte_code_meter
)->contents
[i
] =
1141 Fmake_vector(make_number(256), make_number(0));