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 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.
43 /* Define this to enable some minor sanity checking
44 (useful for debugging the byte compiler...)
46 #define BYTE_CODE_SAFE
48 /* Define this to enable generation of a histogram of byte-op usage.
50 #define BYTE_CODE_METER
53 #ifdef BYTE_CODE_METER
55 Lisp_Object Vbyte_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 /* no longer generated as of v19 */
112 #define Bfset 0115 /* no longer generated as of v19 */
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
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
165 #define Bconstant2 0201
167 #define Bgotoifnil 0203
168 #define Bgotoifnonnil 0204
169 #define Bgotoifnilelsepop 0205
170 #define Bgotoifnonnilelsepop 0206
172 #define Bdiscard 0210
175 #define Bsave_excursion 0212
176 #define Bsave_window_excursion 0213
177 #define Bsave_restriction 0214
180 #define Bunwind_protect 0216
181 #define Bcondition_case 0217
182 #define Btemp_output_buffer_setup 0220
183 #define Btemp_output_buffer_show 0221
185 #define Bunbind_all 0222
187 #define Bstringeqlsign 0230
188 #define Bstringlss 0231
194 #define Bnreverse 0237
197 #define Bcar_safe 0242
198 #define Bcdr_safe 0243
202 #define Bnumberp 0247
203 #define Bintegerp 0250
205 #define Bconstant 0300
206 #define CONSTANTLIM 0100
208 /* Fetch the next byte from the bytecode stream */
212 /* Fetch two bytes from the bytecode stream
213 and make a 16-bit number out of them */
215 #define FETCH2 (op = FETCH, op + (FETCH << 8))
217 /* Push x onto the execution stack. */
219 /* This used to be #define PUSH(x) (*++stackp = (x))
220 This oddity is necessary because Alliant can't be bothered to
221 compile the preincrement operator properly, as of 4/91. -JimB */
222 #define PUSH(x) (stackp++, *stackp = (x))
224 /* Pop a value off the execution stack. */
226 #define POP (*stackp--)
228 /* Discard n values from the execution stack. */
230 #define DISCARD(n) (stackp -= (n))
232 /* Get the value which is at the top of the execution stack, but don't pop it. */
234 #define TOP (*stackp)
236 DEFUN ("byte-code", Fbyte_code
, Sbyte_code
, 3, 3, 0,
237 "Function used internally in byte-compiled code.\n\
238 The first argument is a string of byte code; the second, a vector of constants;\n\
239 the third, the maximum stack depth used in this function.\n\
240 If the third argument is incorrect, Emacs may crash.")
241 (bytestr
, vector
, maxdepth
)
242 Lisp_Object bytestr
, vector
, maxdepth
;
244 struct gcpro gcpro1
, gcpro2
, gcpro3
;
245 int count
= specpdl_ptr
- specpdl
;
246 #ifdef BYTE_CODE_METER
253 register Lisp_Object
*stackp
;
255 register Lisp_Object v1
, v2
;
256 register Lisp_Object
*vectorp
= XVECTOR (vector
)->contents
;
257 #ifdef BYTE_CODE_SAFE
258 register int const_length
= XVECTOR (vector
)->size
;
260 /* Copy of BYTESTR, saved so we can tell if BYTESTR was relocated. */
261 Lisp_Object string_saved
;
262 /* Cached address of beginning of string,
263 valid if BYTESTR equals STRING_SAVED. */
264 register unsigned char *strbeg
;
266 CHECK_STRING (bytestr
, 0);
267 if (XTYPE (vector
) != Lisp_Vector
)
268 vector
= wrong_type_argument (Qvectorp
, vector
);
269 CHECK_NUMBER (maxdepth
, 2);
271 stackp
= (Lisp_Object
*) alloca (XFASTINT (maxdepth
) * sizeof (Lisp_Object
));
272 bzero (stackp
, XFASTINT (maxdepth
) * sizeof (Lisp_Object
));
273 GCPRO3 (bytestr
, vector
, *stackp
);
274 gcpro3
.nvars
= XFASTINT (maxdepth
);
278 stacke
= stackp
+ XFASTINT (maxdepth
);
280 /* Initialize the saved pc-pointer for fetching from the string. */
281 string_saved
= bytestr
;
282 pc
= XSTRING (string_saved
)->data
;
286 #ifdef BYTE_CODE_SAFE
289 "Stack overflow in byte code (byte compiler bug), pc = %d, depth = %d",
290 pc
- XSTRING (string_saved
)->data
, stacke
- stackp
);
292 error ("Stack underflow in byte code (byte compiler bug), pc = %d",
293 pc
- XSTRING (string_saved
)->data
);
296 if (string_saved
!= bytestr
)
298 pc
= pc
- XSTRING (string_saved
)->data
+ XSTRING (bytestr
)->data
;
299 string_saved
= bytestr
;
302 #ifdef BYTE_CODE_METER
304 this_op
= op
= FETCH
;
305 METER_CODE (prev_op
, op
);
319 case Bvarref
: case Bvarref
+1: case Bvarref
+2: case Bvarref
+3:
320 case Bvarref
+4: case Bvarref
+5:
324 if (XTYPE (v1
) != Lisp_Symbol
)
325 v2
= Fsymbol_value (v1
);
328 v2
= XSYMBOL (v1
)->value
;
329 #ifdef SWITCH_ENUM_BUG
330 switch ((int) XTYPE (v2
))
336 if (!EQ (v2
, Qunbound
))
341 case Lisp_Buffer_Local_Value
:
342 case Lisp_Some_Buffer_Local_Value
:
343 case Lisp_Buffer_Objfwd
:
345 v2
= Fsymbol_value (v1
);
359 case Bvarset
: case Bvarset
+1: case Bvarset
+2: case Bvarset
+3:
360 case Bvarset
+4: case Bvarset
+5:
363 Fset (vectorp
[op
], POP
);
374 case Bvarbind
: case Bvarbind
+1: case Bvarbind
+2: case Bvarbind
+3:
375 case Bvarbind
+4: case Bvarbind
+5:
378 specbind (vectorp
[op
], POP
);
389 case Bcall
: case Bcall
+1: case Bcall
+2: case Bcall
+3:
390 case Bcall
+4: case Bcall
+5:
394 TOP
= Ffuncall (op
+ 1, &TOP
);
405 case Bunbind
: case Bunbind
+1: case Bunbind
+2: case Bunbind
+3:
406 case Bunbind
+4: case Bunbind
+5:
409 unbind_to (specpdl_ptr
- specpdl
- op
, Qnil
);
413 /* To unbind back to the beginning of this frame. Not used yet,
414 but wil be needed for tail-recursion elimination.
416 unbind_to (count
, Qnil
);
421 op
= FETCH2
; /* pc = FETCH2 loses since FETCH2 contains pc++ */
422 pc
= XSTRING (string_saved
)->data
+ op
;
430 pc
= XSTRING (string_saved
)->data
+ op
;
439 pc
= XSTRING (string_saved
)->data
+ op
;
443 case Bgotoifnilelsepop
:
448 pc
= XSTRING (string_saved
)->data
+ op
;
453 case Bgotoifnonnilelsepop
:
458 pc
= XSTRING (string_saved
)->data
+ op
;
477 PUSH (vectorp
[FETCH2
]);
480 case Bsave_excursion
:
481 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
484 case Bsave_window_excursion
:
485 TOP
= Fsave_window_excursion (TOP
);
488 case Bsave_restriction
:
489 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
494 TOP
= internal_catch (TOP
, Feval
, v1
);
497 case Bunwind_protect
:
498 record_unwind_protect (0, POP
);
499 (specpdl_ptr
- 1)->symbol
= Qnil
;
502 case Bcondition_case
:
504 v1
= Fcons (POP
, v1
);
505 TOP
= Fcondition_case (Fcons (TOP
, v1
));
508 case Btemp_output_buffer_setup
:
509 temp_output_buffer_setup (XSTRING (TOP
)->data
);
510 TOP
= Vstandard_output
;
513 case Btemp_output_buffer_show
:
515 temp_output_buffer_show (TOP
, Qnil
);
517 /* pop binding of standard-output */
518 unbind_to (specpdl_ptr
- specpdl
- 1, Qnil
);
525 CHECK_NUMBER (v2
, 0);
531 v1
= XCONS (v1
)->cdr
;
535 v1
= wrong_type_argument (Qlistp
, v1
);
544 TOP
= XTYPE (TOP
) == Lisp_Symbol
? Qt
: Qnil
;
548 TOP
= CONSP (TOP
) ? Qt
: Qnil
;
552 TOP
= XTYPE (TOP
) == Lisp_String
? Qt
: Qnil
;
556 TOP
= CONSP (TOP
) || NULL (TOP
) ? Qt
: Qnil
;
561 TOP
= EQ (v1
, TOP
) ? Qt
: Qnil
;
566 TOP
= Fmemq (TOP
, v1
);
570 TOP
= NULL (TOP
) ? Qt
: Qnil
;
576 if (CONSP (v1
)) TOP
= XCONS (v1
)->car
;
577 else if (NULL (v1
)) TOP
= Qnil
;
578 else Fcar (wrong_type_argument (Qlistp
, v1
));
583 if (CONSP (v1
)) TOP
= XCONS (v1
)->cdr
;
584 else if (NULL (v1
)) TOP
= Qnil
;
585 else Fcdr (wrong_type_argument (Qlistp
, v1
));
590 TOP
= Fcons (TOP
, v1
);
594 TOP
= Fcons (TOP
, Qnil
);
599 TOP
= Fcons (TOP
, Fcons (v1
, Qnil
));
604 TOP
= Flist (3, &TOP
);
609 TOP
= Flist (4, &TOP
);
618 TOP
= Faref (TOP
, v1
);
623 TOP
= Faset (TOP
, v1
, v2
);
627 TOP
= Fsymbol_value (TOP
);
630 case Bsymbol_function
:
631 TOP
= Fsymbol_function (TOP
);
636 TOP
= Fset (TOP
, v1
);
641 TOP
= Ffset (TOP
, v1
);
646 TOP
= Fget (TOP
, v1
);
651 TOP
= Fsubstring (TOP
, v1
, v2
);
656 TOP
= Fconcat (2, &TOP
);
661 TOP
= Fconcat (3, &TOP
);
666 TOP
= Fconcat (4, &TOP
);
671 if (XTYPE (v1
) == Lisp_Int
)
673 XSETINT (v1
, XINT (v1
) - 1);
682 if (XTYPE (v1
) == Lisp_Int
)
684 XSETINT (v1
, XINT (v1
) + 1);
693 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v1
, 0);
694 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v2
, 0);
695 TOP
= (XFLOATINT (v1
) == XFLOATINT (v2
)) ? Qt
: Qnil
;
700 TOP
= Fgtr (TOP
, v1
);
705 TOP
= Flss (TOP
, v1
);
710 TOP
= Fleq (TOP
, v1
);
715 TOP
= Fgeq (TOP
, v1
);
720 TOP
= Fminus (2, &TOP
);
725 if (XTYPE (v1
) == Lisp_Int
)
727 XSETINT (v1
, - XINT (v1
));
731 TOP
= Fminus (1, &TOP
);
736 TOP
= Fplus (2, &TOP
);
741 TOP
= Fmax (2, &TOP
);
746 TOP
= Fmin (2, &TOP
);
751 TOP
= Ftimes (2, &TOP
);
756 TOP
= Fquo (2, &TOP
);
761 /* This had args in the wrong order. -- jwz */
762 TOP
= Frem (TOP
, v1
);
766 XFASTINT (v1
) = point
;
771 TOP
= Fgoto_char (TOP
);
775 TOP
= Finsert (1, &TOP
);
784 XFASTINT (v1
) = BEGV
;
789 TOP
= Fchar_after (TOP
);
792 case Bfollowing_char
:
793 XFASTINT (v1
) = PT
== ZV
? 0 : FETCH_CHAR (point
);
797 case Bpreceding_char
:
798 XFASTINT (v1
) = point
<= BEGV
? 0 : FETCH_CHAR (point
- 1);
802 case Bcurrent_column
:
803 XFASTINT (v1
) = current_column ();
808 TOP
= Findent_to (TOP
, Qnil
);
827 case Bcurrent_buffer
:
828 PUSH (Fcurrent_buffer ());
832 TOP
= Fset_buffer (TOP
);
836 PUSH (Fread_char ());
841 PUSH (Finteractive_p ());
845 /* This was wrong! --jwz */
846 TOP
= Fforward_char (TOP
);
850 /* This was wrong! --jwz */
851 TOP
= Fforward_word (TOP
);
854 case Bskip_chars_forward
:
855 /* This was wrong! --jwz */
857 TOP
= Fskip_chars_forward (TOP
, v1
);
860 case Bskip_chars_backward
:
861 /* This was wrong! --jwz */
863 TOP
= Fskip_chars_backward (TOP
, v1
);
867 /* This was wrong! --jwz */
868 TOP
= Fforward_line (TOP
);
872 CHECK_NUMBER (TOP
, 0);
873 XFASTINT (TOP
) = syntax_code_spec
[(int) SYNTAX (0xFF & XINT (TOP
))];
876 case Bbuffer_substring
:
878 TOP
= Fbuffer_substring (TOP
, v1
);
883 /* This had args in the wrong order. -- jwz */
884 TOP
= Fdelete_region (TOP
, v1
);
887 case Bnarrow_to_region
:
889 /* This had args in the wrong order. -- jwz */
890 TOP
= Fnarrow_to_region (TOP
, v1
);
899 /* This had args in the wrong order. -- jwz */
900 TOP
= Fstring_equal (TOP
, v1
);
905 /* This had args in the wrong order. -- jwz */
906 TOP
= Fstring_lessp (TOP
, v1
);
911 /* This had args in the wrong order. -- jwz */
912 TOP
= Fequal (TOP
, v1
);
917 /* This had args in the wrong order. -- jwz */
918 TOP
= Fnthcdr (TOP
, v1
);
922 if (XTYPE (TOP
) == Lisp_Cons
)
924 /* Exchange args and then do nth. */
930 TOP
= Felt (TOP
, v1
);
935 /* This had args in the wrong order. -- jwz */
936 TOP
= Fmember (TOP
, v1
);
941 /* This had args in the wrong order. -- jwz */
942 TOP
= Fassq (TOP
, v1
);
946 TOP
= Fnreverse (TOP
);
951 /* This had args in the wrong order. -- jwz */
952 TOP
= Fsetcar (TOP
, v1
);
957 /* This had args in the wrong order. -- jwz */
958 TOP
= Fsetcdr (TOP
, v1
);
963 if (XTYPE (v1
) == Lisp_Cons
)
964 TOP
= XCONS (v1
)->car
;
971 if (XTYPE (v1
) == Lisp_Cons
)
972 TOP
= XCONS (v1
)->cdr
;
979 TOP
= Fnconc (2, &TOP
);
983 TOP
= (XTYPE (TOP
) == Lisp_Int
|| XTYPE (TOP
) == Lisp_Float
988 TOP
= XTYPE (TOP
) == Lisp_Int
? Qt
: Qnil
;
991 #ifdef BYTE_CODE_SAFE
993 error ("set-mark is an obsolete bytecode");
996 error ("scan-buffer is an obsolete bytecode");
999 error("mark is an obsolete bytecode");
1004 #ifdef BYTE_CODE_SAFE
1006 error ("unknown bytecode %d (byte compiler bug)", op
);
1007 if ((op
-= Bconstant
) >= const_length
)
1008 error ("no constant number %d (byte compiler bug)", op
);
1011 PUSH (vectorp
[op
- Bconstant
]);
1018 /* Binds and unbinds are supposed to be compiled balanced. */
1019 if (specpdl_ptr
- specpdl
!= count
)
1020 #ifdef BYTE_CODE_SAFE
1021 error ("binding stack not balanced (serious byte compiler bug)");
1030 Qbytecode
= intern ("byte-code");
1031 staticpro (&Qbytecode
);
1033 defsubr (&Sbyte_code
);
1035 #ifdef BYTE_CODE_METER
1037 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter
,
1038 "a vector of vectors which holds a histogram of byte-code usage.");
1039 DEFVAR_BOOL ("byte-metering-on", &byte_metering_on
, "");
1041 byte_metering_on
= 0;
1042 Vbyte_code_meter
= Fmake_vector(make_number(256), make_number(0));
1047 XVECTOR(Vbyte_code_meter
)->contents
[i
] =
1048 Fmake_vector(make_number(256), make_number(0));