FSF: long ago.
-hacked on by jwz@netscape.com 1991-06
+hacked on by jwz@jwz.org 1991-06
o added a compile-time switch to turn on simple sanity checking;
o put back the obsolete byte-codes for error-detection;
o added a new instruction, unbind_all, which I will use for
#include "opaque.h"
#include "syntax.h"
-#include <limits.h>
-
EXFUN (Ffetch_bytecode, 1);
Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code;
typedef unsigned char Opbyte;
\f
+static void check_opcode (Opcode opcode);
static void invalid_byte_code_error (char *error_message, ...);
Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr,
- CONST Opbyte *program_ptr,
+ const Opbyte *program_ptr,
Opcode opcode);
-static Lisp_Object execute_optimized_program (CONST Opbyte *program,
+static Lisp_Object execute_optimized_program (const Opbyte *program,
int stack_depth,
Lisp_Object *constants_data);
Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
int byte_metering_on;
-#define METER_2(code1, code2) \
- XINT (XVECTOR_DATA (XVECTOR_DATA (Vbyte_code_meter)[(code1)])[(code2)])
-
-#define METER_1(code) METER_2 (0, (code))
-
-#define METER_CODE(last_code, this_code) do { \
- 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)++; \
- } \
-} while (0)
+static void
+meter_code (Opcode prev_opcode, Opcode this_opcode)
+{
+ if (byte_metering_on)
+ {
+ Lisp_Object *p = XVECTOR_DATA (XVECTOR_DATA (Vbyte_code_meter)[this_opcode]);
+ p[0] = INT_PLUS1 (p[0]);
+ if (prev_opcode)
+ p[prev_opcode] = INT_PLUS1 (p[prev_opcode]);
+ }
+}
#endif /* BYTE_CODE_METER */
{
retry:
+ if (INTP (obj)) return make_int (- XINT (obj));
#ifdef LISP_FLOAT_TYPE
if (FLOATP (obj)) return make_float (- XFLOAT_DATA (obj));
#endif
if (CHARP (obj)) return make_int (- ((int) XCHAR (obj)));
if (MARKERP (obj)) return make_int (- ((int) marker_position (obj)));
- if (INTP (obj)) return make_int (- XINT (obj));
obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
goto retry;
#ifdef LISP_FLOAT_TYPE
{
- int ival1, ival2;
+ EMACS_INT ival1, ival2;
if (INTP (obj1)) ival1 = XINT (obj1);
else if (CHARP (obj1)) ival1 = XCHAR (obj1);
}
#else /* !LISP_FLOAT_TYPE */
{
- int ival1, ival2;
+ EMACS_INT ival1, ival2;
if (INTP (obj1)) ival1 = XINT (obj1);
else if (CHARP (obj1)) ival1 = XCHAR (obj1);
bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode)
{
#ifdef LISP_FLOAT_TYPE
- int ival1, ival2;
+ EMACS_INT ival1, ival2;
int float_p;
retry:
return make_float (dval1);
}
#else /* !LISP_FLOAT_TYPE */
- int ival1, ival2;
+ EMACS_INT ival1, ival2;
retry:
funcall_compiled_function (Lisp_Object fun, int nargs, Lisp_Object args[])
{
/* This function can GC */
- Lisp_Object symbol, tail;
int speccount = specpdl_depth();
REGISTER int i = 0;
Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
and local variables of fun. So just reserve it once. */
SPECPDL_RESERVE (f->specpdl_depth);
- /* Fmake_byte_code() guaranteed that f->arglist is a valid list
- containing only non-constant symbols. */
- LIST_LOOP_3 (symbol, f->arglist, tail)
- {
- if (EQ (symbol, Qand_rest))
- {
- tail = XCDR (tail);
- symbol = XCAR (tail);
- SPECBIND_FAST_UNSAFE (symbol, Flist (nargs - i, &args[i]));
- goto run_code;
- }
- else if (EQ (symbol, Qand_optional))
- optional = 1;
- else if (i == nargs && !optional)
- goto wrong_number_of_arguments;
- else
- SPECBIND_FAST_UNSAFE (symbol, i < nargs ? args[i++] : Qnil);
- }
+ {
+ /* Fmake_byte_code() guaranteed that f->arglist is a valid list
+ containing only non-constant symbols. */
+ LIST_LOOP_3 (symbol, f->arglist, tail)
+ {
+ if (EQ (symbol, Qand_rest))
+ {
+ tail = XCDR (tail);
+ symbol = XCAR (tail);
+ SPECBIND_FAST_UNSAFE (symbol, Flist (nargs - i, &args[i]));
+ goto run_code;
+ }
+ else if (EQ (symbol, Qand_optional))
+ optional = 1;
+ else if (i == nargs && !optional)
+ goto wrong_number_of_arguments;
+ else
+ SPECBIND_FAST_UNSAFE (symbol, i < nargs ? args[i++] : Qnil);
+ }
+ }
if (i < nargs)
goto wrong_number_of_arguments;
}
wrong_number_of_arguments:
+ /* The actual printed compiled_function object is incomprehensible.
+ Check the backtrace to see if we can get a more meaningful symbol. */
+ if (EQ (fun, indirect_function (*backtrace_list->function, 0)))
+ fun = *backtrace_list->function;
return Fsignal (Qwrong_number_of_arguments, list2 (fun, make_int (nargs)));
}
static Lisp_Object
-execute_optimized_program (CONST Opbyte *program,
+execute_optimized_program (const Opbyte *program,
int stack_depth,
Lisp_Object *constants_data)
{
/* This function can GC */
- REGISTER CONST Opbyte *program_ptr = (Opbyte *) program;
+ REGISTER const Opbyte *program_ptr = (Opbyte *) program;
REGISTER Lisp_Object *stack_ptr
= alloca_array (Lisp_Object, stack_depth + 1);
int speccount = specpdl_depth ();
invalid_byte_code_error ("byte code stack overflow");
if (stack_ptr < stack_beg)
invalid_byte_code_error ("byte code stack underflow");
+ check_opcode (opcode);
#endif
#ifdef BYTE_CODE_METER
prev_opcode = this_opcode;
this_opcode = opcode;
- METER_CODE (prev_opcode, this_opcode);
+ meter_code (prev_opcode, this_opcode);
#endif
switch (opcode)
do_varset:
{
Lisp_Object symbol = constants_data[n];
- struct Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
+ Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
Lisp_Object old_value = symbol_ptr->value;
Lisp_Object new_value = POP;
if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
do_varbind:
{
Lisp_Object symbol = constants_data[n];
- struct Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
+ Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
Lisp_Object old_value = symbol_ptr->value;
Lisp_Object new_value = POP;
if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
opcode == Bunbind+6 ? READ_UINT_1 : READ_UINT_2));
break;
+
case Bgoto:
JUMP;
break;
}
case Bsub1:
- TOP = INTP (TOP) ? make_int (XINT (TOP) - 1) : Fsub1 (TOP);
+ TOP = INTP (TOP) ? INT_MINUS1 (TOP) : Fsub1 (TOP);
break;
case Badd1:
- TOP = INTP (TOP) ? make_int (XINT (TOP) + 1) : Fadd1 (TOP);
+ TOP = INTP (TOP) ? INT_PLUS1 (TOP) : Fadd1 (TOP);
break;
Lisp_Object arg2 = POP;
Lisp_Object arg1 = TOP;
TOP = INTP (arg1) && INTP (arg2) ?
- make_int (XINT (arg1) + XINT (arg2)) :
+ INT_PLUS (arg1, arg2) :
bytecode_arithop (arg1, arg2, opcode);
break;
}
Lisp_Object arg2 = POP;
Lisp_Object arg1 = TOP;
TOP = INTP (arg1) && INTP (arg2) ?
- make_int (XINT (arg1) - XINT (arg2)) :
+ INT_MINUS (arg1, arg2) :
bytecode_arithop (arg1, arg2, opcode);
break;
}
break;
}
-
case Bset:
{
Lisp_Object arg = POP;
Don't make this function static, since then the compiler might inline it. */
Lisp_Object *
execute_rare_opcode (Lisp_Object *stack_ptr,
- CONST Opbyte *program_ptr,
+ const Opbyte *program_ptr,
Opcode opcode)
{
switch (opcode)
}
default:
- abort();
+ ABORT();
break;
}
return stack_ptr;
sprintf (buf, "%s", error_message);
va_start (args, error_message);
- obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (buf), Qnil, -1,
+ obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (buf), Qnil, -1,
args);
va_end (args);
Lisp_Object instructions,
Lisp_Object constants,
/* out */
- Opbyte * CONST program,
- int * CONST program_length,
- int * CONST varbind_count)
+ Opbyte * const program,
+ int * const program_length,
+ int * const varbind_count)
{
size_t instructions_length = XSTRING_LENGTH (instructions);
size_t comfy_size = 2 * instructions_length;
- int * CONST icounts = alloca_array (int, comfy_size);
+ int * const icounts = alloca_array (int, comfy_size);
int * icounts_ptr = icounts;
/* We maintain a table of jumps in the source code. */
int from;
int to;
};
- struct jump * CONST jumps = alloca_array (struct jump, comfy_size);
+ struct jump * const jumps = xnew_array (struct jump, comfy_size);
struct jump *jumps_ptr = jumps;
Opbyte *program_ptr = program;
- CONST Bufbyte *ptr = XSTRING_DATA (instructions);
- CONST Bufbyte * CONST end = ptr + instructions_length;
+ const Bufbyte *ptr = XSTRING_DATA (instructions);
+ const Bufbyte * const end = ptr + instructions_length;
*varbind_count = 0;
break;
default:
- abort();
+ ABORT();
break;
}
}
/* *program_ptr++ = 0; */
*program_length = program_ptr - program;
+ xfree(jumps);
}
/* Optimize the byte code and store the optimized program, only
program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions));
optimize_byte_code (f->instructions, f->constants,
program, &program_length, &varbind_count);
- f->specpdl_depth = XINT (Flength (f->arglist)) + varbind_count;
+ f->specpdl_depth = (unsigned short) (XINT (Flength (f->arglist)) +
+ varbind_count);
f->instructions =
- Fpurecopy (make_opaque (program_length * sizeof (Opbyte),
- (CONST void *) program));
+ make_opaque (program, program_length * sizeof (Opbyte));
}
assert (OPAQUEP (f->instructions));
static Lisp_Object
-mark_compiled_function (Lisp_Object obj, void (*markobj) (Lisp_Object))
+mark_compiled_function (Lisp_Object obj)
{
Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
- markobj (f->instructions);
- markobj (f->arglist);
- markobj (f->doc_and_interactive);
+ mark_object (f->instructions);
+ mark_object (f->arglist);
+ mark_object (f->doc_and_interactive);
#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
- markobj (f->annotated);
+ mark_object (f->annotated);
#endif
/* tail-recurse on constants */
return f->constants;
}
static const struct lrecord_description compiled_function_description[] = {
- { XD_LISP_OBJECT, offsetof(struct Lisp_Compiled_Function, instructions), 4 },
+ { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, instructions) },
+ { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, constants) },
+ { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, arglist) },
+ { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, doc_and_interactive) },
#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
- { XD_LISP_OBJECT, offsetof(struct Lisp_Compiled_Function, annotated), 1 },
+ { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, annotated) },
#endif
{ XD_END }
};
/* Invert action performed by optimize_byte_code() */
Lisp_Opaque *opaque = XOPAQUE (f->instructions);
- Bufbyte * CONST buffer =
+ Bufbyte * const buffer =
alloca_array (Bufbyte, OPAQUE_SIZE (opaque) * MAX_EMCHAR_LEN);
Bufbyte *bp = buffer;
- CONST Opbyte * CONST program = (CONST Opbyte *) OPAQUE_DATA (opaque);
- CONST Opbyte *program_ptr = program;
- CONST Opbyte * CONST program_end = program_ptr + OPAQUE_SIZE (opaque);
+ const Opbyte * const program = (const Opbyte *) OPAQUE_DATA (opaque);
+ const Opbyte *program_ptr = program;
+ const Opbyte * const program_end = program_ptr + OPAQUE_SIZE (opaque);
while (program_ptr < program_end)
{
}
DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /*
-Return the max stack depth of the compiled-function object FUNCTION.
+Return the maximum stack depth of the compiled-function object FUNCTION.
*/
(function))
{
/* v18 or v19 bytecode file. Need to Ebolify. */
if (f->flags.ebolified && VECTORP (XCDR (tem)))
ebolify_bytecode_constants (XCDR (tem));
- /* VERY IMPORTANT to purecopy here!!!!!
- See load_force_doc_string_unwind. */
- f->instructions = Fpurecopy (XCAR (tem));
- f->constants = Fpurecopy (XCDR (tem));
+ f->instructions = XCAR (tem);
+ f->constants = XCDR (tem);
return function;
}
- abort ();
+ ABORT ();
return Qnil; /* not reached */
}
void
syms_of_bytecode (void)
{
- deferror (&Qinvalid_byte_code, "invalid-byte-code",
- "Invalid byte code", Qerror);
+ INIT_LRECORD_IMPLEMENTATION (compiled_function);
+
+ DEFERROR_STANDARD (Qinvalid_byte_code, Qinvalid_state);
defsymbol (&Qbyte_code, "byte-code");
defsymbol (&Qcompiled_functionp, "compiled-function-p");
projects / chise / xemacs-chise.git.1 / blobdiff