/* Execution of byte code produced by bytecomp.el.
Copyright (C) 1985, 1986, 1987, 1988, 1993, 2000, 2001, 2002, 2003, 2004,
- 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+ 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
This file is part of GNU Emacs.
-GNU Emacs is free software; you can redistribute it and/or modify
+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 3, or (at your option)
-any later version.
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
GNU General Public License for more details.
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, Inc., 51 Franklin Street, Fifth Floor,
-Boston, MA 02110-1301, USA.
+along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
+/*
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;
*/
#include <config.h>
+#include <setjmp.h>
#include "lisp.h"
#include "buffer.h"
#include "character.h"
\f
Lisp_Object Qbytecode;
+extern Lisp_Object Qand_optional, Qand_rest;
/* Byte codes: */
+#define Bstack_ref 0
#define Bvarref 010
#define Bvarset 020
#define Bvarbind 030
#define BconcatN 0260
#define BinsertN 0261
+/* Bstack_ref is code 0. */
+#define Bstack_set 0262
+#define Bstack_set2 0263
+#define Bvec_ref 0264
+#define Bvec_set 0265
+#define BdiscardN 0266
+
#define Bconstant 0300
#define CONSTANTLIM 0100
/* Mark objects on byte_stack_list. Called during GC. */
void
-mark_byte_stack ()
+mark_byte_stack (void)
{
struct byte_stack *stack;
Lisp_Object *obj;
counters. Called when GC has completed. */
void
-unmark_byte_stack ()
+unmark_byte_stack (void)
{
struct byte_stack *stack;
Fsignal (Qquit, Qnil); \
AFTER_POTENTIAL_GC (); \
} \
+ ELSE_PENDING_SIGNALS \
} while (0)
-DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0,
+DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, MANY, 0,
doc: /* Function used internally in byte-compiled code.
The first argument, BYTESTR, is a string of byte code;
the second, VECTOR, a vector of constants;
the third, MAXDEPTH, the maximum stack depth used in this function.
-If the third argument is incorrect, Emacs may crash. */)
- (bytestr, vector, maxdepth)
- Lisp_Object bytestr, vector, maxdepth;
+If the third argument is incorrect, Emacs may crash.
+
+If ARGS-TEMPLATE is specified, it is an argument list specification,
+according to which any remaining arguments are pushed on the stack
+before executing BYTESTR.
+
+usage: (byte-code BYTESTR VECTOR MAXDEP &optional ARGS-TEMPLATE &rest ARGS) */)
+ (int nargs, Lisp_Object *args)
+{
+ Lisp_Object args_tmpl = nargs >= 4 ? args[3] : Qnil;
+ int pnargs = nargs >= 4 ? nargs - 4 : 0;
+ Lisp_Object *pargs = nargs >= 4 ? args + 4 : 0;
+ return exec_byte_code (args[0], args[1], args[2], args_tmpl, pnargs, pargs);
+}
+
+/* Execute the byte-code in BYTESTR. VECTOR is the constant vector, and
+ MAXDEPTH is the maximum stack depth used (if MAXDEPTH is incorrect,
+ emacs may crash!). If ARGS_TEMPLATE is non-nil, it should be a lisp
+ argument list (including &rest, &optional, etc.), and ARGS, of size
+ NARGS, should be a vector of the actual arguments. The arguments in
+ ARGS are pushed on the stack according to ARGS_TEMPLATE before
+ executing BYTESTR. */
+
+Lisp_Object
+exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
+ Lisp_Object args_template, int nargs, Lisp_Object *args)
{
int count = SPECPDL_INDEX ();
#ifdef BYTE_CODE_METER
Lisp_Object *top;
Lisp_Object result;
-#ifdef CHECK_FRAME_FONT
+#if 0 /* CHECK_FRAME_FONT */
{
struct frame *f = SELECTED_FRAME ();
if (FRAME_X_P (f)
stacke = stack.bottom - 1 + XFASTINT (maxdepth);
#endif
+ if (! NILP (args_template))
+ /* We should push some arguments on the stack. */
+ {
+ Lisp_Object at;
+ int pushed = 0, optional = 0;
+
+ for (at = args_template; CONSP (at); at = XCDR (at))
+ if (EQ (XCAR (at), Qand_optional))
+ optional = 1;
+ else if (EQ (XCAR (at), Qand_rest))
+ {
+ PUSH (Flist (nargs, args));
+ pushed = nargs;
+ at = Qnil;
+ break;
+ }
+ else if (pushed < nargs)
+ {
+ PUSH (*args++);
+ pushed++;
+ }
+ else if (optional)
+ PUSH (Qnil);
+ else
+ break;
+
+ if (pushed != nargs || !NILP (at))
+ Fsignal (Qwrong_number_of_arguments,
+ Fcons (args_template, Fcons (make_number (nargs), Qnil)));
+ }
+
while (1)
{
#ifdef BYTE_CODE_SAFE
v1 = vectorp[op];
if (SYMBOLP (v1))
{
- v2 = SYMBOL_VALUE (v1);
- if (MISCP (v2) || EQ (v2, Qunbound))
+ if (XSYMBOL (v1)->redirect != SYMBOL_PLAINVAL
+ || (v2 = SYMBOL_VAL (XSYMBOL (v1)),
+ EQ (v2, Qunbound)))
{
BEFORE_POTENTIAL_GC ();
v2 = Fsymbol_value (v1);
/* Inline the most common case. */
if (SYMBOLP (sym)
&& !EQ (val, Qunbound)
- && !XSYMBOL (sym)->indirect_variable
- && !SYMBOL_CONSTANT_P (sym)
- && !MISCP (XSYMBOL (sym)->value))
- XSYMBOL (sym)->value = val;
+ && !XSYMBOL (sym)->redirect
+ && !SYMBOL_CONSTANT_P (sym))
+ XSYMBOL (sym)->val.value = val;
else
{
BEFORE_POTENTIAL_GC ();
- set_internal (sym, val, current_buffer, 0);
+ set_internal (sym, val, Qnil, 0);
AFTER_POTENTIAL_GC ();
}
}
case Bsave_window_excursion:
BEFORE_POTENTIAL_GC ();
- TOP = Fsave_window_excursion (TOP);
+ TOP = Fsave_window_excursion (TOP); /* FIXME: lexbind */
AFTER_POTENTIAL_GC ();
break;
Lisp_Object v1;
BEFORE_POTENTIAL_GC ();
v1 = POP;
- TOP = internal_catch (TOP, Feval, v1);
+ TOP = internal_catch (TOP, eval_sub, v1); /* FIXME: lexbind */
AFTER_POTENTIAL_GC ();
break;
}
case Bunwind_protect:
- record_unwind_protect (Fprogn, POP);
+ record_unwind_protect (Fprogn, POP); /* FIXME: lexbind */
break;
case Bcondition_case:
handlers = POP;
body = POP;
BEFORE_POTENTIAL_GC ();
- TOP = internal_lisp_condition_case (TOP, body, handlers);
+ TOP = internal_lisp_condition_case (TOP, body, handlers); /* FIXME: lexbind */
AFTER_POTENTIAL_GC ();
break;
}
break;
#endif
- case 0:
- abort ();
+ /* Handy byte-codes for lexical binding. */
+ case Bstack_ref:
+ case Bstack_ref+1:
+ case Bstack_ref+2:
+ case Bstack_ref+3:
+ case Bstack_ref+4:
+ case Bstack_ref+5:
+ PUSH (stack.bottom[op - Bstack_ref]);
+ break;
+ case Bstack_ref+6:
+ PUSH (stack.bottom[FETCH]);
+ break;
+ case Bstack_ref+7:
+ PUSH (stack.bottom[FETCH2]);
+ break;
+ case Bstack_set:
+ stack.bottom[FETCH] = POP;
+ break;
+ case Bstack_set2:
+ stack.bottom[FETCH2] = POP;
+ break;
+ case Bvec_ref:
+ case Bvec_set:
+ /* These byte-codes used mostly for variable references to
+ lexically bound variables that are in an environment vector
+ instead of on the byte-interpreter stack (generally those
+ variables which might be shared with a closure). */
+ {
+ int index = FETCH;
+ Lisp_Object vec = POP;
+
+ if (! VECTORP (vec))
+ wrong_type_argument (Qvectorp, vec);
+ else if (index < 0 || index >= XVECTOR (vec)->size)
+ args_out_of_range (vec, make_number (index));
+
+ if (op == Bvec_ref)
+ PUSH (XVECTOR (vec)->contents[index]);
+ else
+ XVECTOR (vec)->contents[index] = POP;
+ }
+ break;
+ case BdiscardN:
+ op = FETCH;
+ if (op & 0x80)
+ {
+ op &= 0x7F;
+ top[-op] = TOP;
+ }
+ DISCARD (op);
+ break;
case 255:
default:
}
void
-syms_of_bytecode ()
+syms_of_bytecode (void)
{
- Qbytecode = intern ("byte-code");
+ Qbytecode = intern_c_string ("byte-code");
staticpro (&Qbytecode);
defsubr (&Sbyte_code);
byte_metering_on = 0;
Vbyte_code_meter = Fmake_vector (make_number (256), make_number (0));
- Qbyte_code_meter = intern ("byte-code-meter");
+ Qbyte_code_meter = intern_c_string ("byte-code-meter");
staticpro (&Qbyte_code_meter);
{
int i = 256;
HCoop / bpt / emacs.git / blobdiff