/* Execution of byte code produced by bytecomp.el.
- Copyright (C) 1985, 1986, 1987, 1988 Free Software Foundation, Inc.
+ Copyright (C) 1985, 1986, 1987, 1988, 1993 Free Software Foundation, Inc.
This file is part of GNU Emacs.
GNU Emacs is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 1, or (at your option)
+the Free Software Foundation; either version 2, or (at your option)
any later version.
GNU Emacs is distributed in the hope that it will be useful,
along with GNU Emacs; see the file COPYING. If not, write to
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-hacked on by jwz 17-jun-91
+hacked on by jwz@lucid.com 17-jun-91
o added a compile-time switch to turn on simple sanity checking;
o put back the obsolete byte-codes for error-detection;
- o put back fset, symbol-function, and read-char because I don't
- see any reason for them to have been removed;
o added a new instruction, unbind_all, which I will use for
tail-recursion elimination;
- o made temp_output_buffer_show() be called with the right number
+ o made temp_output_buffer_show be called with the right number
of args;
o made the new bytecodes be called with args in the right order;
o added metering support.
o all conditionals now only do QUIT if they jump.
*/
-
-#include "config.h"
+#include <config.h>
#include "lisp.h"
#include "buffer.h"
#include "syntax.h"
-/* Define this to enable some minor sanity checking
- (useful for debugging the byte compiler...)
- */
-#define BYTE_CODE_SAFE
-
-/* Define this to enable generation of a histogram of byte-op usage.
+/*
+ * define BYTE_CODE_SAFE to enable some minor sanity checking (useful for
+ * debugging the byte compiler...)
+ *
+ * define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
*/
-#define BYTE_CODE_METER
+/* #define BYTE_CODE_SAFE */
+/* #define BYTE_CODE_METER */
\f
#ifdef BYTE_CODE_METER
-Lisp_Object Vbyte_code_meter;
+Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
int byte_metering_on;
-# define METER_2(code1,code2) \
+#define METER_2(code1, code2) \
XFASTINT (XVECTOR (XVECTOR (Vbyte_code_meter)->contents[(code1)]) \
->contents[(code2)])
-# define METER_1(code) METER_2 (0,(code))
-
-# define METER_CODE(last_code, this_code) { \
- if (byte_metering_on) { \
- if (METER_1 (this_code) != ((1<<VALBITS)-1)) \
- METER_1 (this_code) ++; \
- if (last_code && \
- METER_2 (last_code,this_code) != ((1<<VALBITS)-1)) \
- METER_2 (last_code,this_code) ++; \
- } \
- }
+#define METER_1(code) METER_2 (0, (code))
+
+#define METER_CODE(last_code, this_code) \
+{ \
+ if (byte_metering_on) \
+ { \
+ if (METER_1 (this_code) != ((1<<VALBITS)-1)) \
+ METER_1 (this_code)++; \
+ if (last_code \
+ && METER_2 (last_code, this_code) != ((1<<VALBITS)-1))\
+ METER_2 (last_code, this_code)++; \
+ } \
+}
-#else /* ! BYTE_CODE_METER */
+#else /* no BYTE_CODE_METER */
-# define meter_code(last_code, this_code)
+#define METER_CODE(last_code, this_code)
-#endif
+#endif /* no BYTE_CODE_METER */
\f
Lisp_Object Qbytecode;
#define Baref 0110
#define Baset 0111
#define Bsymbol_value 0112
-#define Bsymbol_function 0113 /* no longer generated as of v19 */
+#define Bsymbol_function 0113
#define Bset 0114
-#define Bfset 0115 /* no longer generated as of v19 */
+#define Bfset 0115
#define Bget 0116
#define Bsubstring 0117
#define Bconcat2 0120
#define Bbobp 0157
#define Bcurrent_buffer 0160
#define Bset_buffer 0161
-#define Bread_char 0162
+#define Bread_char 0162 /* No longer generated as of v19 */
#define Bset_mark 0163 /* this loser is no longer generated as of v18 */
#define Binteractive_p 0164 /* Needed since interactive-p takes unevalled args */
#define Bdelete_region 0174
#define Bnarrow_to_region 0175
#define Bwiden 0176
+#define Bend_of_line 0177
#define Bconstant2 0201
#define Bgoto 0202
#define Bunbind_all 0222
+#define Bset_marker 0223
+#define Bmatch_beginning 0224
+#define Bmatch_end 0225
+#define Bupcase 0226
+#define Bdowncase 0227
+
#define Bstringeqlsign 0230
#define Bstringlss 0231
#define Bequal 0232
#define Bnumberp 0247
#define Bintegerp 0250
+#define BRgoto 0252
+#define BRgotoifnil 0253
+#define BRgotoifnonnil 0254
+#define BRgotoifnilelsepop 0255
+#define BRgotoifnonnilelsepop 0256
+
+#define BlistN 0257
+#define BconcatN 0260
+#define BinsertN 0261
+
#define Bconstant 0300
#define CONSTANTLIM 0100
\f
register unsigned char *strbeg;
CHECK_STRING (bytestr, 0);
- if (XTYPE (vector) != Lisp_Vector)
+ if (!VECTORP (vector))
vector = wrong_type_argument (Qvectorp, vector);
CHECK_NUMBER (maxdepth, 2);
{
#ifdef BYTE_CODE_SAFE
if (stackp > stacke)
- error (
- "Stack overflow in byte code (byte compiler bug), pc = %d, depth = %d",
+ error ("Byte code stack overflow (byte compiler bug), pc %d, depth %d",
pc - XSTRING (string_saved)->data, stacke - stackp);
if (stackp < stack)
- error ("Stack underflow in byte code (byte compiler bug), pc = %d",
+ error ("Byte code stack underflow (byte compiler bug), pc %d",
pc - XSTRING (string_saved)->data);
#endif
- if (string_saved != bytestr)
+ if (! EQ (string_saved, bytestr))
{
pc = pc - XSTRING (string_saved)->data + XSTRING (bytestr)->data;
string_saved = bytestr;
op = op - Bvarref;
varref:
v1 = vectorp[op];
- if (XTYPE (v1) != Lisp_Symbol)
+ if (!SYMBOLP (v1))
v2 = Fsymbol_value (v1);
else
{
v2 = XSYMBOL (v1)->value;
-#ifdef SWITCH_ENUM_BUG
- switch ((int) XTYPE (v2))
-#else
- switch (XTYPE (v2))
-#endif
- {
- case Lisp_Symbol:
- if (!EQ (v2, Qunbound))
- break;
- case Lisp_Intfwd:
- case Lisp_Boolfwd:
- case Lisp_Objfwd:
- case Lisp_Buffer_Local_Value:
- case Lisp_Some_Buffer_Local_Value:
- case Lisp_Buffer_Objfwd:
- case Lisp_Void:
- v2 = Fsymbol_value (v1);
- }
+ if (MISCP (v2) || EQ (v2, Qunbound))
+ v2 = Fsymbol_value (v1);
}
PUSH (v2);
break;
case Bcall+4: case Bcall+5:
op -= Bcall;
docall:
- DISCARD(op);
+ DISCARD (op);
+#ifdef BYTE_CODE_METER
+ if (byte_metering_on && SYMBOLP (TOP))
+ {
+ v1 = TOP;
+ v2 = Fget (v1, Qbyte_code_meter);
+ if (INTEGERP (v2)
+ && XINT (v2) != ((1<<VALBITS)-1))
+ {
+ XSETINT (v2, XINT (v2) + 1);
+ Fput (v1, Qbyte_code_meter, v2);
+ }
+ }
+#endif
TOP = Ffuncall (op + 1, &TOP);
break;
case Bunbind_all:
/* To unbind back to the beginning of this frame. Not used yet,
- but wil be needed for tail-recursion elimination.
- */
+ but will be needed for tail-recursion elimination. */
unbind_to (count, Qnil);
break;
case Bgotoifnil:
op = FETCH2;
- if (NULL (POP))
+ if (NILP (POP))
{
QUIT;
pc = XSTRING (string_saved)->data + op;
case Bgotoifnonnil:
op = FETCH2;
- if (!NULL (POP))
+ if (!NILP (POP))
{
QUIT;
pc = XSTRING (string_saved)->data + op;
case Bgotoifnilelsepop:
op = FETCH2;
- if (NULL (TOP))
+ if (NILP (TOP))
{
QUIT;
pc = XSTRING (string_saved)->data + op;
}
- else DISCARD(1);
+ else DISCARD (1);
break;
case Bgotoifnonnilelsepop:
op = FETCH2;
- if (!NULL (TOP))
+ if (!NILP (TOP))
{
QUIT;
pc = XSTRING (string_saved)->data + op;
}
- else DISCARD(1);
+ else DISCARD (1);
+ break;
+
+ case BRgoto:
+ QUIT;
+ pc += *pc - 127;
+ break;
+
+ case BRgotoifnil:
+ if (NILP (POP))
+ {
+ QUIT;
+ pc += *pc - 128;
+ }
+ pc++;
+ break;
+
+ case BRgotoifnonnil:
+ if (!NILP (POP))
+ {
+ QUIT;
+ pc += *pc - 128;
+ }
+ pc++;
+ break;
+
+ case BRgotoifnilelsepop:
+ op = *pc++;
+ if (NILP (TOP))
+ {
+ QUIT;
+ pc += op - 128;
+ }
+ else DISCARD (1);
+ break;
+
+ case BRgotoifnonnilelsepop:
+ op = *pc++;
+ if (!NILP (TOP))
+ {
+ QUIT;
+ pc += op - 128;
+ }
+ else DISCARD (1);
break;
case Breturn:
goto exit;
case Bdiscard:
- DISCARD(1);
+ DISCARD (1);
break;
case Bdup:
case Btemp_output_buffer_show:
v1 = POP;
- temp_output_buffer_show (TOP, Qnil);
+ temp_output_buffer_show (TOP);
TOP = v1;
/* pop binding of standard-output */
unbind_to (specpdl_ptr - specpdl - 1, Qnil);
{
if (CONSP (v1))
v1 = XCONS (v1)->cdr;
- else if (!NULL (v1))
+ else if (!NILP (v1))
{
immediate_quit = 0;
v1 = wrong_type_argument (Qlistp, v1);
goto docar;
case Bsymbolp:
- TOP = XTYPE (TOP) == Lisp_Symbol ? Qt : Qnil;
+ TOP = SYMBOLP (TOP) ? Qt : Qnil;
break;
case Bconsp:
break;
case Bstringp:
- TOP = XTYPE (TOP) == Lisp_String ? Qt : Qnil;
+ TOP = STRINGP (TOP) ? Qt : Qnil;
break;
case Blistp:
- TOP = CONSP (TOP) || NULL (TOP) ? Qt : Qnil;
+ TOP = CONSP (TOP) || NILP (TOP) ? Qt : Qnil;
break;
case Beq:
break;
case Bnot:
- TOP = NULL (TOP) ? Qt : Qnil;
+ TOP = NILP (TOP) ? Qt : Qnil;
break;
case Bcar:
v1 = TOP;
docar:
if (CONSP (v1)) TOP = XCONS (v1)->car;
- else if (NULL (v1)) TOP = Qnil;
+ else if (NILP (v1)) TOP = Qnil;
else Fcar (wrong_type_argument (Qlistp, v1));
break;
case Bcdr:
v1 = TOP;
if (CONSP (v1)) TOP = XCONS (v1)->cdr;
- else if (NULL (v1)) TOP = Qnil;
+ else if (NILP (v1)) TOP = Qnil;
else Fcdr (wrong_type_argument (Qlistp, v1));
break;
break;
case Blist3:
- DISCARD(2);
+ DISCARD (2);
TOP = Flist (3, &TOP);
break;
case Blist4:
- DISCARD(3);
+ DISCARD (3);
TOP = Flist (4, &TOP);
break;
+ case BlistN:
+ op = FETCH;
+ DISCARD (op - 1);
+ TOP = Flist (op, &TOP);
+ break;
+
case Blength:
TOP = Flength (TOP);
break;
break;
case Bconcat2:
- DISCARD(1);
+ DISCARD (1);
TOP = Fconcat (2, &TOP);
break;
case Bconcat3:
- DISCARD(2);
+ DISCARD (2);
TOP = Fconcat (3, &TOP);
break;
case Bconcat4:
- DISCARD(3);
+ DISCARD (3);
TOP = Fconcat (4, &TOP);
break;
+ case BconcatN:
+ op = FETCH;
+ DISCARD (op - 1);
+ TOP = Fconcat (op, &TOP);
+ break;
+
case Bsub1:
v1 = TOP;
- if (XTYPE (v1) == Lisp_Int)
+ if (INTEGERP (v1))
{
XSETINT (v1, XINT (v1) - 1);
TOP = v1;
case Badd1:
v1 = TOP;
- if (XTYPE (v1) == Lisp_Int)
+ if (INTEGERP (v1))
{
XSETINT (v1, XINT (v1) + 1);
TOP = v1;
v2 = POP; v1 = TOP;
CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v1, 0);
CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v2, 0);
- TOP = (XFLOATINT (v1) == XFLOATINT (v2)) ? Qt : Qnil;
+#ifdef LISP_FLOAT_TYPE
+ if (FLOATP (v1) || FLOATP (v2))
+ {
+ double f1, f2;
+
+ f1 = (FLOATP (v1) ? XFLOAT (v1)->data : XINT (v1));
+ f2 = (FLOATP (v2) ? XFLOAT (v2)->data : XINT (v2));
+ TOP = (f1 == f2 ? Qt : Qnil);
+ }
+ else
+#endif
+ TOP = (XINT (v1) == XINT (v2) ? Qt : Qnil);
break;
case Bgtr:
break;
case Bdiff:
- DISCARD(1);
+ DISCARD (1);
TOP = Fminus (2, &TOP);
break;
case Bnegate:
v1 = TOP;
- if (XTYPE (v1) == Lisp_Int)
+ if (INTEGERP (v1))
{
XSETINT (v1, - XINT (v1));
TOP = v1;
break;
case Bplus:
- DISCARD(1);
+ DISCARD (1);
TOP = Fplus (2, &TOP);
break;
case Bmax:
- DISCARD(1);
+ DISCARD (1);
TOP = Fmax (2, &TOP);
break;
case Bmin:
- DISCARD(1);
+ DISCARD (1);
TOP = Fmin (2, &TOP);
break;
case Bmult:
- DISCARD(1);
+ DISCARD (1);
TOP = Ftimes (2, &TOP);
break;
case Bquo:
- DISCARD(1);
+ DISCARD (1);
TOP = Fquo (2, &TOP);
break;
case Brem:
v1 = POP;
- /* This had args in the wrong order. -- jwz */
TOP = Frem (TOP, v1);
break;
case Bpoint:
- XFASTINT (v1) = point;
+ XSETFASTINT (v1, point);
PUSH (v1);
break;
TOP = Finsert (1, &TOP);
break;
+ case BinsertN:
+ op = FETCH;
+ DISCARD (op - 1);
+ TOP = Finsert (op, &TOP);
+ break;
+
case Bpoint_max:
- XFASTINT (v1) = ZV;
+ XSETFASTINT (v1, ZV);
PUSH (v1);
break;
case Bpoint_min:
- XFASTINT (v1) = BEGV;
+ XSETFASTINT (v1, BEGV);
PUSH (v1);
break;
break;
case Bfollowing_char:
- XFASTINT (v1) = PT == ZV ? 0 : FETCH_CHAR (point);
+ v1 = Ffollowing_char ();
PUSH (v1);
break;
case Bpreceding_char:
- XFASTINT (v1) = point <= BEGV ? 0 : FETCH_CHAR (point - 1);
+ v1 = Fprevious_char ();
PUSH (v1);
break;
case Bcurrent_column:
- XFASTINT (v1) = current_column ();
+ XSETFASTINT (v1, current_column ());
PUSH (v1);
break;
break;
case Bforward_char:
- /* This was wrong! --jwz */
TOP = Fforward_char (TOP);
break;
case Bforward_word:
- /* This was wrong! --jwz */
TOP = Fforward_word (TOP);
break;
case Bskip_chars_forward:
- /* This was wrong! --jwz */
v1 = POP;
TOP = Fskip_chars_forward (TOP, v1);
break;
case Bskip_chars_backward:
- /* This was wrong! --jwz */
v1 = POP;
TOP = Fskip_chars_backward (TOP, v1);
break;
case Bforward_line:
- /* This was wrong! --jwz */
TOP = Fforward_line (TOP);
break;
case Bchar_syntax:
CHECK_NUMBER (TOP, 0);
- XFASTINT (TOP) = syntax_code_spec[(int) SYNTAX (0xFF & XINT (TOP))];
+ XSETFASTINT (TOP,
+ syntax_code_spec[(int) SYNTAX (XINT (TOP))]);
break;
case Bbuffer_substring:
case Bdelete_region:
v1 = POP;
- /* This had args in the wrong order. -- jwz */
TOP = Fdelete_region (TOP, v1);
break;
case Bnarrow_to_region:
v1 = POP;
- /* This had args in the wrong order. -- jwz */
TOP = Fnarrow_to_region (TOP, v1);
break;
PUSH (Fwiden ());
break;
+ case Bend_of_line:
+ TOP = Fend_of_line (TOP);
+ break;
+
+ case Bset_marker:
+ v1 = POP;
+ v2 = POP;
+ TOP = Fset_marker (TOP, v2, v1);
+ break;
+
+ case Bmatch_beginning:
+ TOP = Fmatch_beginning (TOP);
+ break;
+
+ case Bmatch_end:
+ TOP = Fmatch_end (TOP);
+ break;
+
+ case Bupcase:
+ TOP = Fupcase (TOP);
+ break;
+
+ case Bdowncase:
+ TOP = Fdowncase (TOP);
+ break;
+
case Bstringeqlsign:
v1 = POP;
- /* This had args in the wrong order. -- jwz */
TOP = Fstring_equal (TOP, v1);
break;
case Bstringlss:
v1 = POP;
- /* This had args in the wrong order. -- jwz */
TOP = Fstring_lessp (TOP, v1);
break;
case Bequal:
v1 = POP;
- /* This had args in the wrong order. -- jwz */
TOP = Fequal (TOP, v1);
break;
case Bnthcdr:
v1 = POP;
- /* This had args in the wrong order. -- jwz */
TOP = Fnthcdr (TOP, v1);
break;
case Belt:
- if (XTYPE (TOP) == Lisp_Cons)
+ if (CONSP (TOP))
{
/* Exchange args and then do nth. */
v2 = POP;
case Bmember:
v1 = POP;
- /* This had args in the wrong order. -- jwz */
TOP = Fmember (TOP, v1);
break;
case Bassq:
v1 = POP;
- /* This had args in the wrong order. -- jwz */
TOP = Fassq (TOP, v1);
break;
case Bsetcar:
v1 = POP;
- /* This had args in the wrong order. -- jwz */
TOP = Fsetcar (TOP, v1);
break;
case Bsetcdr:
v1 = POP;
- /* This had args in the wrong order. -- jwz */
TOP = Fsetcdr (TOP, v1);
break;
case Bcar_safe:
v1 = TOP;
- if (XTYPE (v1) == Lisp_Cons)
+ if (CONSP (v1))
TOP = XCONS (v1)->car;
else
TOP = Qnil;
case Bcdr_safe:
v1 = TOP;
- if (XTYPE (v1) == Lisp_Cons)
+ if (CONSP (v1))
TOP = XCONS (v1)->cdr;
else
TOP = Qnil;
break;
case Bnconc:
- DISCARD(1);
+ DISCARD (1);
TOP = Fnconc (2, &TOP);
break;
case Bnumberp:
- TOP = (XTYPE (TOP) == Lisp_Int || XTYPE (TOP) == Lisp_Float
- ? Qt : Qnil);
+ TOP = (NUMBERP (TOP) ? Qt : Qnil);
break;
case Bintegerp:
- TOP = XTYPE (TOP) == Lisp_Int ? Qt : Qnil;
+ TOP = INTEGERP (TOP) ? Qt : Qnil;
break;
#ifdef BYTE_CODE_SAFE
error ("scan-buffer is an obsolete bytecode");
break;
case Bmark:
- error("mark is an obsolete bytecode");
+ error ("mark is an obsolete bytecode");
break;
#endif
#ifdef BYTE_CODE_METER
DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter,
- "a vector of vectors which holds a histogram of byte-code usage.");
- DEFVAR_BOOL ("byte-metering-on", &byte_metering_on, "");
+ "A vector of vectors which holds a histogram of byte-code usage.\n\
+(aref (aref byte-code-meter 0) CODE) indicates how many times the byte\n\
+opcode CODE has been executed.\n\
+(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,\n\
+indicates how many times the byte opcodes CODE1 and CODE2 have been\n\
+executed in succession.");
+ DEFVAR_BOOL ("byte-metering-on", &byte_metering_on,
+ "If non-nil, keep profiling information on byte code usage.\n\
+The variable byte-code-meter indicates how often each byte opcode is used.\n\
+If a symbol has a property named `byte-code-meter' whose value is an\n\
+integer, it is incremented each time that symbol's function is called.");
byte_metering_on = 0;
- Vbyte_code_meter = Fmake_vector(make_number(256), make_number(0));
-
+ Vbyte_code_meter = Fmake_vector (make_number (256), make_number (0));
+ Qbyte_code_meter = intern ("byte-code-meter");
+ staticpro (&Qbyte_code_meter);
{
int i = 256;
while (i--)
- XVECTOR(Vbyte_code_meter)->contents[i] =
- Fmake_vector(make_number(256), make_number(0));
+ XVECTOR (Vbyte_code_meter)->contents[i] =
+ Fmake_vector (make_number (256), make_number (0));
}
#endif
}
HCoop / bpt / emacs.git / blobdiff