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 <stddef.h>
#include <limits.h>
EXFUN (Ffetch_bytecode, 1);
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:
}
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)));
}
#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)
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;
program, &program_length, &varbind_count);
f->specpdl_depth = XINT (Flength (f->arglist)) + varbind_count;
f->instructions =
- Fpurecopy (make_opaque (program_length * sizeof (Opbyte),
- (CONST void *) program));
+ make_opaque (program_length * sizeof (Opbyte),
+ (CONST void *) program);
}
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;
/* 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 ();