/* Execution of byte code produced by bytecomp.el.
- Copyright (C) 1985, 1986, 1987, 1988, 1992 Free Software Foundation, Inc.
+ Copyright (C) 1985, 1986, 1987, 1988, 1993 Free Software Foundation, Inc.
This file is part of GNU Emacs.
You should have received a copy of the GNU General Public License
along with GNU Emacs; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.
hacked on by jwz@lucid.com 17-jun-91
o added a compile-time switch to turn on simple sanity checking;
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 Bmult 0137
#define Bpoint 0140
-#define Bmark 0141 /* no longer generated as of v18 */
+/* Was Bmark in v17. */
+#define Bsave_current_buffer 0141
#define Bgoto_char 0142
#define Binsert 0143
#define Bpoint_max 0144
#define Bbobp 0157
#define Bcurrent_buffer 0160
#define Bset_buffer 0161
+#define Bsave_current_buffer_1 0162 /* Replacing Bsave_current_buffer. */
#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 TOP (*stackp)
+/* Garbage collect if we have consed enough since the last time.
+ We do this at every branch, to avoid loops that never GC. */
+
+#define MAYBE_GC() \
+ if (consing_since_gc > gc_cons_threshold) \
+ { \
+ Fgarbage_collect (); \
+ HANDLE_RELOCATION (); \
+ } \
+ else
+
+/* Relocate BYTESTR if there has been a GC recently. */
+#define HANDLE_RELOCATION() \
+ if (! EQ (string_saved, bytestr)) \
+ { \
+ pc = pc - XSTRING (string_saved)->data + XSTRING (bytestr)->data; \
+ string_saved = bytestr; \
+ } \
+ else
+
+/* Check for jumping out of range. */
+#define CHECK_RANGE(ARG) \
+ if (ARG >= bytestr_length) abort ()
+
DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0,
"Function used internally in byte-compiled code.\n\
-The first argument is a string of byte code; the second, a vector of constants;\n\
-the third, the maximum stack depth used in this function.\n\
+The first argument, BYTESTR, is a string of byte code;\n\
+the second, VECTOR, a vector of constants;\n\
+the third, MAXDEPTH, the maximum stack depth used in this function.\n\
If the third argument is incorrect, Emacs may crash.")
(bytestr, vector, maxdepth)
Lisp_Object bytestr, vector, maxdepth;
/* Cached address of beginning of string,
valid if BYTESTR equals STRING_SAVED. */
register unsigned char *strbeg;
+ int bytestr_length = STRING_BYTES (XSTRING (bytestr));
CHECK_STRING (bytestr, 0);
- if (XTYPE (vector) != Lisp_Vector)
+ if (!VECTORP (vector))
vector = wrong_type_argument (Qvectorp, vector);
CHECK_NUMBER (maxdepth, 2);
pc - XSTRING (string_saved)->data);
#endif
- if (! EQ (string_saved, bytestr))
- {
- pc = pc - XSTRING (string_saved)->data + XSTRING (bytestr)->data;
- string_saved = bytestr;
- }
+ /* Update BYTESTR if we had a garbage collection. */
+ HANDLE_RELOCATION ();
#ifdef BYTE_CODE_METER
prev_op = this_op;
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;
docall:
DISCARD (op);
#ifdef BYTE_CODE_METER
- if (byte_metering_on && XTYPE (TOP) == Lisp_Symbol)
+ if (byte_metering_on && SYMBOLP (TOP))
{
v1 = TOP;
v2 = Fget (v1, Qbyte_code_meter);
- if (XTYPE (v2) == Lisp_Int
+ if (INTEGERP (v2)
&& XINT (v2) != ((1<<VALBITS)-1))
{
XSETINT (v2, XINT (v2) + 1);
break;
case Bgoto:
+ MAYBE_GC ();
QUIT;
op = FETCH2; /* pc = FETCH2 loses since FETCH2 contains pc++ */
+ CHECK_RANGE (op);
pc = XSTRING (string_saved)->data + op;
break;
case Bgotoifnil:
+ MAYBE_GC ();
op = FETCH2;
if (NILP (POP))
{
QUIT;
+ CHECK_RANGE (op);
pc = XSTRING (string_saved)->data + op;
}
break;
case Bgotoifnonnil:
+ MAYBE_GC ();
op = FETCH2;
if (!NILP (POP))
{
QUIT;
+ CHECK_RANGE (op);
pc = XSTRING (string_saved)->data + op;
}
break;
case Bgotoifnilelsepop:
+ MAYBE_GC ();
op = FETCH2;
if (NILP (TOP))
{
QUIT;
+ CHECK_RANGE (op);
pc = XSTRING (string_saved)->data + op;
}
else DISCARD (1);
break;
case Bgotoifnonnilelsepop:
+ MAYBE_GC ();
op = FETCH2;
if (!NILP (TOP))
{
QUIT;
+ CHECK_RANGE (op);
pc = XSTRING (string_saved)->data + op;
}
else DISCARD (1);
break;
case BRgoto:
+ MAYBE_GC ();
QUIT;
- pc += *pc - 127;
+ pc += (int) *pc - 127;
break;
case BRgotoifnil:
+ MAYBE_GC ();
if (NILP (POP))
{
QUIT;
- pc += *pc - 128;
+ pc += (int) *pc - 128;
}
pc++;
break;
case BRgotoifnonnil:
+ MAYBE_GC ();
if (!NILP (POP))
{
QUIT;
- pc += *pc - 128;
+ pc += (int) *pc - 128;
}
pc++;
break;
case BRgotoifnilelsepop:
+ MAYBE_GC ();
op = *pc++;
if (NILP (TOP))
{
break;
case BRgotoifnonnilelsepop:
+ MAYBE_GC ();
op = *pc++;
if (!NILP (TOP))
{
record_unwind_protect (save_excursion_restore, save_excursion_save ());
break;
+ case Bsave_current_buffer:
+ case Bsave_current_buffer_1:
+ record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ());
+ break;
+
case Bsave_window_excursion:
TOP = Fsave_window_excursion (TOP);
break;
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:
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:
case Bnegate:
v1 = TOP;
- if (XTYPE (v1) == Lisp_Int)
+ if (INTEGERP (v1))
{
XSETINT (v1, - XINT (v1));
TOP = v1;
break;
case Bpoint:
- XFASTINT (v1) = point;
+ XSETFASTINT (v1, PT);
PUSH (v1);
break;
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;
TOP = Fset_buffer (TOP);
break;
- case Bread_char:
- PUSH (Fread_char ());
- QUIT;
- break;
-
case Binteractive_p:
PUSH (Finteractive_p ());
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:
break;
case Belt:
- if (XTYPE (TOP) == Lisp_Cons)
+ if (CONSP (TOP))
{
/* Exchange args and then do nth. */
v2 = POP;
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 Bintegerp:
- TOP = XTYPE (TOP) == Lisp_Int ? Qt : Qnil;
+ TOP = INTEGERP (TOP) ? Qt : Qnil;
break;
#ifdef BYTE_CODE_SAFE
return v1;
}
+void
syms_of_bytecode ()
{
Qbytecode = intern ("byte-code");
HCoop / bpt / emacs.git / blobdiff