+ case Bold_memq:
+ {
+ Lisp_Object arg = POP;
+ TOP = Fold_memq (TOP, arg);
+ break;
+ }
+
+ case Bold_equal:
+ {
+ Lisp_Object arg = POP;
+ TOP = Fold_equal (TOP, arg);
+ break;
+ }
+
+ case Bold_member:
+ {
+ Lisp_Object arg = POP;
+ TOP = Fold_member (TOP, arg);
+ break;
+ }
+
+ case Bold_assq:
+ {
+ Lisp_Object arg = POP;
+ TOP = Fold_assq (TOP, arg);
+ break;
+ }
+
+ default:
+ abort();
+ break;
+ }
+ return stack_ptr;
+}
+
+\f
+static void
+invalid_byte_code_error (char *error_message, ...)
+{
+ Lisp_Object obj;
+ va_list args;
+ char *buf = alloca_array (char, strlen (error_message) + 128);
+
+ sprintf (buf, "%s", error_message);
+ va_start (args, error_message);
+ obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (buf), Qnil, -1,
+ args);
+ va_end (args);
+
+ signal_error (Qinvalid_byte_code, list1 (obj));
+}
+
+/* Check for valid opcodes. Change this when adding new opcodes. */
+static void
+check_opcode (Opcode opcode)
+{
+ if ((opcode < Bvarref) ||
+ (opcode == 0251) ||
+ (opcode > Bassq && opcode < Bconstant))
+ invalid_byte_code_error
+ ("invalid opcode %d in instruction stream", opcode);
+}
+
+/* Check that IDX is a valid offset into the `constants' vector */
+static void
+check_constants_index (int idx, Lisp_Object constants)
+{
+ if (idx < 0 || idx >= XVECTOR_LENGTH (constants))
+ invalid_byte_code_error
+ ("reference %d to constants array out of range 0, %d",
+ idx, XVECTOR_LENGTH (constants) - 1);
+}
+
+/* Get next character from Lisp instructions string. */
+#define READ_INSTRUCTION_CHAR(lvalue) do { \
+ (lvalue) = charptr_emchar (ptr); \
+ INC_CHARPTR (ptr); \
+ *icounts_ptr++ = program_ptr - program; \
+ if (lvalue > UCHAR_MAX) \
+ invalid_byte_code_error \
+ ("Invalid character %c in byte code string"); \
+} while (0)
+
+/* Get opcode from Lisp instructions string. */
+#define READ_OPCODE do { \
+ unsigned int c; \
+ READ_INSTRUCTION_CHAR (c); \
+ opcode = (Opcode) c; \
+} while (0)
+
+/* Get next operand, a uint8, from Lisp instructions string. */
+#define READ_OPERAND_1 do { \
+ READ_INSTRUCTION_CHAR (arg); \
+ argsize = 1; \
+} while (0)
+
+/* Get next operand, a uint16, from Lisp instructions string. */
+#define READ_OPERAND_2 do { \
+ unsigned int arg1, arg2; \
+ READ_INSTRUCTION_CHAR (arg1); \
+ READ_INSTRUCTION_CHAR (arg2); \
+ arg = arg1 + (arg2 << 8); \
+ argsize = 2; \
+} while (0)
+
+/* Write 1 byte to PTR, incrementing PTR */
+#define WRITE_INT8(value, ptr) do { \
+ *((ptr)++) = (value); \
+} while (0)
+
+/* Write 2 bytes to PTR, incrementing PTR */
+#define WRITE_INT16(value, ptr) do { \
+ WRITE_INT8 (((unsigned) (value)) & 0x00ff, (ptr)); \
+ WRITE_INT8 (((unsigned) (value)) >> 8 , (ptr)); \
+} while (0)
+
+/* We've changed our minds about the opcode we've already written. */
+#define REWRITE_OPCODE(new_opcode) ((void) (program_ptr[-1] = new_opcode))
+
+/* Encode an op arg within the opcode, or as a 1 or 2-byte operand. */
+#define WRITE_NARGS(base_opcode) do { \
+ if (arg <= 5) \
+ { \
+ REWRITE_OPCODE (base_opcode + arg); \
+ } \
+ else if (arg <= UCHAR_MAX) \
+ { \
+ REWRITE_OPCODE (base_opcode + 6); \
+ WRITE_INT8 (arg, program_ptr); \
+ } \
+ else \
+ { \
+ REWRITE_OPCODE (base_opcode + 7); \
+ WRITE_INT16 (arg, program_ptr); \
+ } \
+} while (0)
+
+/* Encode a constants reference within the opcode, or as a 2-byte operand. */
+#define WRITE_CONSTANT do { \
+ check_constants_index(arg, constants); \
+ if (arg <= UCHAR_MAX - Bconstant) \
+ { \
+ REWRITE_OPCODE (Bconstant + arg); \
+ } \
+ else \
+ { \
+ REWRITE_OPCODE (Bconstant2); \
+ WRITE_INT16 (arg, program_ptr); \
+ } \
+} while (0)
+
+#define WRITE_OPCODE WRITE_INT8 (opcode, program_ptr)
+
+/* Compile byte code instructions into free space provided by caller, with
+ size >= (2 * string_char_length (instructions) + 1) * sizeof (Opbyte).
+ Returns length of compiled code. */
+static void
+optimize_byte_code (/* in */
+ Lisp_Object instructions,
+ Lisp_Object constants,
+ /* out */
+ 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 * icounts_ptr = icounts;
+
+ /* We maintain a table of jumps in the source code. */
+ struct jump
+ {
+ int from;
+ int to;
+ };
+ struct jump * const jumps = alloca_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;
+
+ *varbind_count = 0;
+
+ while (ptr < end)
+ {
+ Opcode opcode;
+ int arg;
+ int argsize = 0;
+ READ_OPCODE;
+ WRITE_OPCODE;
+
+ switch (opcode)
+ {
+ Lisp_Object val;
+
+ case Bvarref+7: READ_OPERAND_2; goto do_varref;
+ case Bvarref+6: READ_OPERAND_1; goto do_varref;
+ case Bvarref: case Bvarref+1: case Bvarref+2:
+ case Bvarref+3: case Bvarref+4: case Bvarref+5:
+ arg = opcode - Bvarref;
+ do_varref:
+ check_constants_index (arg, constants);
+ val = XVECTOR_DATA (constants) [arg];
+ if (!SYMBOLP (val))
+ invalid_byte_code_error ("variable reference to non-symbol %S", val);
+ if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
+ invalid_byte_code_error ("variable reference to constant symbol %s",
+ string_data (XSYMBOL (val)->name));
+ WRITE_NARGS (Bvarref);
+ break;
+
+ case Bvarset+7: READ_OPERAND_2; goto do_varset;
+ case Bvarset+6: READ_OPERAND_1; goto do_varset;
+ case Bvarset: case Bvarset+1: case Bvarset+2:
+ case Bvarset+3: case Bvarset+4: case Bvarset+5:
+ arg = opcode - Bvarset;
+ do_varset:
+ check_constants_index (arg, constants);
+ val = XVECTOR_DATA (constants) [arg];
+ if (!SYMBOLP (val))
+ invalid_byte_code_error ("attempt to set non-symbol %S", val);
+ if (EQ (val, Qnil) || EQ (val, Qt))
+ invalid_byte_code_error ("attempt to set constant symbol %s",
+ string_data (XSYMBOL (val)->name));
+ /* Ignore assignments to keywords by converting to Bdiscard.
+ For backward compatibility only - we'd like to make this an error. */
+ if (SYMBOL_IS_KEYWORD (val))
+ REWRITE_OPCODE (Bdiscard);
+ else
+ WRITE_NARGS (Bvarset);
+ break;
+
+ case Bvarbind+7: READ_OPERAND_2; goto do_varbind;
+ case Bvarbind+6: READ_OPERAND_1; goto do_varbind;
+ case Bvarbind: case Bvarbind+1: case Bvarbind+2:
+ case Bvarbind+3: case Bvarbind+4: case Bvarbind+5:
+ arg = opcode - Bvarbind;
+ do_varbind:
+ (*varbind_count)++;
+ check_constants_index (arg, constants);
+ val = XVECTOR_DATA (constants) [arg];
+ if (!SYMBOLP (val))
+ invalid_byte_code_error ("attempt to let-bind non-symbol %S", val);
+ if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
+ invalid_byte_code_error ("attempt to let-bind constant symbol %s",
+ string_data (XSYMBOL (val)->name));
+ WRITE_NARGS (Bvarbind);
+ break;
+
+ case Bcall+7: READ_OPERAND_2; goto do_call;
+ case Bcall+6: READ_OPERAND_1; goto do_call;
+ case Bcall: case Bcall+1: case Bcall+2:
+ case Bcall+3: case Bcall+4: case Bcall+5:
+ arg = opcode - Bcall;
+ do_call:
+ WRITE_NARGS (Bcall);
+ break;
+
+ case Bunbind+7: READ_OPERAND_2; goto do_unbind;
+ case Bunbind+6: READ_OPERAND_1; goto do_unbind;
+ case Bunbind: case Bunbind+1: case Bunbind+2:
+ case Bunbind+3: case Bunbind+4: case Bunbind+5:
+ arg = opcode - Bunbind;
+ do_unbind:
+ WRITE_NARGS (Bunbind);