xref: /dports/games/ldmud/ldmud-3.3.720/src/interpret.c

/*---------------------------------------------------------------------------
 * Gamedriver: Bytecode Interpreter
 *
 *---------------------------------------------------------------------------
 * This module implements the bytecode interpreter for the compiled LPC
 * programs. The machine is implemented as a stackmachine with separate
 * stacks for values and control.
 *
 * See also 'exec.h' for the details of program storage, and 'svalue.h'
 * for the details of value storage.
 *
 * --- Evaluator Stack ---
 *
 *    The evaluation stack is an array of 'svalue_t's (see datatypes.h
 *    for information about this type) with EVALUATOR_SIZE<<1 elements.
 *    <inter_sp> resp. <sp> points to the last (that is topmost) valid
 *    entry in the stack, the framepointer <inter_fp> resp. <fp> points
 *    to the bottom of the frame of one function. Single values in the
 *    frame are then accessed by indexing the frame pointer.
 *    A typical stack layout looks like this:
 *
 *                    ^
 *    (inter_)sp   -> |  Top stack value
 *                    |  ...
 *                    |  Temporary stack values
 *                    |  Break addresses for switch instructions
 *    break_sp     -> |   (forming a sub-stack growing _down_).
 *                    |  ...
 *                    |  Local variable number 1
 *                    |  Local variable number 0
 *                    |  ...
 *                    |  Argument number 1
 *    (inter_)fp   -> |  Argument number 0
 *                    |
 *                    |
 *    VALUE_STACK     -----
 *
 *    The interpreter assumes that there are no destructed objects
 *    on the stack - to aid in this, the functions remove_object_from_stack()
 *    and (in array.c) check_for_destr() replace destructed objects by
 *    value 0.
 *
 *
#ifdef USE_NEW_INLINES
 * --- Context Variables ---
 *
 *    In order to implement 'real' inline closures, lfun closure carry with
 *    them a set of svalue_t's, called the 'context'. When such a closure
 *    is created, the context is filled with values from selected local
 *    function variables.
 *
 *    The interpreter keeps the pointer <inter_context> pointed to the
 *    currently value context, if there is one, or NULL if there is no
 *    context. The context variables are accessed with a set of instructions
 *    mirroring those to access object variables.
 *
 *    TODO: In fact, these contexts could be implemented as light-weight
 *    TODO:: objects, removing the need for special cases.
 *
 *
#endif
 * --- Control Stack ---
 *
 *    During nested function calls, the return information to the higher
 *    functions are stored on the control stack.
 *
 *    One particularity about the current implementation is that every
 *    inter-object call (ie. every 'extern_call') and every catch()
 *    constitutes in a recursive call to eval_instruction().
 *
 *
 * --- Error Recovery Stack --- (implemented in backend.c)
 *
 *    Error recovery in general is implemented using setjmp()/longjmp().
 *    The error recovery stack holds the (possibly nested) longjmp() contexts
 *    together with an indication where the jump will lead. Currently these
 *    context types are defined:
 *      ERROR_RECOVERY_NONE:     No error recovery available
 *                               (used by the top entry in the stack)
 *      ERROR_RECOVERY_BACKEND:  Errors fall back to the backend,
 *                               e.g. process_objects(), call_heart_beat()
 *                               and others.
 *      ERROR_RECOVERY_APPLY:    Errors fall back into the secure_apply()
 *                               function used for sensitive applies.
 *      ERROR_RECOVERY_CATCH:    Errors are caught by the catch() construct.
 *
 *    The _CATCH contexts differs from the others in that it allows the
 *    continuing execution after the error. In order to achieve this, the
 *    stack entry holds the necessary additional information to re-init
 *    the interpreter.
 *    TODO: Elaborate on the details.
 *
 *
 * --- Bytecode ---
 *
 *    The machine instructions are stored as unsigned characters and read
 *    sequentially. A single machine instruction consists of one or two
 *    bytes defining the instruction, optionally followed by more bytes
 *    with parameters (e.g. number of arguments on the stack, branch offsets,
 *    etc).
 *
 *    Apart from the usual machine instructions (branches, stack
 *    manipulation, summarily called 'codes'), the machine implements every
 *    efun by its own instruction code. Since this leads to more than
 *    256 instructions, the most of the efuns are encoded using prefix
 *    bytes. The unprefixed opcodes in the range 0..255 are used for the
 *    internal machine instructions and LPC operators, and for the small
 *    and/or often used efuns. The prefix byte for the other efun
 *    instructions reflects the type of the efun:
 *
 *      F_EFUN0: efuns taking no argument
 *      F_EFUN1: efuns taking one argument
 *      F_EFUN2: efuns taking two arguments
 *      F_EFUN3: efuns taking three arguments
 *      F_EFUN4: efuns taking four arguments
 *      F_EFUNV: efuns taking more than four or a variable number of arguments
 *
 *    The implementation is such that the unprefixed instructions are
 *    implemented directly in the interpreter loop in a big switch()
 *    statement, whereas the prefixed instructions are implemented
 *    in separate functions and called via the lookup tables efun_table[]
 *    and vefun_table[].
 *
 *    Every machine instruction, efun or else, is assigned a unique number
 *    and a preprocessor symbol F_<name>. The exact translation into
 *    the prefix/opcode bytecodes depends on the number of instructions
 *    in the various classes, but is linear and holds the following
 *    conditions:
 *
 *       - all non-efun instructions do not need a prefix byte and start
 *         at instruction code 0.
 *       - selected efuns also don't need a prefix byte and directly follow
 *         the non-efun instructions.
 *       - the instruction codes for all tabled efuns are consecutive.
 *       - the instruction codes for all tabled varargs efuns are consecutive.
 *
 *    All existing machine instructions are defined in the file func_spec,
 *    which during the compilation of the driver is evaluated by make_func.y
 *    to create the LPC compiler lang.y from prolang.y, the symbolic
 *    instruction names and numbers in instrs.h, and the definition of the
 *    tables efuns in efun_defs.c .
 *
 *
 * --- Calling Convention ---
 *
 *    All arguments for a function are evaluated and pushed to the value
 *    stack. The last argument is the last pushed. It is important that
 *    the called function gets exactly as many arguments as it wants; for
 *    LPC functions ('lfuns') this means that the actual function call will
 *    remove excessive arguments or push '0's for missing arguments. The
 *    number of arguments will be stored in the control stack, so that
 *    the return instruction not needs to know it explicitely.
 *
 *    If the function called is an lfun (inherited or not), the number
 *    of arguments passed to the call is encoded in the bytecode stream,
 *    and the number of arguments expected can be determined from the
 *    functions 'struct function' entry.
 *
 *    Efuns, operators and internal bytecode usually operate on a fixed
 *    number of arguments and the compiler makes sure that the right
 *    number is given. If an efun takes a variable number of arguments,
 *    the actual number is stored in the byte following the efun's opcode.
 *
 *    The called function must ensure that exactly one value remains on the
 *    stack when returning. The caller is responsible of deallocating the
 *    returned value. This includes 'void' lfuns, which just push the
 *    value 0 as return value.
 *
 *    When a LPC function returns, it will use the instruction F_RETURN, which
 *    will deallocate all arguments and local variables, and only let the
 *    top of stack entry remain. The number of arguments and local variables
 *    are stored in the control stack, so that the evaluator knows how much
 *    to deallocate.
 *
 *    If flag 'extern_call' is set, then the evaluator should return from
 *    eval_instruction(). Otherwise, the evaluator will continue to execute
 *    the instruction at the returned address. In the current implementation,
 *    every inter-object call (call_other) receives its own (recursive)
 *    call to eval_instruction().
 *
 *---------------------------------------------------------------------------
 * TODO: The virtual machine should be reconsidered, using the DGD and MudOS
 * TODO:: machines for inspiration. This applies to implementation as well
 * TODO:: as to the instruction set.
 * TODO: Let all assign_ and transfer_ functions check for destruct objects.
 * TODO:: The speed difference to assign_checked_ and transfer_checked_ is
 * TODO:: not big enough to justify the extra set of functions.
 */

/*-------------------------------------------------------------------------*/

#include "driver.h"
#include "typedefs.h"

#include "my-alloca.h"
#include <stdarg.h>
#include <stddef.h>
#include <stdio.h>
#include <setjmp.h>
#include <ctype.h>
#ifdef HAVE_SYS_TIME_H
#include <sys/time.h>
#endif
#include <time.h>
#include <sys/types.h>
#include <sys/stat.h>
#ifdef MARK
#include "profile.h"
#endif

#include "interpret.h"

#include "actions.h"
#include "array.h"
#include "backend.h"
#include "call_out.h"
#include "closure.h"
#include "comm.h"
#include "efuns.h"
#include "exec.h"
#include "filestat.h"
#include "gcollect.h"
#include "heartbeat.h"
#include "instrs.h"
#include "lex.h"
#include "mapping.h"
#include "mstrings.h"
#include "object.h"
#include "otable.h"
#include "parse.h"
#include "prolang.h"
#include "simulate.h"
#include "simul_efun.h"
#include "stdstrings.h"
#ifdef USE_STRUCTS
#include "structs.h"
#endif /* USE_STRUCTS */
#include "svalue.h"
#include "swap.h"
#include "switch.h"
#include "wiz_list.h"
#include "xalloc.h"

#include "i-eval_cost.h"

#include "../mudlib/sys/driver_hook.h"
#include "../mudlib/sys/debug_info.h"
#include "../mudlib/sys/trace.h"

/*-------------------------------------------------------------------------*/
/* Types */

/* --- struct catch_context: error_recovery subclass for catch() ---
 *
 * This extension of the struct error_recovery_info (see backend.h)
 * stores the additional information needed to reinitialize the global
 * variables when bailing out of a catch(). The type is always
 * ERROR_RECOVERY_CATCH.
 *
 * It is handled by the functions push_, pop_ and pull_error_context().
 */

struct catch_context
{
    struct error_recovery_info recovery_info;
      /* The subclassed recovery info.
       */
    struct control_stack * save_csp;
    object_t             * save_command_giver;
    svalue_t             * save_sp;
      /* The saved global values
       */

    svalue_t catch_value;
      /* Holds the value throw()n from within a catch() while the throw
       * is executed.
       */
};

/* --- struct cache: one entry of the apply cache
 *
 * Every entry in the apply cache holds information about a function
 * call, both for functions found and not found.
 */

struct cache
{
    string_t *name;
      /* The name of the cached function, shared for existing functions,
       * allocated if the object does not have the function.
       * This pointer counts as reference.
       */
    program_t *progp;
      /* The pointer to the program code of the function, or NULL if the
       * object does not implement the function.
       */
    int32 id;
      /* The id_number of the program. */

    funflag_t flags;
      /* Copy of the _MOD_STATIC and _MOD_PROTECTED flags of the function.
       */
    fun_hdr_p funstart;
      /* Pointer to the function.
       */
    int function_index_offset;
    int variable_index_offset;
      /* Function and variable index offset.
       */
};

/*-------------------------------------------------------------------------*/
/* Macros */

#define ERRORF(s) do{inter_pc = pc; inter_sp = sp; errorf s ;}while(0)
#define ERROR(s) ERRORF((s))
  /* ERRORF((...)) acts like errorf(...), except that first the local pc and sp
   * are copied into the global variables.
   * ERROR() is an easier to type form of ERRORF() when your error message
   * is just one string. It will be redefined below for the tabled
   * efuns.
   */

#define WARNF(s) do{inter_pc = pc; inter_sp = sp; warnf s ;}while(0)
#define WARN(s) WARNF((s))
#define FATALF(s) do{inter_pc = pc; inter_sp = sp; fatal s ;}while(0)
#define FATAL(s) FATALF((s))
  /* Analogue.
   */

#if APPLY_CACHE_BITS < 1
#    error APPLY_CACHE_BITS must be at least 1.
#else
#    define CACHE_SIZE (1 << APPLY_CACHE_BITS)
#endif
  /* Number of entries in the apply cache.
   */
#if CACHE_SIZE > INT_MAX
#error CACHE_SIZE is > INT_MAX.
#endif
  /* sanity check - some function rely that CACHE_SIZE fits into int */

/*-------------------------------------------------------------------------*/
/* Tracing */

#if TOTAL_TRACE_LENGTH > INT_MAX
#error TOTAL_TRACE_LENGTH is > INT_MAX.
#endif
/* sanity check - some function rely that TOTAL_TRACE_LENGTH fits into int */

int tracedepth;
  /* Current depth of traced functions.
   */

int trace_level;
  /* Current set of active trace options.
   * This set can be different from interactive->trace_level if several
   * nested trace() calls occur.
   */

static int traceing_recursion = -1;
  /* Kind of mutex, used to turn off tracing while doing trace output.
   * Necessary because output with add_message() might result result
   * in further code to be executed.
   */

static Bool trace_exec_active = MY_FALSE;
  /* TRUE whenever TRACE_EXEC is not just requested, but actually
   * active. This distinction is necessary as tracing might be limited
   * to one object only, and testing the object name for every instruction
   * would be too expensive. Hence, the tracing condition is checked
   * only on object changes and this variable is updated accordingly.
   * See macros SET_TRACE_EXEC and TRACE_EXEC_P.
   */

#ifdef TRACE_CODE
/* The buffers for the traced code:
 */

static int              previous_instruction[TOTAL_TRACE_LENGTH];
static ptrdiff_t        stack_size[TOTAL_TRACE_LENGTH];
static ptrdiff_t        abs_stack_size[TOTAL_TRACE_LENGTH];
static bytecode_p       previous_pc[TOTAL_TRACE_LENGTH];
static program_t * previous_programs[TOTAL_TRACE_LENGTH];
static object_t  * previous_objects[TOTAL_TRACE_LENGTH];
  /* These arrays, organized as ring buffers, hold the vitals of the
   * last TOTAL_TRACE_LENGTH instructions executed. Yet unused entries
   * are 0 resp. NULL.
   */

static int              last = TOTAL_TRACE_LENGTH - 1;
  /* Index to the last used entry in the ringbuffers above.
   */

#endif

/* --- Macros --- */

#define TRACE_IS_INTERACTIVE() (command_giver && O_IS_INTERACTIVE(command_giver))

  /* Return TRUE if the current command_giver is interactive.
   * TODO: Instead of disabling all traceoutput whenever the command_giver
   * TODO:: turns non-interactive, output should be redirected (with a
   * TODO:: special mark) to the current_interactive.
   */

#define TRACETST(b) (TRACE_IS_INTERACTIVE() && (O_GET_INTERACTIVE(command_giver)->trace_level & (b)))

  /* Return TRUE if the any of the tracing options <b> are requested
   * by the interactive user.
   */

#define TRACEP(b) (trace_level & (b) && trace_test(b))
  /* Return TRUE if tracing options <b> are both active in trace_level
   * and requested by the interactive user.
   */

#define TRACEHB \
  ( current_heart_beat == NULL || TRACETST(TRACE_HEART_BEAT))

  /* Return TRUE if either the current execution is not caused
   * by a heart beat call, or if heartbeat tracing is allowed.
   */

#define SET_TRACE_EXEC MACRO( \
                              if (trace_level & TRACE_EXEC) \
                                  trace_exec_active = MY_TRUE;\
                            )

  /* If TRACE_EXEC is requested, (re)activate it.
   * See trace_exec_active for the background.
   */

#define TRACE_EXEC_P (   TRACEP(TRACE_EXEC) \
                      || (trace_exec_active = MY_FALSE, MY_FALSE))

  /* If TRACE_EXEC is still requested, return TRUE, otherwise deactivate
   * it and return FALSE.
   * See trace_exec_active for the background.
   */

/*-------------------------------------------------------------------------*/
/* The names for the svalue types */

static const char * svalue_typename[]
 = { /* T_INVALID */  "invalid"
   , /* T_LVALUE  */  "lvalue"
   , /* T_NUMBER  */  "number"
   , /* T_STRING  */  "string"
   , /* T_POINTER */  "array"
   , /* T_OBJECT  */  "object"
   , /* T_MAPPING */  "mapping"
   , /* T_FLOAT   */  "float"
   , /* T_CLOSURE */  "closure"
   , /* T_SYMBOL  */  "symbol"
   , /* T_QUOTED_ARRAY */  "quoted-array"
   , /* T_STRUCT */  "struct"
   , /* T_CHAR_LVALUE */           "char-lvalue"
   , /* T_STRING_RANGE_LVALUE */   "string-range-lvalue"
   , /* T_POINTER_RANGE_LVALUE */  "array-range-lvalue"
   , /* T_PROTECTED_CHAR_LVALUE */           "prot-char-lvalue"
   , /* T_PROTECTED_STRING_RANGE_LVALUE */   "prot-string-range-lvalue"
   , /* T_PROTECTED_POINTER_RANGE_LVALUE */  "prot-array-range-lvalue"
   , /* T_PROTECTED_LVALUE  */               "prot-lvalue"
   , /* T_PROTECTOR_MAPPING  */              "protector-mapping"
   , /* T_CALLBACK */       "callback-mapping"
   , /* T_ERROR_HANDLER */  "error-handler"
   , /* T_NULL */  "null"
   };

/*-------------------------------------------------------------------------*/
/* Variables */

/* The virtual machine's registers.
 *
 * While the interpreter is in eval_instruction(), some of the values are
 * kept in local variables for greater speed, with the globals being updated
 * only when necessary.
 * The affected variables are: inter_pc, inter_sp, TODO: which else?
 */

svalue_t *inter_sp;
  /* Points to last valid value on the value stack.
   */
bytecode_p inter_pc;
  /* Next bytecode to interpret.
   */

static svalue_t *inter_fp;
  /* Framepointer: pointer to first argument.
   */

#ifdef USE_NEW_INLINES
static svalue_t *inter_context;
  /* Contextpointer: pointer to first context variable.
   * May be NULL if no context is available.
   */
#endif /* USE_NEW_INLINES */

static bytecode_p *break_sp;
  /* Points to address to branch to at next F_BREAK from within a switch().
   * This is actually a stack of addresses with break_sp pointing to the
   * bottom with the most recent entry. This break stack is stored on
   * the evaluator stack, one address per svalue_t (which incidentally
   * stored in the u.string field), between the functions temporary values
   * and its local variables.
   * TODO: Since this stores an opcode* in a svalue, it should get its
   * TODO:: own union type, and break_sp should be an svalue_t *.
   */

program_t *current_prog;
  /* The current program. This is usually current_object->prog, but can
   * differ when executing an inherited program.
   */

static svalue_t current_lambda;
  /* If the VM is executing a lambda, this variable holds a counted
   * reference to it to make sure that it isn't destructed while it is
   * still executing.
   */

static string_t **current_strings;
  /* Pointer to the string literal block of the current program for
   * faster access.
   */

int function_index_offset;
  /* Index of current program's function block within the functions of
   * the current objects program (needed for inheritance).
   */

static int variable_index_offset;
  /* Index of current program's variable block within the variables
   * of the current object (needed for inheritance).
   */

svalue_t *current_variables;
  /* Pointer to begin of the current variable block.
   * This is current_object->variables + variable_index_offset for
   * faster access.
   */


/* Other Variables */

int32 eval_cost;
  /* The amount of eval cost used in the current execution thread.
   */

int32 assigned_eval_cost;
  /* Auxiliary variable used to account eval costs to single objects and
   * their user's wizlist entry.
   * Whenver the execution thread enters a different object,
   * assigned_eval_cost is set to the current value of eval_cost. When the
   * thread leaves the object again, the difference between the actual
   * eval_cost value and the older assigned_eval_cost is accounted to
   * the current object.
   * The implementation combines both actions in one function
   * assign_eval_cost().
   */

svalue_t apply_return_value = { T_NUMBER };
  /* This variable holds the result from a call to apply(), transferred
   * properly from the interpreter stack where the called function
   * left it.
   * push_ and pop_apply_value() handle this particular transfer.
   * Note: The process_string() helper function process_value() takes
   * direct advantage of this variable.
   */

#define SIZEOF_STACK (EVALUATOR_STACK_SIZE<<1)
#if SIZEOF_STACK > INT_MAX
#error SIZEOF_STACK is > INT_MAX.
#endif
/* sanity check - some function rely that SIZEOF_STACK fits into int */

static svalue_t value_stack_array[SIZEOF_STACK+1];
#define VALUE_STACK (value_stack_array+1)

  /* The evaluator stack, sized with (hopefully) enough fudge to handle
   * function arguments and overflows.
   * The stack grows upwards, and <inter_sp> points to last valid entry.
   *
   * The first entry of value_stack_array[] is not used and serves as
   * dummy so that underflows can be detected in a portable way
   * (Standard C disallows indexing before an array). Instead, VALUE_STACK
   * is the real bottom of the stack.
   */

#if MAX_TRACE > INT_MAX
#error MAX_TRACE is > INT_MAX.
#endif
#if MAX_USER_TRACE >= MAX_TRACE
#error MAX_USER_TRACE value must be smaller than MAX_TRACE!
#endif
  /* Sanity check for the control stack definition.
   */

static struct control_stack control_stack_array[MAX_TRACE+2];
#define CONTROL_STACK (control_stack_array+2)
struct control_stack *csp;
  /* The control stack holds copies of the machine registers for previous
   * function call levels, with <csp> pointing to the last valid
   * entry, describing the last context.
   * This also means that CONTROL_STACK[0] (== control_stack_array[2]) will
   * have almost no interesting values as it will terminate execution.
   * Especially CONTROL_STACK[0].prog is NULL to mark the bottom.
   *
   * The first two entries of control_stack_array[] are not used and
   * serve as dummies so that underflows can be detected in a portable
   * way (Standard C disallows indexing before an array).
   */

static Bool runtime_no_warn_deprecated = MY_FALSE;
  /* Set to TRUE if the current instruction is not to warn about usage
   * of deprecated features; reset at the end of the instruction.
   * This flag is set by the NO_WARN_DEPRECATED instruction, generated
   * by the bytecode compiler in response to the warn-deprecated pragma.
   */

static Bool runtime_array_range_check = MY_FALSE;
  /* Set to TRUE if the current instruction is to warn about using
   * an illegal range.
   * This flag is set by the ARRAY_RANGE_CHECK instruction, generated
   * by the bytecode compiler in response to the range-check pragma.
   */

#ifdef APPLY_CACHE_STAT
p_uint apply_cache_hit  = 0;
p_uint apply_cache_miss = 0;
  /* Number of hits and misses in the apply cache.
   */
#endif

static struct cache cache[CACHE_SIZE];
  /* The apply cache.
   */

static struct
  {
    svalue_t v;
      /* The target value:
       *   .v.type: T_CHAR_LVALUE
       *   .v.u.charp: the char to modify
       * or
       *   .v.type: T_{POINTER,STRING}_RANGE_LVALUE
       *   .v.u.{vec,string}: the target value holding the range
       *   .index1, .index2, .size: see below
       */
    mp_int index1;  /* First index of the range */
    mp_int index2;  /* Last index of the range plus 1 */
    mp_int size;    /* Current(?) size of the value */
  }
special_lvalue;
  /* When assigning to vector and string ranges or elements, the
   * target information is stored in this structure.
   * TODO: Having one global structure counts as 'ugly'.
   * Used knowingly by: (r)index_lvalue(), transfer_pointer_range(),
   *                    assign_string_range().
   * Used unknowingly by: assign_svalue(), transfer_svalue(),
   *                    add_number_to_lvalue(), F_VOID_ASSIGN.
   */

static svalue_t indexing_quickfix = { T_NUMBER };
  /* When indexing arrays and mappings with just one ref, especially
   * for the purpose of getting a lvalue, the indexed item is copied
   * into this variable and indexed from here.
   * Used by operators: push_(r)indexed_lvalue, push_indexed_map_lvalue.
   * TODO: Rename this variable, or better: devise a nice solution.
   * TODO:: Use the protected_lvalues instead?
   * TODO:: To quote Marion:
   * TODO::     marion says: but this is crude too
   * TODO::     marion blushes.
   * TODO: Is it made sure that this var will be vacated before the
   * TODO:: next use? Otoh, if not it's no problem as the value is
   * TODO:: by definition volatile.
   */

svalue_t last_indexing_protector = { T_NUMBER };
  /* When indexing a protected non-string-lvalue, this variable receives
   * the protecting svalue for the duration of the operation (actually
   * until the next indexing operation (TODO: not nice)).
   * This is necessary because the indexing operation necessarily destroys
   * the protector structure, even though the protection is still needed.
   * Used by: protected_index_lvalue().
   */

#ifdef OPCPROF

#define MAXOPC (LAST_INSTRUCTION_CODE)
  /* Number of different instructions to trace.
   */

static int opcount[MAXOPC];
  /* Counter array for instruction profiling: each entry counts the
   * usages of one instruction. The full instruction code (not the
   * opcode) is used as index.
   */

#endif

#ifdef DEBUG

static program_t *check_a_lot_ref_counts_search_prog;
  /* Program you developer are especially interested in.
   */

static struct pointer_table *ptable;
  /* check_a_lot_of_ref_counts: the table of structures already
   * visited.
   */

#endif

p_uint eval_number;
  /* evaluation number. (may overflow)
   */

unsigned long total_evalcost;
static struct timeval eval_begin;
  /* Current total evalcost counter, and start of the evaluation.
   */

unsigned long last_total_evalcost = 0;
struct timeval last_eval_duration = { 0 };
  /* Last total evaluation cost and duration.
   */

statistic_t stat_total_evalcost = { 0 };
statistic_t stat_eval_duration = { 0 };
  /* Weighted statistics of evaluation cost and duration.
   */

/*-------------------------------------------------------------------------*/
/* Forward declarations */

enum { APPLY_NOT_FOUND = 0, APPLY_FOUND, APPLY_DEFAULT_FOUND };
static int int_apply(string_t *, object_t *, int, Bool, Bool);
static void call_simul_efun(unsigned int code, object_t *ob, int num_arg);
#ifdef DEBUG
static void check_extra_ref_in_vector(svalue_t *svp, size_t num);
#endif

/*-------------------------------------------------------------------------*/

/* Assign the evaluation cost elapsed since the last call to the
 * current_object and it's user's wizlist entry. Then set assigned_eval_cost
 * to the current eval_cost so that later calls can do the same.
 *
 * This function must be called at least whenever the execution leaves
 * one object for another one.
 *
 * assign_eval_cost_inl() is the inlinable version used here,
 * assign_eval_cost() is used by other compilation units.
 */

static INLINE void
assign_eval_cost_inl(void)
{
    unsigned long carry;
    if (current_object->user)
    {
        current_object->user->cost += eval_cost - assigned_eval_cost;
        carry = current_object->user->cost / 1000000000;
        if (carry)
        {
            current_object->user->gigacost += carry;
            current_object->user->cost %= 1000000000;
        }
        current_object->user->total_cost += eval_cost - assigned_eval_cost;
        carry = current_object->user->total_cost / 1000000000;
        if (carry)
        {
            current_object->user->total_gigacost += carry;
            current_object->user->total_cost %= 1000000000;
        }
    }
    current_object->ticks += eval_cost - assigned_eval_cost;
    {
        carry = current_object->ticks / 1000000000;
        if (carry)
        {
            current_object->gigaticks += carry;
            current_object->ticks %= 1000000000;
        }
    }
    assigned_eval_cost = eval_cost;
}

void assign_eval_cost(void) { assign_eval_cost_inl(); }

/*-------------------------------------------------------------------------*/
void
mark_start_evaluation (void)

/* Called before a new evaluation; resets the current evaluation statistics.
 */

{
    total_evalcost = 0;
    eval_number++;
    if (gettimeofday(&eval_begin, NULL))
    {
        eval_begin.tv_sec = eval_begin.tv_usec = 0;
    }
} /* mark_start_evaluation() */

/*-------------------------------------------------------------------------*/
void
mark_end_evaluation (void)

/* Called after an evaluation; updates the evaluation statistics.
 */

{
    if (total_evalcost == 0)
        return;

    last_total_evalcost = total_evalcost;

    if (eval_begin.tv_sec == 0
     || gettimeofday(&last_eval_duration, NULL))
    {
        last_eval_duration.tv_sec = last_eval_duration.tv_usec = 0;
    }
    else
    {
        last_eval_duration.tv_sec -= eval_begin.tv_sec;
        last_eval_duration.tv_usec -= eval_begin.tv_usec;

        if (last_eval_duration.tv_usec < 0)
        {
            last_eval_duration.tv_sec--;
            last_eval_duration.tv_usec += 1000000;
        }

        update_statistic_avg( &stat_eval_duration
                            , last_eval_duration.tv_sec * 1000000L
                              + last_eval_duration.tv_usec
                            );
    }

    update_statistic_avg(&stat_total_evalcost, last_total_evalcost);
} /* mark_end_evaluation() */

/*-------------------------------------------------------------------------*/
void
init_interpret (void)

/* Initialize the interpreter data structures, especially the apply cache.
 */

{
    struct cache invalid_entry;
    int i;

    /* The cache is inited to hold entries for 'functions' in a non-existing
     * program (id 0). The first real apply calls will thus see a (virtual)
     * collision with 'older' cache entries.
     */

    invalid_entry.id = 0;
    invalid_entry.progp = (program_t *)1;
    invalid_entry.name = NULL;

    /* To silence the compiler: */
    invalid_entry.variable_index_offset = 0;
    invalid_entry.function_index_offset = 0;
    invalid_entry.funstart = 0;
    invalid_entry.flags = 0;

    for (i = 0; i < CACHE_SIZE; i++)
        cache[i] = invalid_entry;
} /* init_interpret()*/

/*-------------------------------------------------------------------------*/
static INLINE Bool
is_sto_context (void)

/* Return TRUE if the current call context has a set_this_object()
 * in effect.
 */

{
    struct control_stack *p;

    for (p = csp; !p->extern_call; p--) NOOP;

    return (p->extern_call & CS_PRETEND) != 0;
} /* is_sto_context() */

/*=========================================================================*/

/*                         S V A L U E S                                   */

/*-------------------------------------------------------------------------*/
/* The following functions handle svalues, ie. the data referenced
 * by the svalue_ts. 'Freeing' in this context therefore never means
 * a svalue_t, only the data referenced by it.
 *
 * destructed_object_ref(v): test if <v> references a destructed object.
 * object_ref(v,o):          test if <v> references object <o>
 * free_string_svalue(v): free string svalue <v>.
 * free_object_svalue(v): free object svalue <v>.
 * zero_object_svalue(v): replace the object in svalue <v> by number 0.
 * free_svalue(v):        free the svalue <v>.
 * assign_svalue_no_free(to,from): put a copy of <from> into <to>; <to>
 *                        is considered empty.
 * copy_svalue_no_free(to,from): put a shallow value copy of <from> into <to>;
 *                        <to> is considered empty.
 * assign_checked_svalue_no_free(to,from): put a copy of <from> into <to>;
 *                        <to> is considered empty, <from> may be destructed
 *                        object.
 * assign_local_svalue_no_free(to,from): put a copy of local var <from>
 *                        into <to>; <to> is considered empty, <from> may
 *                        be destructed object.
 * static assign_lrvalue_no_free(to,from): like assign_svalue_no_free(),
 *                        but lvalues and strings are handled differently.
 * assign_svalue(dest,v): assign <v> to <dest>, freeing <dest> first.
 *                        Also handles assigns to lvalues.
 * transfer_svalue_no_free(dest,v): move <v> into <dest>; <dest> is
 *                        considered empty.
 * transfer_svalue(dest,v): move <v> into <dest>; freeing <dest> first.
 *                        Also handles transfers to lvalues.
 * static add_number_to_lvalue(dest,i,pre,post): add <i> to lvalue <dest>.
 *
 * In addition there are some helper functions.
 *
 * TODO: All these functions and vars should go into a separate module.
 */

/*-------------------------------------------------------------------------*/

/* --- Protector structures ---
 *
 * Whenever an assignment is made to a single value, or to a range in
 * a string, vector or mapping, the interpreter generates protector
 * structures in place of the usual LVALUE-svalues, which hold:
 *  - a svalue structure referring to the svalue into which the assignment
 *    is done (this structure is always first so that the protector
 *    structures can be used instead of normal svalues),
 *  - the necessary information to store the assigned svalue into its
 *    place in the target holding the value,
 *  - a protective reference to the holding value.
 *
 * All this just to keep LPC statements like 'a = ({ 1 }); a[0] = (a = 0);'
 * from crashing.
 *
 * TODO: A simpler way would be to compute the lhs of an assignment
 * TODO:: after evaluating the rhs - not vice versa as it is now.
 * TODO:: However, passing lvalues and ranges as ref-parameters to functions
 * TODO:: would still be a potential problem.
 */

/* --- struct protected_lvalue: protect a single value
 */
struct protected_lvalue
{
    svalue_t v;
      /* .v.type: T_PROTECTED_LVALUE
       * .v.u.lvalue: the protected value
       */
    svalue_t protector;
      /* additional reference .v.u.lvalue (or its holder) as means of
       * protection
       */
};

/* --- struct protected_char_lvalue: protect a char in a string
 */
struct protected_char_lvalue
{
    svalue_t v;
      /* .v.type: T_PROTECTED_CHAR_LVALUE
       * .v.u.charp: points to the char to access
       */
    svalue_t protector; /* protects .lvalue */
    svalue_t *lvalue;   /* the string containing the char */
    char *start;
      /* must be == get_txt(lvalue->u.str), otherwise the string has been
       * changed and this lvalue is invalid
       */
};

/* --- struct protected_range_lvalue: protect a range in a string or vector
 */
struct protected_range_lvalue {
    svalue_t v;
      /* .v.type: T_PROTECTED_{POINTER,STRING}_RANGE_LVALUE
       * .v.u.{str,vec}: the target value holding the range
       */
    svalue_t protector;  /* protects .lvalue */
    svalue_t *lvalue;    /* the original svalue holding the range */
    int index1, index2;  /* first and last index of the range in .lvalue */
    int size;            /* original size of .lvalue */

    /* On creation, .v.u.{vec,str} == .lvalue->u.{vec,str}.
     * If that condition no longer holds, the target in .v has been changed
     * and the range information (index, size) is no longer valid.
     */
};

/*-------------------------------------------------------------------------*/
/* Forward declarations */

static void transfer_pointer_range(svalue_t *source);
static void transfer_protected_pointer_range(
    struct protected_range_lvalue *dest, svalue_t *source);
static void assign_string_range(svalue_t *source, Bool do_free);
static void assign_protected_string_range(
    struct protected_range_lvalue *dest,svalue_t *source, Bool do_free);

/*-------------------------------------------------------------------------*/
void
free_string_svalue (svalue_t *v)

/* Free the string svalue <v>; <v> must be of type T_STRING.
 */

{
#ifdef DEBUG
    if (v->type != T_STRING)
    {
        fatal("free_string_svalue(): Expected string, "
              "received svalue type (%d:%hd)\n"
            , v->type, v->x.generic);
        /* NOTREACHED */
        return;
    }
#endif

    free_mstring(v->u.str);
}

#define free_string_svalue(v) free_mstring((v)->u.str)

/*-------------------------------------------------------------------------*/
void
free_object_svalue (svalue_t *v)

/* Free the object svalue <v>; <v> must be of type T_OBJECT.
 */

{
    object_t *ob = v->u.ob;

#ifdef DEBUG
    if (v->type != T_OBJECT)
    {
        fatal("free_object_svalue(): Expected object, "
              "received svalue type (%d:%hd)\n"
            , v->type, v->x.generic);
        /* NOTREACHED */
        return;
    }
#endif

    free_object(ob, "free_object_svalue");
}

/*-------------------------------------------------------------------------*/
void
zero_object_svalue (svalue_t *v)

/* Change <v> from an object svalue to the svalue-number 0.
 */

{
    object_t *ob = v->u.ob;

    free_object(ob, "zero_object_svalue");
    put_number(v, 0);
}

/*-------------------------------------------------------------------------*/
static void
free_protector_svalue (svalue_t *v)

/* Free the svalue <v> which contains a protective reference to a vector
 * or to a mapping.
 */

{
    switch (v->type)
    {
#ifdef USE_STRUCTS
      case T_STRUCT:
        free_struct(v->u.strct);
        break;
#endif /* USE_STRUCTS */
      case T_POINTER:
        free_array(v->u.vec);
        break;
      case T_MAPPING:
        free_mapping(v->u.map);
        break;
      case T_PROTECTOR_MAPPING:
        free_protector_mapping(v->u.map);
        break;
    }
}

/*-------------------------------------------------------------------------*/
static void
int_free_svalue (svalue_t *v)

/* Free the svalue <v>, which may be of any type.
 * Afterwards, the content of <v> is undefined.
 */

{
    ph_int type = v->type;

    v->type = T_INVALID;
      /* If freeing the value throws an error, it is most likely that
       * we ran out of stack. To avoid the error handling running
       * out of stack on the same value again, we mask it before we free
       * it - at the risk of leaking memory.
       */

    assert_stack_gap();

    switch (type)
    {
    default:
        fatal("(free_svalue) Illegal svalue %p type %d\n", v, type);
        /* NOTREACHED */
        break;

    case T_INVALID:
    case T_NUMBER:
    case T_FLOAT:
        NOOP;
        break;

    case T_STRING:
      {
        string_t *str = v->u.str;
        free_mstring(str);
        break;
      }

    case T_OBJECT:
      {
        object_t *ob = v->u.ob;
        free_object(ob, "free_svalue");
        break;
      }

    case T_QUOTED_ARRAY:
    case T_POINTER:
        free_array(v->u.vec);
        break;

#ifdef USE_STRUCTS
    case T_STRUCT:
        free_struct(v->u.strct);
        break;
#endif /* USE_STRUCTS */

    case T_MAPPING:
        free_mapping(v->u.map);
        break;

    case T_SYMBOL:
        free_mstring(v->u.str);
        break;

    case T_CLOSURE:
        free_closure(v);
        break;

    case T_CALLBACK:
        free_callback(v->u.cb);
        break;

    case T_LVALUE:
        switch (v->u.lvalue->type)
        {
        case T_PROTECTED_LVALUE:
          {
              struct protected_lvalue *p;

              p = v->u.protected_lvalue;
              free_protector_svalue(&p->protector);
              xfree(p);
              break;
          }

        case T_PROTECTED_CHAR_LVALUE:
          {
              struct protected_char_lvalue *p;

              p = v->u.protected_char_lvalue;
              if (p->v.type == T_STRING)
              {
                  free_mstring(p->v.u.str);
              }
              free_protector_svalue(&p->protector);
              xfree(p);
              break;
          }

        case T_PROTECTED_STRING_RANGE_LVALUE:
          {
              struct protected_range_lvalue *p;

              p = v->u.protected_range_lvalue;
              free_mstring(p->v.u.str);
              free_protector_svalue(&p->protector);
              xfree(p);
              break;
          }

        case T_PROTECTED_POINTER_RANGE_LVALUE:
          {
              struct protected_range_lvalue *p;

              p = v->u.protected_range_lvalue;
              free_array(p->v.u.vec);
              free_protector_svalue(&p->protector);
              xfree(p);
              break;
          }

        case T_ERROR_HANDLER:
          {
              svalue_t *p;

              p = v->u.lvalue;
              (*p->u.error_handler)(p);
              break;
          }
        } /* switch (v->u.lvalue->type) */
        break; /* case T_LVALUE */

    }
} /* int_free_svalue() */

/*-------------------------------------------------------------------------*/

/* Queue element to deserialize the freeing of complex svalues. */
struct fs_queue_s {
    struct fs_queue_s * next;
    svalue_t                   value;
};

typedef struct fs_queue_s fs_queue_t;

static fs_queue_t fs_queue_base;
  /* Static fs_queue_t variable to avoid xallocs for the simple cases.
   */

static fs_queue_t * fs_queue_head = NULL;
static fs_queue_t * fs_queue_tail = NULL;
  /* Double-ended list of deserialized svalues to free.
   */

void
free_svalue (svalue_t *v)

/* Free the svalue <v>, which may be of any type, while making sure that
 * complex nested structures are deserialized (to avoid stack overflows).
 * Afterwards, the content of <v> is undefined.
 */

{
    Bool needs_deserializing = MY_FALSE;

    switch (v->type)
    {
    case T_QUOTED_ARRAY:
    case T_POINTER:
        needs_deserializing = (v->u.vec->ref == 1);
        break;

#ifdef USE_STRUCTS
    case T_STRUCT:
        needs_deserializing = (struct_ref(v->u.strct) == 1);
        break;
#endif /* USE_STRUCTS */

    case T_MAPPING:
        needs_deserializing = (v->u.map->ref == 1);
        break;
    }

    /* If the value doesn't need de-serializing, it can be
     * be freed immediately.
     */
    if (!needs_deserializing)
    {
        int_free_svalue(v);
        return;
    }

    /* If there are elements in the queue, we are inside the freeing of a
     * complex structure, and this element just needs to be queued up.
     * When out of memory, however, just free it.
     */
    if (fs_queue_head != NULL)
    {
        fs_queue_t * tmp = xalloc(sizeof(*tmp));

        if (NULL == tmp)
        {
            int_free_svalue(v);
            return;
        }

        /* Copy the value over, invalidating this one. */
        tmp->next = NULL;
        tmp->value = *v;
        v->type = T_INVALID;

        /* Insert the element into the queue. */
        fs_queue_tail->next = tmp;
        fs_queue_tail = tmp;

        return;
    }

    /* This is the first complex value to be freed - start the queue.
     */
    fs_queue_base.next = NULL;
    fs_queue_base.value = *v;
    v->type = T_INVALID;

    fs_queue_head = fs_queue_tail = &fs_queue_base;

    /* Now loop over the queue, successively freeing the values.
     * If one of the values freed contains complex freeable structures
     * itself, they will be added to the end of the queue and eventually
     * picked up by this loop.
     */
    while (fs_queue_head != NULL)
    {
        fs_queue_t * current = fs_queue_head;

        int_free_svalue(&(fs_queue_head->value));

        fs_queue_head = fs_queue_head->next;
        if (fs_queue_head == NULL)
            fs_queue_tail = NULL;

        if (current != &fs_queue_base)
            xfree(current);
    }
} /* free_svalue() */

/*-------------------------------------------------------------------------*/
static INLINE Bool
_destructed_object_ref (svalue_t *svp)

/* Return TRUE if the svalue in <svp> references a destructed object.
 */

{
    lambda_t *l;
    int type;

    if (svp->type != T_OBJECT && svp->type != T_CLOSURE)
        return MY_FALSE;

    if (svp->type == T_OBJECT || !CLOSURE_MALLOCED(type = svp->x.closure_type))
        return (svp->u.ob->flags & O_DESTRUCTED) ? MY_TRUE : MY_FALSE;

    /* Lambda closure */

    l = svp->u.lambda;

    if (CLOSURE_HAS_CODE(type) && type == CLOSURE_UNBOUND_LAMBDA)
        return MY_FALSE;

    if (type == CLOSURE_LFUN
     && (l->function.lfun.ob->flags & O_DESTRUCTED))
        return MY_TRUE;

    return (l->ob->flags & O_DESTRUCTED) ? MY_TRUE : MY_FALSE;

} /* _destructed_object_ref() */

Bool destructed_object_ref (svalue_t *v) { return _destructed_object_ref(v); }

#define destructed_object_ref(v) _destructed_object_ref(v)

/*-------------------------------------------------------------------------*/
static INLINE Bool
int_object_ref (svalue_t *svp, object_t *obj)

/* Return TRUE if <svp> references object <obj> (destructed or alive),
 * return FALSE if it doesn't.
 */

{
    lambda_t *l;
    int type;

    if (svp->type != T_OBJECT && svp->type != T_CLOSURE)
        return MY_FALSE;

    if (svp->type == T_OBJECT || !CLOSURE_MALLOCED(type = svp->x.closure_type))
        return svp->u.ob == obj;

    /* Lambda closure */

    l = svp->u.lambda;

    if (CLOSURE_HAS_CODE(type) && type == CLOSURE_UNBOUND_LAMBDA)
        return MY_FALSE;

    if (type == CLOSURE_LFUN && l->function.lfun.ob == obj)
        return MY_TRUE;

    return l->ob == obj;

} /* int_object_ref() */

#define object_ref(v,o) int_object_ref(v,o)

/*-------------------------------------------------------------------------*/
static INLINE void
check_for_ref_loop (svalue_t * dest)

/* <dest> has just been assigned to - check if this created a reference loop.
 * If yes, free <dest> and throw an error.
 */

{
    if (dest->type == T_LVALUE || dest->type == T_PROTECTED_LVALUE)
    {
        /* rover1 will scan the lvalue chain in two-steps, rover2 will
         * scan it step by step. If there is a loop, the two will eventually
         * meet again.
         */
        svalue_t * rover1, * rover2;

        rover1 = rover2 = dest;
        do {
            if (rover1->type == T_LVALUE || rover1->type == T_PROTECTED_LVALUE)
                rover1 = rover1->u.lvalue;
            else
                break;
            if (rover1->type == T_LVALUE || rover1->type == T_PROTECTED_LVALUE)
                rover1 = rover1->u.lvalue;
            else
                break;
            if (rover2->type == T_LVALUE || rover2->type == T_PROTECTED_LVALUE)
                rover2 = rover2->u.lvalue;
            else
                break;
            if (rover1 == rover2)
            {
                free_svalue(dest);
                errorf("Assignment would create reference loop.\n");
            }
        } while (rover1
             && (rover1->type == T_LVALUE || rover1->type == T_PROTECTED_LVALUE)
             && rover2
             && (rover2->type == T_LVALUE || rover2->type == T_PROTECTED_LVALUE)
                );
    }

} /* check_for_ref_loop() */

/*-------------------------------------------------------------------------*/
static INLINE void
inl_assign_svalue_no_free (svalue_t *to, svalue_t *from)

/* Put a duplicate of svalue <from> into svalue <to>, meaning that the original
 * value is either copied when appropriate, or its refcount is increased.
 * <to> is considered empty at the time of call.
 *
 * If <from> is a destructed object, <to> is set to the number 0 but
 * <from> is left unchanged.
 */

{
#ifdef DEBUG
    if (from == 0)
        fatal("Null pointer to assign_svalue().\n");
#endif

    /* Copy all the data */
    *to = *from;

    /* Now create duplicates resp. increment refcounts where necessary */

    switch(from->type)
    {
    case T_STRING:
        (void)ref_mstring(from->u.str);
        break;

    case T_OBJECT:
        {
          object_t *ob = to->u.ob;
          if ( !(ob->flags & O_DESTRUCTED) )
              (void)ref_object(ob, "ass to var");
          else
              put_number(to, 0);

          break;
        }
        break;

    case T_QUOTED_ARRAY:
    case T_POINTER:
        (void)ref_array(to->u.vec);
        break;

#ifdef USE_STRUCTS
    case T_STRUCT:
        (void)ref_struct(to->u.strct);
        break;
#endif /* USE_STRUCTS */

    case T_SYMBOL:
        (void)ref_mstring(to->u.str);
        break;

    case T_CLOSURE:
        addref_closure(to, "ass to var");
        break;

    case T_MAPPING:
        (void)ref_mapping(to->u.map);
        break;
    }

    /* Protection against endless reference loops */
    if (to->type == T_LVALUE || to->type == T_PROTECTED_LVALUE)
    {
        check_for_ref_loop(to);
    }
} /* inl_assign_svalue_no_free() */

void assign_svalue_no_free (svalue_t *to, svalue_t *from)
{ inl_assign_svalue_no_free(to,from); }

#define assign_svalue_no_free(to,from) inl_assign_svalue_no_free(to,from)

/*-------------------------------------------------------------------------*/
static INLINE void
inl_copy_svalue_no_free (svalue_t *to, svalue_t *from)

/* Put a duplicate of svalue <from> into svalue <to>, meaning that the original
 * value is either copied when appropriate, or its refcount is increased.
 * In particular, if <from> is a mapping (which must not contain destructed
 * objects!) or array, a shallow copy is created.
 * <to> is considered empty at the time of call.
 *
 * If <from> is a destructed object, <to> is set to the number 0 but
 * <from> is left unchanged.
 */

{
    assign_svalue_no_free(to, from);

    /* For arrays and mappings, create a shallow copy */
    if (from->type == T_MAPPING)
    {
        mapping_t *old, *new;

        old = to->u.map;
        if (old->ref != 1)
        {
            DYN_MAPPING_COST(MAP_SIZE(old));
            new = copy_mapping(old);
            if (!new)
                errorf("Out of memory: mapping[%"PRIdPINT"] for copy.\n"
                     , MAP_SIZE(old));
            free_mapping(old);
            to->u.map = new;
        }
    }
    else if (from->type == T_POINTER
          || from->type == T_QUOTED_ARRAY)
    {
        vector_t *old, *new;
        size_t size, i;

        old = to->u.vec;
        size = VEC_SIZE(old);
        if (old->ref != 1 && old != &null_vector)
        {
            DYN_ARRAY_COST(size);
            new = allocate_uninit_array((int)size);
            if (!new)
                errorf("Out of memory: array[%zu] for copy.\n"
                     , size);
            for (i = 0; i < size; i++)
                assign_svalue_no_free( &new->item[i]
                                     , &old->item[i]);
            free_array(old);
            to->u.vec = new;
        }
    }
} /* inl_copy_svalue_no_free() */

void copy_svalue_no_free (svalue_t *to, svalue_t *from)
{ inl_copy_svalue_no_free(to,from); }

#define copy_svalue_no_free(to,from) inl_copy_svalue_no_free(to,from)

/*-------------------------------------------------------------------------*/
static INLINE void
assign_checked_svalue_no_free (svalue_t *to, svalue_t *from)

/* Put a duplicate of svalue <from> into svalue <to>, meaning that the original
 * value is either copied when appropriate, or its refcount is increased.
 * <to> is considered empty at the time of call.
 * <from> may point to a variable or vector element, so it might contain
 * a destructed object. In that case, <from> and <to> are set to
 * svalue-number 0.
 */

{
    switch (from->type)
    {
    case T_STRING:
        (void)ref_mstring(from->u.str);
        break;

    case T_OBJECT:
      {
        object_t *ob = from->u.ob;
        if ( !(ob->flags & O_DESTRUCTED) ) {
            ref_object(ob, "ass to var");
            break;
        }
        zero_object_svalue(from);
        break;
      }

    case T_QUOTED_ARRAY:
    case T_POINTER:
        (void)ref_array(from->u.vec);
        break;

#ifdef USE_STRUCTS
    case T_STRUCT:
        (void)ref_struct(from->u.strct);
        break;
#endif /* USE_STRUCTS */

    case T_SYMBOL:
        (void)ref_mstring(from->u.str);
        break;

    case T_CLOSURE:
        if (!destructed_object_ref(from))
            addref_closure(from, "ass to var");
        else
            assign_svalue(from, &const0);
        break;

    case T_MAPPING:
        (void)ref_mapping(from->u.map);
        break;
    }
    *to = *from;

    /* Protection against endless reference loops */
    if (to->type == T_LVALUE || to->type == T_PROTECTED_LVALUE)
    {
        check_for_ref_loop(to);
    }
} /* assign_checked_svalue_no_free() */

/*-------------------------------------------------------------------------*/
static INLINE void
assign_local_svalue_no_free ( svalue_t *to, svalue_t *from )

/* Put a duplicate of svalue <from> into svalue <to>, meaning that the original
 * value is either copied when appropriate, or its refcount is increased.
 * <to> is considered empty at the time of call.
 *
 * <from> is meant to point to a local variable, which might be an arg
 * to the current lfun.
 * If <from> is a lvalue, the chain is unraveled and the final non-lvalue
 * is assigned. If that value is a destructed object, 0 is assigned.
 */

{
assign_from_lvalue:
    switch (from->type)
    {
      case T_STRING:
        (void)ref_mstring(from->u.str);
        break;
      case T_OBJECT:
        (void)ref_object(from->u.ob, "assign_local_lvalue_no_free");
        break;
      case T_QUOTED_ARRAY:
      case T_POINTER:
        (void)ref_array(from->u.vec);
        break;
#ifdef USE_STRUCTS
      case T_STRUCT:
        (void)ref_struct(from->u.strct);
        break;
#endif /* USE_STRUCTS */
      case T_SYMBOL:
        (void)ref_mstring(from->u.str);
        break;
      case T_CLOSURE:
        addref_closure(from, "ass to var");
        break;
      case T_MAPPING:
        (void)ref_mapping(from->u.map);
        break;
      case T_LVALUE:
      case T_PROTECTED_LVALUE:
        from = from->u.lvalue;
        if (destructed_object_ref(from)) {
            assign_svalue(from, &const0);
            break;
        }
        goto assign_from_lvalue;
      case T_PROTECTED_CHAR_LVALUE:
        put_number(to, *from->u.charp);
        return;
    }
    *to = *from;

    /* Protection against endless reference loops */
    if (to->type == T_LVALUE || to->type == T_PROTECTED_LVALUE)
    {
        check_for_ref_loop(to);
    }
} /* assign_local_svalue_no_free() */

/*-------------------------------------------------------------------------*/
static INLINE
void assign_lrvalue_no_free (svalue_t *to, svalue_t *from)

/* Put a duplicate of svalue <from> into svalue <to>, meaning that the original
 * value is either copied when appropriate, or its refcount is increased.
 * <to> is considered empty at the time of call.
 *
 * This function differs from assign_svalue_no_free() in the handling of
 * two types:
 *  - if <from> is an unshared string, the string is made shared and
 *    both <to> and <from> are changed to use the shared string.
 *  - if <from> is a lvalue, <to>.u.lvalue is set to point to <from>.
 *    This is necessary when pushing references onto the stack - if
 *    assign_svalue_no_free() were used, the first free_svalue() would undo
 *    the whole lvalue indirection, even though there were still other lvalue
 *    entries in the stack for the same svalue.
 *    TODO: An alternative would be use a special struct lvalue {} with a
 *    refcount.
 */

{
#ifdef DEBUG
    if (from == 0)
        fatal("Null pointer to assign_lrvalue_no_free().\n");
#endif

    /* Copy the data */
    *to = *from;

    /* Now adapt the refcounts or similar */

    switch(from->type)
    {
    case T_STRING:
        (void)ref_mstring(to->u.str);
        break;

    case T_OBJECT:
        (void)ref_object(to->u.ob, "ass to var");
        break;

    case T_QUOTED_ARRAY:
    case T_POINTER:
        (void)ref_array(to->u.vec);
        break;

#ifdef USE_STRUCTS
    case T_STRUCT:
        (void)ref_struct(to->u.strct);
        break;
#endif /* USE_STRUCTS */

    case T_SYMBOL:
        (void)ref_mstring(to->u.str);
        break;

    case T_CLOSURE:
        if (!destructed_object_ref(to))
            addref_closure(to, "ass to var");
        else
            put_number(to, 0);
        break;

    case T_MAPPING:
        (void)ref_mapping(to->u.map);
        break;

    case T_LVALUE:
        to->u.lvalue = from;
        break;
    }

    /* Protection against endless reference loops */
    if (to->type == T_LVALUE || to->type == T_PROTECTED_LVALUE)
    {
        check_for_ref_loop(to);
    }
} /* assign_lrvalue_no_free() */

/*-------------------------------------------------------------------------*/
void
assign_svalue (svalue_t *dest, svalue_t *v)

/* Put a duplicate of svalue <v> into svalue <dest>, meaning that the
 * original value is either copied when appropriate, or its refcount is
 * increased.
 *
 * <dest> is considered a valid svalue and therefore freed before the
 * assignment. Structured values will necessiate doing the assignment before
 * the actual deallocation, otherwise recursive structures could cause crashs.
 * One nasty example is
 *    a = ( ({((a=({0})),(a[0]=a)),(a=0)})[0] = query_verb() );
 * which used to corrupt the shared string table, namely the entry for
 * the verb in variable a if its length uses a memory block of
 * the same length as an array of size 2.
 *
 * If <dest> is a lvalue, <v> will be assigned to the svalue referenced
 * to by <dest>.
 */

{
    /* Free the <dest> svalue.
     * If <dest> is a (protected) lvalue, the loop will traverse the lvalue
     * chain until the actual svalue is found.
     * If a T_xxx_LVALUE is found, the assignment will be done here
     * immediately.
     */

    for (;;) {
        switch(dest->type)
        {
        case T_LVALUE:
        case T_PROTECTED_LVALUE:
            dest = dest->u.lvalue;
            continue;

        case T_STRING:
            free_mstring(dest->u.str);
            break;

        case T_OBJECT:
          {
            object_t *ob = dest->u.ob;
            free_object(ob, "assign_svalue");
            break;
          }

        case T_QUOTED_ARRAY:
        case T_POINTER:
          {
            vector_t *vec = dest->u.vec;
            assign_svalue_no_free(dest, v);
              /* TODO: leaks vec if out of memory */
            free_array(vec);
            return;
          }

#ifdef USE_STRUCTS
        case T_STRUCT:
          {
            struct_t *strct = dest->u.strct;
            assign_svalue_no_free(dest, v);
              /* TODO: leaks strct if out of memory */
            free_struct(strct);
            return;
          }
#endif /* USE_STRUCTS */

        case T_MAPPING:
          {
            mapping_t *map = dest->u.map;
            assign_svalue_no_free(dest, v); /* leaks map if out of memory */
            free_mapping(map);
            return;
          }

        case T_SYMBOL:
            free_mstring(dest->u.str);
            break;

        case T_CLOSURE:
            free_closure(dest);
            break;

        /* If the final svalue in dest is one of these lvalues,
         * the assignment is done right here and now.
         * Note that 'dest' in some cases points to a protector structure.
         */

        case T_CHAR_LVALUE:
            if (v->type == T_NUMBER)
                *dest->u.charp = (char)v->u.number;
            return;

        case T_PROTECTED_CHAR_LVALUE:
          {
            struct protected_char_lvalue *p;

            p = (struct protected_char_lvalue *)dest;
            if (p->lvalue->type == T_STRING
             && get_txt(p->lvalue->u.str) == p->start)
            {
                if (v->type == T_NUMBER)
                    *p->v.u.charp = (char)v->u.number;
            }
            return;
          }

        case T_POINTER_RANGE_LVALUE:
            if (v->type == T_POINTER)
            {
                (void)ref_array(v->u.vec); /* transfer_...() will free it once */
                transfer_pointer_range(v);
            }
            return;

        case T_PROTECTED_POINTER_RANGE_LVALUE:
            if (v->type == T_POINTER)
            {
                (void)ref_array(v->u.vec); /* transfer_...() will free it once */
                transfer_protected_pointer_range(
                  (struct protected_range_lvalue *)dest, v
                );
            }
            return;

        case T_STRING_RANGE_LVALUE:
            assign_string_range(v, MY_FALSE);
            return;

        case T_PROTECTED_STRING_RANGE_LVALUE:
            assign_protected_string_range(
                  (struct protected_range_lvalue *)dest, v, MY_FALSE
            );
            return;

        } /* switch() */

        /* No more lvalues to follow, old value freed: do the assign next */
        break;
    } /* end for */

    /* Now assign the value to the now-invalid <dest> */
    assign_svalue_no_free(dest, v);
} /* assign_svalue() */

/*-------------------------------------------------------------------------*/
static INLINE void
inl_transfer_svalue_no_free (svalue_t *dest, svalue_t *v)

/* Move the value <v> into <dest>.
 *
 * <dest> is assumed to be invalid before the call, <v> is invalid after.
 */

{
    /* Copy the data */
    *dest = *v;

    /* Protection against endless reference loops */
    if (dest->type == T_LVALUE || dest->type == T_PROTECTED_LVALUE)
    {
        v->type = T_INVALID;
        check_for_ref_loop(dest);
    }
} /* inl_transfer_svalue_no_free() */

void transfer_svalue_no_free (svalue_t *dest, svalue_t *v)
{  inl_transfer_svalue_no_free(dest,v); }

#define transfer_svalue_no_free(dest,v) inl_transfer_svalue_no_free(dest,v)

/*-------------------------------------------------------------------------*/
static INLINE void
inl_transfer_svalue (svalue_t *dest, svalue_t *v)

/* Move svalue <v> into svalue <dest>.
 *
 * <dest> is considered a valid svalue and therefore freed before the
 * assignment. <v> will be invalid after the call.
 *
 * If <dest> is a lvalue, <v> will be moved into the svalue referenced
 * to by <dest>.
 *
 * TODO: Test if copying this function into F_VOID_ASSIGN case speeds up
 * TODO:: the interpreter.
 */

{
    /* Unravel the T_LVALUE chain, if any. */
    while (dest->type == T_LVALUE || dest->type == T_PROTECTED_LVALUE)
        dest = dest->u.lvalue;

    /* Free the <dest> svalue.
     * If a T_xxx_LVALUE is found, the transfer will be done here
     * immediately.
     */

    for(;;)
    {
        switch (dest->type)
        {
        case T_STRING:
            free_mstring(dest->u.str);
            break;

        case T_OBJECT:
          {
            object_t *ob = dest->u.ob;
            free_object(ob, "transfer_svalue");
            break;
          }

        case T_QUOTED_ARRAY:
        case T_POINTER:
            free_array(dest->u.vec);
            break;

#ifdef USE_STRUCTS
        case T_STRUCT:
            free_struct(dest->u.strct);
            break;
#endif /* USE_STRUCTS */

        case T_SYMBOL:
            free_mstring(dest->u.str);
            break;

        case T_CLOSURE:
            free_closure(dest);
            break;

        case T_MAPPING:
            free_mapping(dest->u.map);
            break;

        /* If the final svalue in dest is one of these lvalues,
         * the assignment is done right here and now.
         * Note that 'dest' in some cases points to a protector structure.
         */

        case T_CHAR_LVALUE:
            if (v->type == T_NUMBER)
            {
                *dest->u.charp = (char)v->u.number;
            }
            else
                free_svalue(v);
            return;

        case T_PROTECTED_CHAR_LVALUE:
          {
            struct protected_char_lvalue *p;

            p = (struct protected_char_lvalue *)dest;
            if (p->lvalue->type == T_STRING
             && get_txt(p->lvalue->u.str) == p->start)
            {
                if (v->type == T_NUMBER)
                {
                    *p->v.u.charp = (char)v->u.number;
                    return;
                }
            }
            free_svalue(v);
            return;
          }

        case T_POINTER_RANGE_LVALUE:
            transfer_pointer_range(v);
            return;

        case T_PROTECTED_POINTER_RANGE_LVALUE:
            transfer_protected_pointer_range(
              (struct protected_range_lvalue *)dest, v
            );
            return;

        case T_STRING_RANGE_LVALUE:
            assign_string_range(v, MY_TRUE);
            return;

        case T_PROTECTED_STRING_RANGE_LVALUE:
            assign_protected_string_range(
              (struct protected_range_lvalue *)dest, v, MY_TRUE
            );
            return;
        } /* end switch */

        /* No more lvalues to follow, old value freed: do the assign next */
        break;
    } /* end for */

    /* Transfer the value */
    *dest = *v;

    /* Protection against endless reference loops */
    if (dest->type == T_LVALUE || dest->type == T_PROTECTED_LVALUE)
    {
        v->type = T_INVALID;
        check_for_ref_loop(dest);
    }

} /* inl_transfer_svalue() */

void transfer_svalue (svalue_t *dest, svalue_t *v)
{  inl_transfer_svalue(dest,v); }

#define transfer_svalue(dest,v) inl_transfer_svalue(dest,v)

/*-------------------------------------------------------------------------*/
static void
transfer_pointer_range (svalue_t *source)

/* Transfer the vector <source> to the vector range defined by
 * <special_lvalue>, modifying the target vector in special_lvalue
 * accordingly. <source> is freed once in the call.
 *
 * If <source> is not a vector, it is just freed.
 */

{
    if (source->type == T_POINTER)
    {
        vector_t *sv;      /* Source vector (from source) */
        vector_t *dv;      /* Destination vector (from special_lvalue) */
        vector_t *rv;      /* Result vector */
        mp_int dsize;           /* Size of destination vector */
        mp_int ssize;           /* Size of source vector */
        mp_int index1, index2;  /* First and last index of destination range */
        mp_int i;

        /* Setup the variables */
        dsize = special_lvalue.size;
        index1 = special_lvalue.index1;
        index2 = special_lvalue.index2;
        dv = special_lvalue.v.u.lvalue->u.vec;
        sv = source->u.vec;
        ssize = (mp_int)VEC_SIZE(sv);

#ifdef NO_NEGATIVE_RANGES
        if (index1 > index2)
            errorf("Illegal range [%"PRIdMPINT"..%"PRIdMPINT
                   "] for assignment.\n", index1, index2-1
                 );
#endif /* NO_NEGATIVE_RANGES */

        if (ssize + index1 - index2 == 0)
        {
            /* <source> fits exactly into the target range */

            svalue_t *s, *d;  /* Copy source and destination */

            s = sv->item;
            d = dv->item + index1;

            ref_array(dv); /* protect against recursive refs during the copy */

            /* If there is just one ref to the source, use the faster
             * transfer instead of the slow assign for the copy.
             */
            if (sv->ref == 1)
            {
                for (i = ssize; --i >= 0; )
                {
                    transfer_svalue(d++, s++);
                }
                free_empty_vector(sv);
            }
            else /* sv->ref > 1 */
            {
                for (i = ssize; --i >= 0; )
                {
                    assign_svalue(d++, s++);
                }

                free_array(sv);
                  /* deref_array() is not enough, because in situations
                   * where one d == sv, eg
                   *    arr = ({ ({ 1 }) });
                   *    arr[0..0] = arr[0];
                   * sv would be left behind with 0 refs but unfreed.
                   */
            }

            free_array(dv); /* Undo the ref_array() above */
        }
        else
        {
            /* Create a new vector */

            svalue_t *s, *d; /* Copy source and destination */

            rv = allocate_array(dsize + ssize + index1 - index2);
            special_lvalue.v.u.lvalue->u.vec = rv;
            s = dv->item;
            d = rv->item;

            for (i = index1; --i >= 0; )
            {
                assign_svalue_no_free(d++, s++);
            }

            s = sv->item;
            for (i = ssize; --i >= 0; )
            {
                assign_svalue_no_free(d++, s++);
            }
            free_array(sv);

            s = dv->item + index2;
            for (i = dsize - index2; --i >= 0; )
            {
                assign_svalue_no_free(d++, s++);
            }

            free_array(dv); /* this can make the lvalue invalid to use */
        }
    }
    else
        /* Not a pointer: just free it */
        free_svalue(source);

} /* transfer_pointer_range() */

/*-------------------------------------------------------------------------*/
static void
transfer_protected_pointer_range ( struct protected_range_lvalue *dest
                                 , svalue_t *source)

/* Transfer the vector <source> to the vector range defined by
 * <dest>, modifying the target vector in <dest>
 * accordingly. <source> is freed once in the call.
 *
 * If <source> is not a vector, it is just freed.
 */

{
    if (source->type == T_POINTER && dest->v.u.vec == dest->lvalue->u.vec)
    {
        vector_t *sv;      /* Source vector (from source) */
        vector_t *dv;      /* Dest vector (from dest) */
        vector_t *rv;      /* Result vector */
        mp_int dsize;           /* Size of the dest vector */
        mp_int ssize;           /* Size of the source vector */
        mp_int index1, index2;  /* Target range indices */
        mp_int i;

        /* Setup the variables */
        dsize = dest->size;
        index1 = dest->index1;
        index2 = dest->index2;
        dv = dest->v.u.vec;
        sv = source->u.vec;
        ssize = (mp_int)VEC_SIZE(sv);

#ifdef NO_NEGATIVE_RANGES
        if (index1 > index2)
            errorf("Illegal range [%"PRIdMPINT"..%"PRIdMPINT
                   "] for assignment.\n", index1, index2-1
                 );
#endif /* NO_NEGATIVE_RANGES */

        if (ssize + index1 - index2 == 0)
        {
            /* <source> fits exactly into the target range */

            svalue_t *s, *d; /* Copy source and destination */

            s = sv->item;
            d = dv->item + index1;

            /* If there is just one ref to the source, use the faster
             * transfer instead of the slow assign for the copy.
             */
            if (sv->ref == 1)
            {
                for (i = ssize; --i >= 0; )
                {
                    transfer_svalue(d++, s++);
                }
                free_empty_vector(sv);
            }
            else /* sv->ref > 1 */
            {
                for (i = ssize; --i >= 0; )
                {
                    assign_svalue(d++, s++);
                }

                deref_array(sv);
                /* The if() above effectively did the 'free_svalue(source)' */
            }
        }
        else
        {
            /* Create a new vector */

            svalue_t *s, *d;  /* Copy source and destination */

            rv = allocate_array(dsize + ssize + index1 - index2);
            dest->lvalue->u.vec = rv;

            s = dv->item;
            d = rv->item;
            for (i = index1; --i >= 0; )
            {
                assign_svalue_no_free(d++, s++);
            }

            s = sv->item;
            for (i = ssize; --i >= 0; )
            {
                assign_svalue_no_free(d++, s++);
            }
            free_array(sv);

            s = dv->item + index2;
            for (i = dsize - index2; --i >= 0; )
            {
                assign_svalue_no_free(d++, s++);
            }

            free_array(dv); /* this can make the lvalue invalid to use */
        }
    }
    else
    {
        /* Not a pointer, or the protected range has changed in size before:
         * just free it
         */
        free_svalue(source);
    }

} /* transfer_protected_pointer_range() */

/*-------------------------------------------------------------------------*/
static void
assign_string_range (svalue_t *source, Bool do_free)

/* Transfer the string <source> to the string range defined by
 * <special_lvalue>, modifying the target string in special_lvalue
 * accordingly. If <do_free> is TRUE, <source> is freed once in the call.
 *
 * If <source> is not a string, it is just freed resp. ignored.
 */

{
    if (source->type == T_STRING)
    {
        svalue_t *dsvp;     /* destination svalue (from special_lvalue) */
        string_t *ds;            /* destination string (from dsvp) */
        string_t *ss;            /* source string (from source) */
        string_t *rs;            /* result string */
        mp_int dsize;            /* size of destination string */
        mp_int ssize;            /* size of source string */
        mp_int index1, index2;   /* range indices */

        /* Set variables */
        dsize = special_lvalue.size;
        index1 = special_lvalue.index1;
        index2 = special_lvalue.index2;
        dsvp = special_lvalue.v.u.lvalue;
        ds = dsvp->u.str;
        ss = source->u.str;
        ssize = (mp_int)mstrsize(ss);

#ifdef NO_NEGATIVE_RANGES
        if (index1 > index2)
            errorf("Illegal range [%"PRIdMPINT"..%"PRIdMPINT
                   "] for assignment.\n", index1, index2-1
                 );
#endif /* NO_NEGATIVE_RANGES */

        /* Create the new string */
        rs = alloc_mstring((size_t)(dsize + ssize + index1 - index2));
        if (!rs)
        {
            /* We don't pop the stack here --> don't free source */
            outofmem((dsize + ssize + index1 - index2), "new string");
        }

        if (index1)
            memcpy(get_txt(rs), get_txt(ds), (size_t)index1);
        if (ssize)
            memcpy(get_txt(rs) + index1, get_txt(ss), (size_t)ssize);
        if (dsize > index2)
            memcpy( get_txt(rs) + index1 + ssize, get_txt(ds) + index2
                  , (size_t)(dsize - index2));

        /* Assign the new string in place of the old */
        free_string_svalue(dsvp);
        dsvp->u.str = rs;

        if (do_free)
            free_string_svalue(source);
    }
    else
    {
        /* Not a string: just free it */
        if (do_free)
            free_svalue(source);
    }
} /* assign_string_range() */

/*-------------------------------------------------------------------------*/
static void
assign_protected_string_range ( struct protected_range_lvalue *dest
                              , svalue_t *source
                              , Bool do_free
                              )

/* Transfer the string <source> to the string range defined by
 * <dest>, modifying the target string in dest
 * accordingly.
 *
 * If <do_free> is TRUE, <source> and the protector <dest> are freed once
 * in the call.
 *
 * If <source> is not a string, it is just freed resp. ignored.
 */

{
    if (source->type == T_STRING)
    {
        svalue_t *dsvp;     /* destination value (from dest) */
        string_t *ds;            /* destination string (from dsvp) */
        string_t *ss;            /* source string (from source) */
        string_t *rs;            /* result string */
        mp_int dsize;            /* size of destination string */
        mp_int ssize;            /* size of source string */
        mp_int rsize;            /* size of result string */
        mp_int index1, index2;   /* range indices */

        /* Set variables */
        dsize = dest->size;
        index1 = dest->index1;
        index2 = dest->index2;
        dsvp = dest->lvalue;
        ds = dest->v.u.str;

#ifdef NO_NEGATIVE_RANGES
        if (index1 > index2)
            errorf("Illegal range [%"PRIdMPINT"..%"PRIdMPINT
                   "] for assignment.\n", index1, index2-1
                 );
#endif /* NO_NEGATIVE_RANGES */

        /* If the lvalue is no longer valid, free it */
        if (dsvp->u.str != ds)
        {
            if (do_free)
                free_svalue(source);
            return;
        }

        /* Create a new string */
        ss = source->u.str;
        ssize = (mp_int)mstrsize(ss);
        rsize = dsize + ssize + index1 - index2;
        rs = alloc_mstring((size_t)rsize);
        if (!rs)
        {
            outofmem((dsize + ssize + index1 - index2), "new string");
        }

        if (index1)
            memcpy(get_txt(rs), get_txt(ds), (size_t)index1);
        if (ssize)
            memcpy(get_txt(rs) + index1, get_txt(ss), (size_t)ssize);
        dest->index2 = (int)(index1 + ssize);
        if (dsize > index2)
            memcpy( get_txt(rs) + dest->index2, get_txt(ds) + index2
                  , (size_t)(dsize - index2));
        dest->size = rsize;
        free_mstring(ds);
        free_mstring(ds);
        /* we will have two references to rs */
        ref_mstring(rs);
        dest->v.u.str = dsvp->u.str = rs;

        if (do_free)
            free_string_svalue(source);
    }
    else
    {
        /* Not a string: just free it */
        if (do_free)
            free_svalue(source);
    }
} /* transfer_protected_string_range() */

/*-------------------------------------------------------------------------*/
static void
add_number_to_lvalue (svalue_t *dest, int i, svalue_t *pre, svalue_t *post)

/* Add the number <i> to the (PROTECTED_)LVALUE <dest>.
 * If <pre> is not null, the <dest> value before the addition is copied
 * into it.
 * If <post> is not null, the <dest> value after the addition is copied
 * into it.
 * Both <pre> and <post> are supposed to be empty svalues when given.
 *
 * If <dest> is of the wrong type, an error is generated.
 */

{
    /* Deref the T_(PROTECTED_)LVALUES */
    do
        dest = dest->u.lvalue;
    while (dest->type == T_LVALUE || dest->type == T_PROTECTED_LVALUE);

    /* Now increment the non-LVALUE */
    switch (dest->type)
    {
    default:
        errorf("Reference to bad type %s to ++/--\n", typename(dest->type));
        break;

    case T_NUMBER:
        if (pre) put_number(pre, dest->u.number);
        dest->u.number += i;
        if (post) put_number(post, dest->u.number);
        break;

    case T_FLOAT:
      {
        STORE_DOUBLE_USED
        double d;

        d = READ_DOUBLE(dest);

        if (pre)
        {
            pre->type = T_FLOAT;
            STORE_DOUBLE(pre, d);
        }

        d += (double)i;
        STORE_DOUBLE(dest, d);

        if (post)
        {
            post->type = T_FLOAT;
            STORE_DOUBLE(post, d);
        }
        break;
      }

    case T_PROTECTED_LVALUE:
        add_number_to_lvalue(dest, i, pre, post);
        break;

    case T_CHAR_LVALUE:
        if (pre) put_number(pre, (unsigned char)*dest->u.charp);
        *(dest->u.charp) += i;
        if (post) put_number(post, (unsigned char)*dest->u.charp);
        break;

    case T_PROTECTED_CHAR_LVALUE:
      {
        struct protected_char_lvalue *p;

        p = (struct protected_char_lvalue *)dest;
        if (p->lvalue->type == T_STRING
         && get_txt(p->lvalue->u.str) == p->start)
        {
            if (pre) put_number(pre, (unsigned char)*(p->v.u.charp));
            i = (unsigned char)(*(p->v.u.charp) += i);
            if (post) put_number(post, i);
        }
        break;
      }
    } /* switch() */
} /* add_number_to_lvalue() */

/*-------------------------------------------------------------------------*/
static vector_t *
inter_add_array (vector_t *q, vector_t **vpp)

/* Append array <q> to array *<vpp>. Both <q> and *<vpp> are freed,
 * the result vector (just one ref) is assigned to *<vpp> and also returned.
 *
 * <inter_sp> is supposed to point at the two vectors and will be decremented
 * by 2.
 */

{
    vector_t *p;       /* The second summand vector */
    mp_int cnt;
    vector_t *r;       /* Result vector */
    svalue_t *s, *d;   /* Pointers for copying: src and dest */
    size_t p_size, q_size;  /* Sizes of p and q */

    p = *vpp;

    /* *vpp could be in the summands, thus don't free p / q before
     * assigning.
     * On the other hand, with an uninitialized array, we musn't assign
     * before the copying is done.
     */

    p_size = VEC_SIZE(p);
    q_size = VEC_SIZE(q);
    s = p->item;

    /* Check the result size for legality - this leaves the code below
     * to deal just with out of memory conditions.
     */

    if (max_array_size && p_size + q_size > max_array_size)
    {
        errorf("Illegal array size: %zu.\n", (p_size + q_size));
    }

    /* The optimized array-adding will transfer elements around, rendering
     * the arrays on the stack inconsistent. Thus any out-of-memory
     * error must not attempt to free them - leaking them is the lesser
     * evil in this situation.
     */
    inter_sp -= 2;

    /* Out of memory might result in some memory leaks. Better that freeing
     * arrays with 0 ref count, or indigestion in garbage_collection() .
     * It will simply give some more debugging output...
     */

    /* Allocate the result vector and copy p into it.
     */
    if (!(p->ref-1))
    {
        /* p will be deallocated completely - try to optimize a bit */

        /* We try to expand the existing memory for p (without moving)
         * instead of allocating a completely new vector.
         */
        d = malloc_increment_size(p, q_size * sizeof(svalue_t));
        if ( NULL != d)
        {
            /* We got the additional memory */
            r = p;
            r->ref = 1;
            r->size = p_size + q_size;

            r->user->size_array -= p_size;
            r->user = current_object->user;
            r->user->size_array += p_size + q_size;
        } else
        /* Just allocate a new vector and memcopy p into it. */
        {
            r = allocate_uninit_array((p_int)(p_size + q_size));
            deref_array(p);
            d = r->item;
            for (cnt = (mp_int)p_size; --cnt >= 0; )
            {
                *d++ = *s++;
            }
        }
    }
    else
    {
        /* p must survive: allocate a new vector and assign the values
         * from p.
         */
        r = allocate_uninit_array((p_int)(p_size + q_size));
        deref_array(p);
        d = r->item;
        for (cnt = (mp_int)p_size; --cnt >= 0; ) {
            assign_checked_svalue_no_free (d++, s++);
        }
    }

    /* Here 'd' points to the first item to set */

    /* Add the values from q. Again, try to optimize */
    s = q->item;
    if (q->ref == 1)
    {
        for (cnt = (mp_int)q_size; --cnt >= 0; )
        {
            if (destructed_object_ref(s))
            {
                assign_svalue(s, &const0);
            }
            *d++ = *s++;
        }
        *vpp = r;
        free_empty_vector(q);
    }
    else /* q->ref > 1 */
    {
        for (cnt = (mp_int)q_size; --cnt >= 0; ) {
            assign_checked_svalue_no_free (d++, s++);
        }
        *vpp = r;

        deref_array(q);
    }

    if (!p->ref && p != q)
        free_empty_vector(p);

    return r;
} /* inter_add_array() */


/*=========================================================================*/

/*                           S T A C K                                     */

/*-------------------------------------------------------------------------*/
/* The following functions handle the pushing and popping of the
 * interpreter stack. Often functions appear in two versions: one version
 * using the global variable <inter_sp>, the other version receiving and
 * returning the old/new stack pointer as argument and result.
 *
 * Obviously, the former version can be easily called from outside the
 * interpreter, while the latter allows better optimization.
 *
 * To make things even more complicated, some of the 'slower' functions
 * are redefined with preprocessor macros to use the faster function - this
 * is meant to make the code in this module faster, but relies on certain
 * naming conventions (e.g. that 'sp' is always the local copy of the
 * stack pointer).
 *
 * TODO: Streamline the functions, given them macros as fast alternative
 * TODO:: publish them all in interpret.h and enforce their use.
 *-------------------------------------------------------------------------
 * The functions are:
 *
 * put_c_string (sp, p)
 *     Convert the C-String <p> into a mstring and put it into <sp>.
 * push_svalue(v), push_svalue_block(num,v):
 *     Push one or more svalues onto the stack.
 * pop_stack(), _drop_n_elems(n,sp):
 *     Pop (free) elements from the stack.
 * stack_overflow(sp,fp,pc):
 *     Handle a stack overflow.
 * push_referenced_mapping(m):
 *     Push a mapping onto the stack.
 * push_error_handler(h)
 *     Push an errorhandler entry onto the stack.
 */

/*-------------------------------------------------------------------------*/
void
put_c_string (svalue_t *sp, const char *p)

/* Put a copy of the C string *<p> into <sp>.
 */

{
    string_t * str;

    memsafe(str = new_mstring(p), strlen(p), "string");
    put_string(sp, str);
} /* put_c_string() */

/*-------------------------------------------------------------------------*/
void
put_c_n_string (svalue_t *sp, const char *p, size_t len)

/* Put a copy of first <len> characters of the C string *<p> into <sp>.
 */

{
    string_t * str;

    memsafe(str = new_n_mstring(p, len), len, "string");
    put_string(sp, str);
} /* put_c_n_string() */

/*-------------------------------------------------------------------------*/
void
push_svalue (svalue_t *v)

/* Push the svalue <v> onto the stack as defined by <inter_sp>.
 * Same semantic as assign_svalue_no_free().
 */

{
    assign_svalue_no_free(++inter_sp, v);
}

/*-------------------------------------------------------------------------*/
void
push_svalue_block (int num, svalue_t *v)

/* Push all <num> svalues starting at <v> onto the stack as defined by
 * <inter_sp>. Same semantic as assign_svalue_no_free().
 */

{
    svalue_t *w;

    for (w = inter_sp; --num >= 0; v++)
    {
        w++;
        assign_lrvalue_no_free(w, v);
    }
    inter_sp = w;
}

/*-------------------------------------------------------------------------*/
static INLINE void
_pop_stack (void)

/* Pop the topmost element from the stack as defined by <inter_sp>,
 * using free_svalue().
 */

{
#ifdef DEBUG
    if (inter_sp < VALUE_STACK)
        fatal("VM Stack underflow: %"PRIdMPINT" too low.\n",
              (mp_int)(VALUE_STACK - inter_sp));
#endif
    free_svalue(inter_sp--);
}

void pop_stack (void) { _pop_stack(); }

/*-------------------------------------------------------------------------*/
static INLINE svalue_t *
_pop_n_elems (int n, svalue_t *sp)

/* Pop the <n> topmost elements from the stack, currently ending at <sp>,
 * and return the new stackpointer.
 * The elements are freed using free_svalue().
 */

{
#ifdef DEBUG
    if (n < 0)
        fatal("pop_n_elems: %d elements.\n", n);
#endif
    for (; --n >= 0; )
    {
        free_svalue(sp--);
    }
    return sp;
}

svalue_t * pop_n_elems (int n, svalue_t *sp)
{ return _pop_n_elems(n, sp); }

/*-------------------------------------------------------------------------*/
static void stack_overflow (svalue_t *sp, svalue_t *fp, bytecode_p pc)
                              NORETURN;
static void
stack_overflow (svalue_t *sp, svalue_t *fp, bytecode_p pc)

/* Recover from a stack overflow by popping all the elements between the
 * current stack end <sp> and the begin of the frame <fp>.
 * The function then assigns the new <sp> == <fp> and the <pc> to the
 * corresponding inter_xx variables and generates an error.
 */

{
    if (sp >= &VALUE_STACK[SIZEOF_STACK])
        fatal("Fatal stack overflow: %"PRIdMPINT" too high.\n"
             , (mp_int)(sp - &VALUE_STACK[SIZEOF_STACK])
             );
    sp = _pop_n_elems(sp-fp, sp);
    ERROR("stack overflow\n");
}

/*-------------------------------------------------------------------------*/
void
push_referenced_mapping (mapping_t *m)

/* Push mapping <m> onto the stack as defined by <inter_sp>.
 * The refs of <m> are _not_ incremented.
 */

{
    inter_sp++;
    put_mapping(inter_sp, m);
}

/*-------------------------------------------------------------------------*/
svalue_t *
push_error_handler(void (*errorhandler)(svalue_t *), svalue_t *arg)

/* Push the <errorhandler>() with the argument <arg> as error handler
 * onto the stack.
 * This means that a new T_LVALUE is created on the stack, pointing
 * to <arg>. <arg> itself is setup to be a T_ERROR_HANDLER value.
 * Returns new inter_sp.
 */

{
    arg->type = T_ERROR_HANDLER;
    arg->u.error_handler = errorhandler;

    inter_sp++;
    inter_sp->type = T_LVALUE;
    inter_sp->u.lvalue = arg;
    return inter_sp;
} /* push_error_handler() */

/*-------------------------------------------------------------------------*/
/* Fast version of several functions, must come last so to not disturb
 * the actual definitions:
 */

#define pop_stack()             free_svalue(sp--)
#define pop_n_elems(n)          (sp = _pop_n_elems((n), sp))

/*=========================================================================*/

/*                          I N D E X I N G                                */

/*-------------------------------------------------------------------------*/
/* The following functions are concerned with the indexing of single
 * elements and ranges of strings, vectors and mappings, both as rvalue
 * and lvalue.
 *
 * Most of the functions are just the implementations of the corresponding
 * machine operators and are called just from the interpreter switch().
 * The actual arguments are pulled from the vm stack and the results pushed;
 * the functions receive the current stackpointer and programcounter as
 * function call parameters. The program counter is usally only used to
 * update <inter_pc> in case of errors. Result of the call is the new
 * stackpointer pointing to the result on the machine stack.
 *
 * Some typical layouts:
 *
 *     (LVALUE) -> indexed svalue from vector/mapping
 *                 (might be copied into indexing_quickfix)
 *
 *       by: push_(r)indexed_lvalue()
 *           (r)index_lvalue()
 *
 *
 *     (LVALUE) -> (CHAR_LVALUE)
 *                 special_lvalue.u.charp -> character in untabled string
 *
 *       by: (r)index_lvalue() on string lvalues
 *
 *
 *     (LVALUE) -> (PROTECTED_LVALUE) -> indexed svalue in vector/mapping
 *                 protector          -> vector/mapping
 *       by: push_protected_(r)indexed_lvalue()
 *           push_protected_indexed_map_lvalue()
 *           protected_(r)index_lvalue()
 *
 *
 *     (LVALUE) -> (PROTECTED_CHAR_LVALUE)
 *                    .lvalue -> untabled string svalue
 *                    .charp -> indexed character in untabled string
 *                    .start  -> first character of actual string text
 *                    .protector: T_INVALID or the string's .protector value
 *                                if the string itself is result of a protected
 *                                lvalue index.
 *
 *       by: protected_(r)index_lvalue() on string lvalue
 *
 *
 *     (LVALUE) -> (T_{STRING,POINTER}_RANGE_LVALUE)
 *                   special_lvalue.v   -> indexed-on string/vector
 *                   special_lvalue.size:  size of the string/vector
 *                                 .ind1:  lower index
 *                                 .ind2:  upper index
 *
 *       by: range_lvalue()
 *
 *
 *     (LVALUE) -> (T_PROTECTED_{STRING,POINTER}_RANGE_LVALUE)
 *                   .v   :   indexed-on string/vector
 *                   .lvalue -> svalue of indexed-on string/vector
 *                   .size:  size of the string/vector
 *                   .ind1:  lower index
 *                   .ind2:  upper index
 *                   .protector: the protector of the initial lvalue, if any.
 *
 *       by: protected_range_lvalue()
 *
 *
 * TODO: A lot of the functions differ only in minute details - test how
 * TODO:: much time merging the functions (and adding if()s for the
 * TODO:: differences) really costs.
 *-------------------------------------------------------------------------
 * The functions (in a LPCish notation) are:
 *
 *   push_indexed_lvalue(vector|mapping v, int|mixed i)
 *     Return &(v[i]), unprotected.
 *   push_rindexed_lvalue(vector v, int i)
 *     Return &(v[<i]), unprotected.
 *   push_aindexed_lvalue(vector v, int i)
 *     Return &(v[>i]), unprotected.
 *   push_protected_indexed_lvalue(vector|mapping v, int|mixed i)
 *     Return &(v[i]), protected.
 *   push_protected_rindexed_lvalue(vector v, int i)
 *     Return &(v[<i]), protected.
 *   push_protected_aindexed_lvalue(vector v, int i)
 *     Return &(v[>i]), protected.
 *   push_protected_indexed_map_lvalue(mapping m, mixed i, int j)
 *     Return &(m[i:j]), protected.
 *   index_lvalue(vector|mapping|string & v, int|mixed i)
 *     Return &(*v[i]), unprotected, using special_lvalue.
 *   rindex_lvalue(vector|string & v, int i)
 *     Return &(*v[<i]), unprotected, using special_lvalue.
 *   aindex_lvalue(vector|string & v, int i)
 *     Return &(*v[>i]), unprotected, using special_lvalue.
 *   protected_index_lvalue(vector|mapping|string & v, int|mixed i)
 *     Return &(*v[i]), protected.
 *   protected_rindex_lvalue(vector|string & v, int i)
 *     Return &(*v[<i]), protected.
 *   protected_aindex_lvalue(vector|string & v, int i)
 *     Return &(*v[>i]), protected.
 *   range_lvalue(vector|string & v, int i2, int i1)
 *     Return &(*v[i1..i2]), unprotected, using special_lvalue.
 *   protected_range_lvalue(vector|string & v, int i2, int i1)
 *     Return &(*v[i1..i2]), protected.
 *   push_indexed_value(string|vector|mapping|struct v, int|mixed i)
 *     Return v[i].
 *   push_rindexed_value(string|vector v, int i)
 *     Return v[<i].
 *   push_aindexed_value(string|vector v, int i)
 *     Return v[>i].
 */

/*-------------------------------------------------------------------------*/
static INLINE svalue_t *
get_vector_item (vector_t * vec, svalue_t * i, svalue_t *sp, bytecode_p pc)

/* Index vector <vec> with index <i> and return the pointer to the
 * indexed item.
 * If the index is invalid, throw an error.
 */

{
    p_int ind;
    svalue_t * item;

    if (i->type != T_NUMBER)
    {
        ERRORF(("Illegal index for []: got %s, expected number.\n"
               , typename(i->type)
               ));
        return NULL;
    }
    else
    {
        ind = i->u.number;
        if (ind < 0)
        {
            ERROR("Illegal index for []: not a positive number.\n");
            /* NOTREACHED */
            return NULL;
        }
        if (ind >= VEC_SIZE(vec))
        {
            ERRORF(("Index for [] out of bounds: %"PRIdPINT
                    ", vector size: %"PRIdPINT"\n"
                   , ind, VEC_SIZE(vec)));
            /* NOTREACHED */
            return NULL;
        }
    }

    /* Compute the indexed element */
    item = &vec->item[ind];
    if (destructed_object_ref(item))
    {
        free_svalue(item);
        put_number(item, 0);
    }

    return item;
} /* get_vector_item() */

/*-------------------------------------------------------------------------*/
static INLINE svalue_t *
get_vector_r_item (vector_t * vec, svalue_t * i, svalue_t *sp, bytecode_p pc)

/* Reverse-index vector <vec> with index <i> and return the pointer to the
 * indexed item.
 * If the index is invalid, throw an error.
 */

{
    p_int ind;
    svalue_t * item;

    if (i->type != T_NUMBER)
    {
        ERRORF(("Illegal index for [<]: got %s, expected number.\n"
               , typename(i->type)
               ));
        return NULL;
    }
    if ((ind = i->u.number) < 0)
    {
        ERROR("Illegal index for [<]: not a positive number.\n");
        return NULL;
    }
    if ( (ind = VEC_SIZE(vec) - ind) < 0
     ||  ind >= VEC_SIZE(vec)
       )
    {
        ERRORF(("Index out of bounds for [<]: %"PRIdPINT", vector size: %"
                PRIdPINT".\n", i->u.number, VEC_SIZE(vec)));
        return NULL;
    }

    /* Compute the indexed element */
    item = &vec->item[ind];
    if (destructed_object_ref(item))
    {
        free_svalue(item);
        put_number(item, 0);
    }

    return item;
} /* get_vector_r_item() */

/*-------------------------------------------------------------------------*/
static INLINE svalue_t *
get_vector_a_item (vector_t * vec, svalue_t * i, svalue_t *sp, bytecode_p pc)

/* Arithmetic-index vector <vec> with index <i> and return the pointer to the
 * indexed item.
 * If the index is invalid, throw an error.
 */

{
    p_int ind;
    svalue_t * item;

    if (i->type != T_NUMBER)
    {
        ERRORF(("Illegal index for [>]: got %s, expected number.\n"
               , typename(i->type)
               ));
        return NULL;
    }
    if (0 > (ind = i->u.number))
        ind = VEC_SIZE(vec) + ind;
    if (ind < 0 || ind >= VEC_SIZE(vec))
    {
        ERRORF(("Index out of bounds for [>]: %"PRIdPINT", vector size: %"
                PRIdPINT".\n"
               , i->u.number, VEC_SIZE(vec)));
        return NULL;
    }

    /* Compute the indexed element */
    item = &vec->item[ind];
    if (destructed_object_ref(item))
    {
        free_svalue(item);
        put_number(item, 0);
    }

    return item;
} /* get_vector_a_item() */

/*-------------------------------------------------------------------------*/
static INLINE char *
get_string_item ( svalue_t * svp, svalue_t * i, Bool make_singular
                , Bool allow_one_past
                , svalue_t *sp, bytecode_p pc)

/* Index string <svp> with index <i> and return the pointer to the
 * indexed item.
 * If <make_singular> is TRUE, <svp> is made an untabled string
 * with just one reference.
 * If <allow_one_past> is TRUE, indexing one past the official end
 * of the string for retrieval purposes is ok. TODO: Remove this.
 * If the index is invalid, throw an error.
 */

{
    mp_int ind;

    if (i->type != T_NUMBER)
    {
        ERRORF(("Illegal index for []: got %s, expected number.\n"
               , typename(i->type)
               ));
        return NULL;
    }
    else
    {
        ind = i->u.number;
        if (ind < 0)
        {
            ERROR("Illegal index for []: not a positive number.\n");
            return NULL;
        }

        if (ind > (mp_int)mstrsize(svp->u.str) )
        {
            ERRORF(("Index out for [] of bounds: %"PRIdMPINT
                    ", string length: %zu.\n"
                   , ind, mstrsize(svp->u.str)));
            return NULL;
        }

        if (ind == (mp_int)mstrsize(svp->u.str))
        {
            if (!allow_one_past)
            {
                ERRORF(("Index out of bounds for []: %"PRIdMPINT
                        ", string length: %zu.\n"
                       , ind, mstrsize(svp->u.str)));
                return NULL;
            }
            else if (!runtime_no_warn_deprecated)
                warnf( "Warning: Indexing past string end is deprecated: "
                       "index %"PRIdMPINT", string length: %zu.\n"
                     , ind, mstrsize(svp->u.str)
                     );
        }
    }

    /* The basic idea here was to to create a new copy of the string only
     * if the string is not singular (aka !mstr_singular(svp->u.str)).
     * Unfortunately local variable lvalues are pushed without counting
     * the additional reference, so we now have to play it safe and
     * duplicate the string whenever requested.
     */
    if (make_singular)
    {
        string_t *p;

        memsafe(p = unshare_mstring(svp->u.str), mstrsize(svp->u.str)
               , "modifiable string");
        svp->u.str = p;
    }

    return &(get_txt(svp->u.str)[ind]);
} /* get_string_item() */

/*-------------------------------------------------------------------------*/
static INLINE char *
get_string_r_item (svalue_t * svp, svalue_t * i, Bool make_singular
                  , Bool allow_one_past
                  , svalue_t *sp, bytecode_p pc)

/* Reverse-Index string <svp> with index <i> and return the pointer to the
 * indexed item.
 * If <allow_one_past> is TRUE, indexing one past the official end
 * of the string for retrieval purposes is ok. TODO: Remove this.
 * If <make_singular> is TRUE, <svp> is made an untabled string
 * with just one reference.
 * If the index is invalid, throw an error.
 */

{
    mp_int ind;

    if (i->type != T_NUMBER)
    {
        ERRORF(("Illegal index for [<]: got %s, expected number.\n"
               , typename(i->type)
               ));
        return NULL;
    }
    else
    {
        ind = i->u.number;
        if ((ind = i->u.number) < 0)
        {
            ERROR("Illegal index for [<]: not a positive number.\n");
            return NULL;
        }

        /* Compute the real index. Allow ""[<1]. */
        ind = (mp_int)mstrsize(svp->u.str) - ind;
        if (!mstrsize(svp->u.str) && ind == -1)
            ind = 0;

        if ( ind < 0
         ||  ind > (mp_int)mstrsize(svp->u.str)
           )
        {
            ERRORF(("Index out of bounds for [<]: %"PRIdPINT
                    ", string length: %zu\n"
                   , i->u.number, mstrsize(svp->u.str)));
            return NULL;
        }

        if (ind == (mp_int)mstrsize(svp->u.str))
        {
            if (!allow_one_past)
            {
                ERRORF(("Index out for [<] of bounds: %"PRIdMPINT
                        ", string length: %zu.\n"
                       , ind, mstrsize(svp->u.str)));
                return NULL;
            }
            else if (!runtime_no_warn_deprecated)
                warnf( "Warning: Indexing past string end is deprecated: "
                       "index %"PRIdMPINT", string length: %zu.\n"
                     , ind, mstrsize(svp->u.str)
                     );
        }
    }

    /* The basic idea here was to to create a new copy of the string only
     * if the string is not singular (aka !mstr_singular(svp->u.str)).
     * Unfortunately local variable lvalues are pushed without counting
     * the additional reference, so we now have to play it safe and
     * duplicate the string whenever requested.
     */
    if (make_singular)
    {
        string_t *p;

        memsafe(p = unshare_mstring(svp->u.str), mstrsize(svp->u.str)
               , "modifiable string");
        svp->u.str = p;
    }

    return &(get_txt(svp->u.str)[ind]);
} /* get_string_r_item() */

/*-------------------------------------------------------------------------*/
static INLINE char *
get_string_a_item (svalue_t * svp, svalue_t * i, Bool make_singular
                  , Bool allow_one_past
                  , svalue_t *sp, bytecode_p pc)

/* Arithmetic-Index string <svp> with index <i> and return the pointer to the
 * indexed item.
 * If <allow_one_past> is TRUE, indexing one past the official end
 * of the string for retrieval purposes is ok. TODO: Remove this.
 * If <make_singular> is TRUE, <svp> is made an untabled string
 * with just one reference.
 * If the index is invalid, throw an error.
 */

{
    mp_int ind;

    if (i->type != T_NUMBER)
    {
        ERRORF(("Illegal index for [>]: got %s, expected number.\n"
               , typename(i->type)
               ));
        return NULL;
    }
    else
    {
        ind = i->u.number;

        if (0 > ind)
        {
            /* Compute the real index. Allow ""[<1]. */
            ind = (mp_int)mstrsize(svp->u.str) + ind;
            if (!mstrsize(svp->u.str) && ind == -1)
                ind = 0;
        }
        if (ind < 0 || ind > (mp_int)mstrsize(svp->u.str))
        {
            ERRORF(("Index out of bounds for [>]: %"PRIdPINT
                    ", string length: %zu\n"
                   , i->u.number, mstrsize(svp->u.str)));
            return NULL;
        }

        if (ind == (mp_int)mstrsize(svp->u.str))
        {
            if (!allow_one_past)
            {
                ERRORF(("Index out for [>] of bounds: %"PRIdMPINT
                        ", string length: %zu.\n"
                       , ind, mstrsize(svp->u.str)));
                return NULL;
            }
            else if (!runtime_no_warn_deprecated)
                warnf( "Warning: Indexing past string end is deprecated: "
                       "index %"PRIdMPINT", string length: %zu.\n"
                     , ind, mstrsize(svp->u.str)
                     );
        }
    }

    /* The basic idea here was to to create a new copy of the string only
     * if the string is not singular (aka !mstr_singular(svp->u.str)).
     * Unfortunately local variable lvalues are pushed without counting
     * the additional reference, so we now have to play it safe and
     * duplicate the string whenever requested.
     */
    if (make_singular)
    {
        string_t *p;

        memsafe(p = unshare_mstring(svp->u.str), mstrsize(svp->u.str)
               , "modifiable string");
        svp->u.str = p;
    }

    return &(get_txt(svp->u.str)[ind]);
} /* get_string_a_item() */

#ifdef USE_STRUCTS
/*-------------------------------------------------------------------------*/
static INLINE svalue_t *
check_struct_op (svalue_t * sp, int off_type, int off_value, bytecode_p pc)

/* On the stack are the arguments for a struct indexing operation.
 * In particular: sp[<off_type>]:  the struct type index <idx>
 *               sp[<off_value>]:    <off_value> <= 0: the struct value to idx.
 *               sp[-<off_value>+1]: <off_value> >  0: the struct Lvalue to idx.
 *
 * Check the validity of the indexing operation and thrown an error
 * if invalid.
 *
 * <idx> gives the index of the expected struct type - the
 * operator accepts a struct of this type, or any of its children.
 * An negative <idx> accepts any struct.
 *
 * On success, the <idx> svalue is removed from the stack and the
 * new stack pointer is returned.
 */

{
    short s_index;
    svalue_t * svp;

    /* These two errors can happen with careless funcall(#'->)s */
    if (sp[off_type].type != T_NUMBER)
        ERRORF(("Illegal struct type value: %s, expected a number.\n"
               , typename(sp[off_type].type)
              ));
    if (sp[off_type].u.number >= 0
     && sp[off_type].u.number >= current_prog->num_structs)
    {
        ERRORF(("Too big struct index: %"PRIdPINT", max %hu\n"
               , sp[off_type].u.number, current_prog->num_structs
              ));
    }

    /* Get the struct type index */
    s_index = (short)sp[off_type].u.number;

    if (off_value <= 0 && sp[off_value].type != T_STRUCT)
    {
        ERRORF(("Illegal type to struct->(): %s, expected struct.\n"
               , typename(sp[off_type].type)
              ));
        /* NOTREACHED */
    }

    /* Get the reference to struct svalue to index */

    if (off_value > 0)
    {
        svp = &sp[-off_value+1];

        if (svp->type != T_LVALUE && svp->type != T_PROTECTED_LVALUE)
        {
            ERRORF(("Illegal type to lvalue struct->(): %s value, "
                    "expected struct lvalue.\n"
                   , typename(svp->type)
                  ));
            /* NOTREACHED */
        }

        while (svp->type == T_LVALUE || svp->type == T_PROTECTED_LVALUE)
            svp = svp->u.lvalue;
        if (svp->type != T_STRUCT)
        {
            if (svp->type == T_NUMBER && !svp->u.number)
                ERRORF(("Illegal type to lvalue struct->(): number 0, "
                        "expected struct.\n"
                      ));
            else
                ERRORF(("Illegal type to lvalue struct->(): %s, "
                        "expected struct.\n"
                       , typename(svp->type)
                      ));
            /* NOTREACHED */
        }
    }
    else
        svp = &sp[off_value];

    /* Check if the struct on the stack is of the correct type */
    if (s_index >= 0)
    {
        struct_type_t * pExpected = current_prog->struct_defs[s_index].type;
        struct_type_t * pType = svp->u.strct->type;

        if (!struct_baseof(pExpected, pType))
        {
            string_t * got_name, * exp_name;

            got_name = struct_unique_name(svp->u.strct);
            if (!got_name)
                got_name = struct_name(svp->u.strct);

            exp_name = struct_t_unique_name(pExpected);
            if (!exp_name)
                exp_name = struct_t_name(pExpected);

            ERRORF(("Illegal type to%s struct->(): struct %s, "
                    "expected struct %s.\n"
                   , off_value > 0 ? " lvalue" : ""
                   , get_txt(got_name)
                   , get_txt(exp_name)
                  ));
        }
    }

    /* Remove the type index entry from the stack */
    if (off_type != 0)
    {
        for ( ; off_type < 0; off_type++)
            sp[off_type] = sp[off_type+1];
    }

    return sp-1;
} /* check_struct_op() */

/*-------------------------------------------------------------------------*/
static INLINE svalue_t *
get_struct_item (struct_t * st, svalue_t * i, svalue_t *sp, bytecode_p pc)

/* Index struct <st> with index <i> and return the pointer to the
 * indexed item.
 * If the index is invalid, throw an error.
 */

{
    p_int ind;
    svalue_t * item;

    if (i->type == T_SYMBOL || i->type == T_STRING)
    {
        ind = struct_find_member(st->type, i->u.str);
        if (ind < 0)
        {
            ERRORF(("Illegal struct '%s'->(): member '%s' not found.\n"
                   , get_txt(struct_name(st))
                   , get_txt(i->u.str)
                   ));
            /* NOTREACHED */
            return NULL;
        }
    }
    else if (i->type != T_NUMBER)
    {
        ERRORF(("Illegal struct '%s'->(): got %s, "
                "expected number/string/symbol.\n"
               , get_txt(struct_name(st))
               , typename(i->type)
               ));
        return NULL;
    }
    else
    {
        ind = i->u.number;
        if (ind < 0)
        {
            ERRORF(("Illegal struct '%s'->(): not a positive number.\n"
                   , get_txt(struct_name(st))
                  ));
            /* NOTREACHED */
            return NULL;
        }
        if (ind >= struct_size(st))
        {
            ERRORF(("Illegal struct '%s'->: out of bounds: "
                    "%"PRIdPINT", struct sized: %lu.\n"
                   , get_txt(struct_name(st))
                   , ind
                   , (unsigned long)struct_size(st)
                  ));
            /* NOTREACHED */
            return NULL;
        }
    }

    /* Compute the indexed element */
    item = &st->member[ind];
    if (destructed_object_ref(item))
    {
        free_svalue(item);
        put_number(item, 0);
    }

    return item;
} /* get_struct_item() */
#endif /* USE_STRUCTS */

/*-------------------------------------------------------------------------*/
static INLINE svalue_t *
push_indexed_lvalue (svalue_t *sp, bytecode_p pc)

/* Operator F_PUSH_INDEXED_LVALUE(vector  v=sp[-1], int   i=sp[0])
 * Operator F_PUSH_INDEXED_LVALUE(mapping v=sp[-1], mixed i=sp[0])
 * Operator F_PUSH_INDEXED_S_LVALUE(struct v=sp[-1], mixed i=sp[0])
 *
 * Compute the lvalue &(v[i]) and push it into the stack. If v has just
 * one ref left, the indexed item is stored in indexing_quickfix and the
 * lvalue refers to that variable.
 * TODO: indexing_quickfix could be implemented using protected lvalues.
 */

{
    svalue_t *i;     /* the index value */
    svalue_t *vec;   /* the indexed vector or mapping */

    /* Get the arguments */
    i = sp;
    vec = sp - 1;

    /* Index a vector.
     */
    if (vec->type == T_POINTER)
    {
        svalue_t *item;

        item = get_vector_item(vec->u.vec, i, sp, pc);

        if (vec->u.vec->ref == 1)
        {
            /* Rescue the indexed item as vec will go away */
            assign_svalue (&indexing_quickfix, item);
            item = &indexing_quickfix;
        }

        /* Remove the arguments from the stack */
        sp = vec;
        free_array(vec->u.vec);

        /* Return the result */
        vec->type = T_LVALUE;
        vec->u.lvalue = item;
        return sp;
    }

#ifdef USE_STRUCTS
    /* Index a struct.
     */
    if (vec->type == T_STRUCT)
    {
        struct_t * st = vec->u.strct;
        svalue_t * item;

        item = get_struct_item(st, i, sp, pc);

        if (st->ref == 1)
        {
            /* Rescue the indexed item as st will go away */
            assign_svalue (&indexing_quickfix, item);
            item = &indexing_quickfix;
        }

        /* Remove the arguments from the stack */
        free_svalue(sp); sp--;
        free_struct(st);

        /* Return the result */
        sp->type = T_LVALUE;
        sp->u.lvalue = item;
        return sp;
    }
#endif /* USE_STRUCTS */

    /* Index a mapping
     */
    if (vec->type == T_MAPPING)
    {
        mapping_t *m;
        svalue_t *item;

        m = vec->u.map;

        if (!m->num_values)
        {
            ERROR("Indexing a mapping of width 0.\n");
            return NULL;
        }

        /* Compute the indexed element */

        item = get_map_lvalue(m, i);
        if (!item)
        {
            outofmemory("indexed lvalue");
            /* NOTREACHED */
            return NULL;
        }

        if (m->ref == 1)
        {
            /* Rescue the indexed item as vec will go away */
            assign_svalue (&indexing_quickfix, item);
            item = &indexing_quickfix;
        }

        /* Remove the arguments from the stack */
        free_svalue(sp--);
        free_mapping(m);

        /* Return the result */
        vec->type = T_LVALUE;
        vec->u.lvalue = item;
        return sp;
    }

    /* Illegal type to index */
    inter_sp = sp;
    inter_pc = pc;
    errorf("(lvalue1)Indexing on illegal type '%s'.\n", typename(vec->type));
    return sp;
} /* push_indexed_lvalue() */

/*-------------------------------------------------------------------------*/
static INLINE svalue_t *
push_rindexed_lvalue (svalue_t *sp, bytecode_p pc)

/* Operator F_PUSH_RINDEXED_LVALUE(vector v=sp[-1], int i=sp[0])
 *
 * Compute the lvalue &(v[<i]) and push it into the stack. If v has just
 * one ref left, the indexed item is stored in indexing_quickfix and the
 * lvalue refers to that variable.
 */

{
    svalue_t *i;     /* the index value */
    svalue_t *vec;   /* the vector */

    /* Get the arguments */
    i = sp;
    vec = sp - 1;

    /* Index a vector.
     */
    if (vec->type == T_POINTER)
    {
        svalue_t *item;

        item = get_vector_r_item(vec->u.vec, i, sp, pc);

        if (vec->u.vec->ref == 1)
        {
            /* Rescue the indexed item as vec will go away */
            assign_svalue (&indexing_quickfix, item);
            item = &indexing_quickfix;
        }

        /* Remove the arguments from the stack */
        sp = vec;
        free_array(vec->u.vec);

        /* Return the result */
        vec->type = T_LVALUE;
        vec->u.lvalue = item;
        return sp;
    }

    /* Indexing on illegal type */
    inter_sp = sp;
    inter_pc = pc;
    errorf("(lvalue2)Indexing on illegal type '%s'.\n", typename(vec->type));
    return NULL;
} /* push_rindexed_lvalue() */

/*-------------------------------------------------------------------------*/
static INLINE svalue_t *
push_aindexed_lvalue (svalue_t *sp, bytecode_p pc)

/* Operator F_PUSH_AINDEXED_LVALUE(vector v=sp[-1], int i=sp[0])
 *
 * Compute the lvalue &(v[>i]) and push it into the stack. If v has just
 * one ref left, the indexed item is stored in indexing_quickfix and the
 * lvalue refers to that variable.
 */

{
    svalue_t *i;     /* the index value */
    svalue_t *vec;   /* the vector */

    /* Get the arguments */
    i = sp;
    vec = sp - 1;

    /* Index a vector.
     */
    if (vec->type == T_POINTER)
    {
        svalue_t *item;

        item = get_vector_a_item(vec->u.vec, i, sp, pc);

        if (vec->u.vec->ref == 1)
        {
            /* Rescue the indexed item as vec will go away */
            assign_svalue (&indexing_quickfix, item);
            item = &indexing_quickfix;
        }

        /* Remove the arguments from the stack */
        sp = vec;
        free_array(vec->u.vec);

        /* Return the result */
        vec->type = T_LVALUE;
        vec->u.lvalue = item;
        return sp;
    }

    /* Indexing on illegal type */
    inter_sp = sp;
    inter_pc = pc;
    errorf("(lvalue3)Indexing on illegal type '%s'.\n", typename(vec->type));
    return NULL;
} /* push_aindexed_lvalue() */

/*-------------------------------------------------------------------------*/
/* void BUILD_MAP_PROTECTOR(svalue_t *dest, mapping_t *m)
 *
 * Init svalue <dest> to protectively hold mapping <m> in which one entry
 * is about to be used as target for a lvalue.
 *
 * If mapping <m> is dirty, protect its hash_mapping part by incrementing
 * its refcount (and if this is the first call, also initialize the .deleted
 * entry), and by making the svalue a T_PROTECTOR_MAPPING.
 *
 * If <m> is not dirty, not protection is necessary.
 */
#define BUILD_MAP_PROTECTOR(dest, m)     \
{                                        \
    mapping_hash_t *hm;                  \
                                         \
    if ( NULL != (hm = (m)->hash) ) {    \
        if (!hm->ref++)                  \
            hm->deleted = NULL;          \
        dest.type = T_PROTECTOR_MAPPING; \
    } else {                             \
        dest.type = T_MAPPING;           \
    }                                    \
    dest.u.map = m;                      \
}

/*-------------------------------------------------------------------------*/
static INLINE svalue_t *
push_protected_indexed_lvalue (svalue_t *sp, bytecode_p pc)

/* Op. F_PUSH_PROTECTED_INDEXED_LVALUE(vector  v=sp[-1], int   i=sp[0])
 * Op. F_PUSH_PROTECTED_INDEXED_LVALUE(mapping v=sp[-1], mixed i=sp[0])
 * Op. F_PUSH_PROTECTED_INDEXED_S_LVALUE(struct  v=sp[-1], mixed i=sp[0])
 *
 * Compute the lvalue &(v[i]), store it in a struct protected_lvalue, and
 * push the protector as PROTECTED_LVALUE into the stack.
 */

{
    svalue_t           * i;       /* the index */
    svalue_t           * vec;     /* the vector */

    /* Get the arguments */
    i = sp;
    vec = sp - 1;

    /* Index a vector.
     */
    if (vec->type == T_POINTER)
    {
        svalue_t *item;
        struct protected_lvalue * lvalue;

        item = get_vector_item(vec->u.vec, i, sp, pc);

        /* Compute the indexed item and set up the protector */

        lvalue = (struct protected_lvalue *)xalloc(sizeof *lvalue);
        lvalue->v.type = T_PROTECTED_LVALUE;
        lvalue->v.u.lvalue = item;
        put_array(&(lvalue->protector), vec->u.vec);
          /* The one ref to vec is transferred from *vec */

        /* Remove the arguments and return the result */
        sp = vec;
        vec->type = T_LVALUE;
        vec->u.lvalue = &lvalue->v;
        return sp;
    }

#ifdef USE_STRUCTS
    /* Index a struct.
     */
    if (vec->type == T_STRUCT)
    {
        struct_t * st = vec->u.strct;
        svalue_t * item;
        struct protected_lvalue * lvalue;

        item = get_struct_item(st, i, sp, pc);

        /* Item and set up the protector */

        lvalue = (struct protected_lvalue *)xalloc(sizeof *lvalue);
        lvalue->v.type = T_PROTECTED_LVALUE;
        lvalue->v.u.lvalue = item;
        put_struct(&(lvalue->protector), st);
          /* The one ref to st is transferred from *vec */

        /* Remove the arguments and return the result */
        free_svalue(i);
        sp = vec;
        sp->type = T_LVALUE;
        sp->u.lvalue = &lvalue->v;
        return sp;
    }
#endif /* USE_STRUCTS */

    /* Index a mapping
     */
    if (vec->type == T_MAPPING)
    {
        mapping_t *m;
        svalue_t *item;
        struct protected_lvalue * lvalue;

        m = vec->u.map;

        if (!m->num_values)
        {
            ERROR("Indexing a mapping of width 0.\n");
            return NULL;
        }

        /* Compute the indexed item and set up the protector */

        item = get_map_lvalue(m, i);
        if (!item)
        {
            outofmemory("indexed lvalue");
            /* NOTREACHED */
            return NULL;
        }

        lvalue = (struct protected_lvalue *)xalloc(sizeof *lvalue);
        lvalue->v.type = T_PROTECTED_LVALUE;
        lvalue->v.u.lvalue = item;
        BUILD_MAP_PROTECTOR(lvalue->protector, m)
          /* The one ref is transferred from the stack */

        /* Remove the arguments and return the result */
        pop_stack();
        vec->type = T_LVALUE;
        vec->u.lvalue = &lvalue->v;
        return sp;
    }

    /* Indexing on illegal type. */

    inter_sp = sp;
    inter_pc = pc;
    errorf("(lvalue4)Indexing on illegal type '%s'.\n", typename(vec->type));
    return NULL;
} /* push_protected_indexed_lvalue() */

/*-------------------------------------------------------------------------*/
static INLINE svalue_t *
push_protected_rindexed_lvalue (svalue_t *sp, bytecode_p pc)

/* Op. F_PUSH_PROTECTED_RINDEXED_LVALUE(vector v=sp[-1], int i=sp[0])
 *
 * Compute the lvalue &(v[<i]), store it in a struct protected_lvalue, and
 * push the protector as PROTECTED_LVALUE into the stack.
 */

{
    svalue_t           * i;       /* the index */
    svalue_t           * vec;     /* the vector */
    struct protected_lvalue * lvalue;  /* the protector */

    /* Get the arguments */

    i = sp;
    vec = sp - 1;

    /* Index a vector
     */
    if (vec->type == T_POINTER)
    {
        svalue_t *item;

        item = get_vector_r_item(vec->u.vec, i, sp, pc);

        /* Set up the protector */

        lvalue = (struct protected_lvalue *)xalloc(sizeof *lvalue);
        lvalue->v.type = T_PROTECTED_LVALUE;
        lvalue->v.u.lvalue = item;
        put_array(&(lvalue->protector), vec->u.vec);
          /* The one ref is transferred from the stack */

        /* Remove arguments and return result */
        sp = vec;
        vec->type = T_LVALUE;
        vec->u.lvalue = &lvalue->v;
        return sp;
    }

    /* Indexing in illegal type */

    inter_sp = sp;
    inter_pc = pc;
    errorf("(lvalue5)Indexing on illegal type '%s'.\n", typename(vec->type));
    return NULL;
} /* push_protected_rindexed_lvalue() */

/*-------------------------------------------------------------------------*/
static INLINE svalue_t *
push_protected_aindexed_lvalue (svalue_t *sp, bytecode_p pc)

/* Op. F_PUSH_PROTECTED_AINDEXED_LVALUE(vector v=sp[-1], int i=sp[0])
 *
 * Compute the lvalue &(v[>i]), store it in a struct protected_lvalue, and
 * push the protector as PROTECTED_LVALUE into the stack.
 */

{
    svalue_t           * i;       /* the index */
    svalue_t           * vec;     /* the vector */
    struct protected_lvalue * lvalue;  /* the protector */

    /* Get the arguments */

    i = sp;
    vec = sp - 1;

    /* Index a vector
     */
    if (vec->type == T_POINTER)
    {
        svalue_t *item;

        item = get_vector_a_item(vec->u.vec, i, sp, pc);

        /* Setup the protector */

        lvalue = (struct protected_lvalue *)xalloc(sizeof *lvalue);
        lvalue->v.type = T_PROTECTED_LVALUE;
        lvalue->v.u.lvalue = item;
        put_array(&(lvalue->protector), vec->u.vec);
          /* The one ref is transferred from the stack */

        /* Remove arguments and return result */
        sp = vec;
        vec->type = T_LVALUE;
        vec->u.lvalue = &lvalue->v;
        return sp;
    }

    /* Indexing in illegal type */

    inter_sp = sp;
    inter_pc = pc;
    errorf("(lvalue6)Indexing on illegal type '%s'.\n", typename(vec->type));
    return NULL;
} /* push_protected_aindexed_lvalue() */

/*-------------------------------------------------------------------------*/
static INLINE svalue_t *
push_protected_indexed_map_lvalue (svalue_t *sp, bytecode_p pc)

/* Op. F_PUSH_PROTECTED_INDEXED_MAP_LVALUE(mapping m=sp[-2], mixed i=sp[-1]
 *                                                         , int   j=sp[0])
 *
 * Compute the lvalue &(m[i:j]), store it in a struct protected_lvalue, and
 * push the protector as PROTECTED_LVALUE into the stack.
 */

{
    svalue_t           * i;       /* the index */
    svalue_t           * vec;     /* the vector */
    svalue_t           * item;    /* the indexed element */
    struct protected_lvalue * lvalue;  /* the protector */

    /* Get the arguments */
    i = sp - 1;
    vec = sp - 2;

    /* Index a mapping.
     */
    if (vec->type == T_MAPPING)
    {
        mapping_t *m;

        m = vec->u.map;
        if (sp->type != T_NUMBER)
        {
            ERRORF(("Illegal subindex for []: got %s, expected number.\n"
                   , typename(sp->type)
                   ));
            return NULL;
        }
        if ((p_uint)sp->u.number >= (p_uint)m->num_values
            /* using uints automagically checks for negative indices */
           )
        {
            ERRORF(("Too big subindex for []: value %"PRIdPINT", width %"
                    PRIdPINT".\n", sp->u.number, m->num_values));
            return NULL;
        }

        /* Compute the indexed element and setup the protector */

        item = get_map_lvalue(m, i);
        if (!item)
        {
            outofmemory("indexed lvalue");
            /* NOTREACHED */
            return NULL;
        }
        item += sp->u.number;

        lvalue = (struct protected_lvalue *)xalloc(sizeof *lvalue);
        lvalue->v.type = T_PROTECTED_LVALUE;
        lvalue->v.u.lvalue = item;
        BUILD_MAP_PROTECTOR(lvalue->protector, m)
          /* The one ref is transferred from the stack */

        /* Remove the arguments and return the result */
        sp--;
        pop_stack();
        vec->type = T_LVALUE;
        vec->u.lvalue = &lvalue->v;
        return sp;
    }

    /* Indexing on illegal type */

    inter_sp = sp;
    inter_pc = pc;
    errorf("(lvalue7)Indexing on illegal type '%s'.\n", typename(vec->type));
    return NULL;
} /* push_protected_indexed_map_lvalue() */

/*-------------------------------------------------------------------------*/
static INLINE svalue_t *
index_lvalue (svalue_t *sp, bytecode_p pc)

/* Operator F_INDEX_LVALUE (string|vector &v=sp[0], int   i=sp[-1])
 *          F_INDEX_LVALUE (mapping       &v=sp[0], mixed i=sp[-1])
 *          F_INDEX_S_LVALUE (struct      &v=sp[0], mixed i=sp[-1])
 *
 * Compute the index &(v[i]) of lvalue <v> and push it into the stack. The
 * computed index is a lvalue itself.
 * If <v> is a string-lvalue, it is made a malloced string if necessary,
 * and the pushed result will be a lvalue pointing to a CHAR_LVALUE stored
 * in <special_lvalue>.
 */

{
    svalue_t *vec;   /* the vector/mapping */
    svalue_t *i;     /* the index */
    short     type;  /* type of <vec> */

    /* get the arguments */
    vec = sp;
    i = sp -1;

    /* Dereference the initial (and possibly more) lvalue-indirection
     */
    do {
        vec = vec->u.lvalue;
        type = vec->type;
    } while (type == T_LVALUE || type == T_PROTECTED_LVALUE);

    /* Index a vector.
     */
    if (type == T_POINTER)
    {
        vector_t *v = vec->u.vec;
        svalue_t *item;

        item = get_vector_item(v, i, sp, pc);

        /* Remove the arguments and push the result */

        sp = i;

        sp->type = T_LVALUE;
        sp->u.lvalue = item;
        return sp;
    }

    /* Index a string.
     */
    if (type == T_STRING)
    {
        char * cp;

        cp = get_string_item(vec, i, /* make_singular: */ MY_TRUE
                            , /* allow_one_past: */ MY_FALSE
                            , sp, pc);

        /* Remove the arguments and create and push the result. */

        sp = i;

        sp->type = T_LVALUE;
        sp->u.lvalue = &special_lvalue.v;
        special_lvalue.v.type = T_CHAR_LVALUE;
        special_lvalue.v.u.charp = cp;
        return sp;
    }

#ifdef USE_STRUCTS
    /* Index a struct.
     */
    if (type == T_STRUCT)
    {
        struct_t * st = vec->u.strct;
        svalue_t * item;

        item = get_struct_item(st, i, sp, pc);

        /* Remove the arguments and push the result */

        sp--; /* *sp is a T_LVALUE and can be dropped silently  */
        free_svalue(sp); /* This was 'i' */

        sp->type = T_LVALUE;
        sp->u.lvalue = item;
        return sp;
    }
#endif /* USE_STRUCTS */

    /* Index a mapping.
     */
    if (type == T_MAPPING)
    {
        svalue_t *item;
        mapping_t *m;

        m = vec->u.map;
        if (!m->num_values)
        {
            ERROR("Indexing a mapping of width 0.\n");
            return NULL;
        }

        /* Compute the element */
        item = get_map_lvalue(m, i);
        if (!item)
        {
            outofmemory("indexed lvalue");
            /* NOTREACHED */
            return NULL;
        }

        /* Remove the arguments and push the result. */

        sp = i;
        free_svalue(i);
        sp->type = T_LVALUE;
        sp->u.lvalue = item;
        return sp;
    }

    /* Illegal type to index. */

    inter_sp = sp;
    inter_pc = pc;
    errorf("(lvalue8)Indexing on illegal type '%s'.\n", typename(type));
    return NULL;
} /* index_lvalue() */

/*-------------------------------------------------------------------------*/
static INLINE svalue_t *
rindex_lvalue (svalue_t *sp, bytecode_p pc)

/* Operator F_RINDEX_LVALUE (string|vector &v=sp[0], int   i=sp[-1])
 *
 * Compute the index &(v[<i]) of lvalue <v> and push it into the stack. The
 * computed index is a lvalue itself.
 * If <v> is a string-lvalue, it is made a malloced string if necessary,
 * and the pushed result will be a lvalue pointing to a CHAR_LVALUE stored
 * in <special_lvalue>.
 */

{
    svalue_t *vec;   /* the vector/string */
    svalue_t *i;     /* the index */
    short     type;  /* type of <vec> */

    /* get the arguments */
    vec = sp;
    i = sp -1;

    /* Dereference the initial (and possibly more) lvalue-indirection
     */
    do {
        vec = vec->u.lvalue;
        type = vec->type;
    } while (type == T_LVALUE || type == T_PROTECTED_LVALUE);

    /* Index a vector
     */
    if (type == T_POINTER)
    {
        vector_t *v = vec->u.vec;
        svalue_t *item;

        item = get_vector_r_item(v, i, sp, pc);

        /* Remove the arguments and return the result */

        sp = i;
        sp->type = T_LVALUE;
        sp->u.lvalue = item;
        return sp;
    }

    /* Index a string
     */
    if (type == T_STRING)
    {
        char * cp;

        cp = get_string_r_item(vec, i, /* make_singular: */ MY_TRUE
                              , /* allow_one_past: */ MY_FALSE
                              , sp, pc);

        /* Remove the argument and return the result */

        sp = i;
        sp->type = T_LVALUE;
        sp->u.lvalue = &special_lvalue.v;
        special_lvalue.v.type = T_CHAR_LVALUE;
        special_lvalue.v.u.charp = cp;
        return sp;
    }

    /* Indexing on illegal type */

    inter_sp = sp;
    inter_pc = pc;
    errorf("(lvalue9)Indexing on illegal type '%s'.\n", typename(type));
    return NULL;
} /* rindex_lvalue() */

/*-------------------------------------------------------------------------*/
static INLINE svalue_t *
aindex_lvalue (svalue_t *sp, bytecode_p pc)

/* Operator F_AINDEX_LVALUE (string|vector &v=sp[0], int   i=sp[-1])
 *
 * Compute the index &(v[>i]) of lvalue <v> and push it into the stack. The
 * computed index is a lvalue itself.
 * If <v> is a string-lvalue, it is made a malloced string if necessary,
 * and the pushed result will be a lvalue pointing to a CHAR_LVALUE stored
 * in <special_lvalue>.
 */

{
    svalue_t *vec;   /* the vector/string */
    svalue_t *i;     /* the index */
    short     type;  /* type of <vec> */

    /* get the arguments */
    vec = sp;
    i = sp -1;

    /* Dereference the initial (and possibly more) lvalue-indirection
     */
    do {
        vec = vec->u.lvalue;
        type = vec->type;
    } while (type == T_LVALUE || type == T_PROTECTED_LVALUE);

    /* Index a vector
     */
    if (type == T_POINTER)
    {
        vector_t *v = vec->u.vec;
        svalue_t *item;

        item = get_vector_a_item(v, i, sp, pc);

        /* Remove the arguments and return the result */

        sp = i;
        sp->type = T_LVALUE;
        sp->u.lvalue = item;
        return sp;
    }

    /* Index a string
     */
    if (type == T_STRING)
    {
        char * cp;

        cp = get_string_a_item(vec, i, /* make_singular: */ MY_TRUE
                              , /* allow_one_past: */ MY_FALSE
                              , sp, pc);

        /* Remove the argument and return the result */

        sp = i;
        sp->type = T_LVALUE;
        sp->u.lvalue = &special_lvalue.v;
        special_lvalue.v.type = T_CHAR_LVALUE;
        special_lvalue.v.u.charp = cp;
        return sp;
    }

    /* Indexing on illegal type */

    inter_sp = sp;
    inter_pc = pc;
    errorf("(lvalue10)Indexing on illegal type '%s'.\n", typename(type));
    return NULL;
} /* aindex_lvalue() */

/*-------------------------------------------------------------------------*/
static svalue_t *
protected_index_lvalue (svalue_t *sp, bytecode_p pc)

/* Operator F_PROTECTED_INDEX_LVALUE (string|vector &v=sp[0], int   i=sp[-1])
 *          F_PROTECTED_INDEX_LVALUE (mapping       &v=sp[0], mixed i=sp[-1])
 *          F_PROTECTED_INDEX_S_LVALUE (struct      &v=sp[0], mixed i=sp[-1])
 *
 * Compute the index &(*v[i]) of lvalue <v>, wrap it into a protector, and push
 * the reference to the protector as PROTECTED_LVALUE onto the stack.
 *
 * If <v> is a protected non-string-lvalue, the protected_lvalue referenced
 * by <v>.u.lvalue will be deallocated, and the protector itself will be
 * stored in <last_indexing_protector> for the time being.
 *
 * If <v> is a string-lvalue, it is made a malloced string if necessary.
 */

{
    svalue_t *vec;   /* the indexed value */
    svalue_t *i;     /* the index */
    short     type;  /* type of <vec> */

    /* Get arguments */
    vec = sp->u.lvalue;
    i = sp -1;

    /* The loop unravels the (possible) lvalue chain starting at vec.
     * When a non-lvalue is encountered, the indexing takes place
     * the function returns.
     */
    for (;;)
    {
        type = vec->type;

        /* Index a vector.
         */
        if (type == T_POINTER)
        {
            vector_t *v = vec->u.vec;
            struct protected_lvalue *lvalue;
            svalue_t *item;

            item = get_vector_item(v, i, sp, pc);

            /* Drop the arguments */
            sp = i;

            /* Compute and return the result */

            lvalue = (struct protected_lvalue *)xalloc(sizeof *lvalue);
            lvalue->v.type = T_PROTECTED_LVALUE;
            lvalue->v.u.lvalue = item;
            put_ref_array(&(lvalue->protector), v);

            sp->type = T_LVALUE;
            sp->u.lvalue = &lvalue->v;

            return sp;
        }

#ifdef USE_STRUCTS
        /* Index a struct.
         */
        if (type == T_STRUCT)
        {
            struct_t * st = vec->u.strct;
            svalue_t * item;
            struct protected_lvalue *lvalue;

            item = get_struct_item(st, i, sp, pc);

            /* Drop the arguments */
            free_svalue(i);
            sp = i;

            /* Compute and return the result */

            lvalue = (struct protected_lvalue *)xalloc(sizeof *lvalue);
            lvalue->v.type = T_PROTECTED_LVALUE;
            lvalue->v.u.lvalue = item;
            put_ref_struct(&(lvalue->protector), st);

            sp->type = T_LVALUE;
            sp->u.lvalue = &lvalue->v;

            return sp;
        }
#endif /* USE_STRUCTS */

        /* Index a string.
         */
        if (type == T_STRING)
        {
            struct protected_char_lvalue *val;
            char * cp;

            cp = get_string_item(vec, i, /* make_singular: */ MY_TRUE
                                , /* allow_one_past: */ MY_FALSE
                                , sp, pc);

            /* Add another reference to the string to keep it alive while
             * we use it.
             */
            (void)ref_mstring(vec->u.str);

            /* Drop the arguments */
            sp = i;

            /* Compute and return the result */

            val = (struct protected_char_lvalue *)xalloc(sizeof *val);
            val->v.type = T_PROTECTED_CHAR_LVALUE;
            val->v.u.charp = cp;
            val->lvalue = vec;
            val->start = get_txt(vec->u.str);
            val->protector.type = T_INVALID;

            sp->type = T_LVALUE;
            sp->u.protected_char_lvalue = val;

            return sp;
        }

        /* Index a mapping.
         */
        if (type == T_MAPPING)
        {
            svalue_t *item;
            struct protected_lvalue *lvalue;
            mapping_t *m;

            m = vec->u.map;
            if (!m->num_values)
            {
                ERROR("Indexing a mapping of width 0.\n");
                return NULL;
            }

            /* Compute the indexed element */
            item = get_map_lvalue(m, i);
            if (!item)
            {
                outofmemory("indexed lvalue");
                /* NOTREACHED */
                return NULL;
            }

            /* Build the protector */
            ref_mapping(m);
            lvalue = (struct protected_lvalue *)xalloc(sizeof *lvalue);
            lvalue->v.type = T_PROTECTED_LVALUE;
            lvalue->v.u.lvalue = item;
            BUILD_MAP_PROTECTOR(lvalue->protector, m)

            /* Drop the arguments and return the result */
            sp = i;
            free_svalue(i);

            sp->type = T_LVALUE;
            sp->u.lvalue = &lvalue->v;

            return sp;
        }

        /* lvalues are just dereferenced.
         */
        if (type == T_LVALUE)
        {
            vec = vec->u.lvalue;
            continue;
        }

        /* Non-string protected lvalues are dereferenced, a protected
         * string lvalue is indexed immediately.
         */
        if (type == T_PROTECTED_LVALUE)
        {
            struct protected_lvalue *lvalue;
            struct protected_char_lvalue *val;
            char * cp;

            lvalue = (struct protected_lvalue *)vec;

            if (lvalue->v.u.lvalue->type != T_STRING)
            {
                /* Deref a non-string protected lvalue.
                 * If this is the lvalue passed to the operator, also free
                 * the protector structure (since its stack space will be
                 * used for the result), but keep the protector itself
                 * in a global variable.
                 */
                if (vec == sp->u.lvalue)
                {
                    free_protector_svalue(&last_indexing_protector);
                    last_indexing_protector = lvalue->protector;
                    vec = lvalue->v.u.lvalue;
                    xfree(lvalue);
                    continue;
                }

                vec = lvalue->v.u.lvalue;
                continue;
            }

            vec = lvalue->v.u.lvalue; /* it's a string... */

            cp = get_string_item(vec, i, /* make_singular: */ MY_TRUE
                                , /* allow_one_past: */ MY_FALSE
                                , sp, pc);

            /* Add another reference to the string to keep it alive while
             * we use it.
             */
            (void)ref_mstring(vec->u.str);

            /* Build the protector */
            val = (struct protected_char_lvalue *)xalloc(sizeof *val);
            val->v.type = T_PROTECTED_CHAR_LVALUE;
            val->v.u.charp = cp;
            val->lvalue = vec;
            val->start = get_txt(vec->u.str);

            /* Drop the arguments and return the result.
             * If this was the lvalue passed to the operator in the
             * first place, adopt the protecting value and free the old
             * operator structure. If not, just don't assign a protecting
             * value.
             */
            if (lvalue == sp->u.protected_lvalue)
            {
                val->protector = lvalue->protector;
                xfree(lvalue);
            }
            else
            {
                val->protector.type = T_INVALID;
            }

            sp = i;
            sp->type = T_LVALUE;
            sp->u.protected_char_lvalue = val;

            return sp;
        }

        /* Indexing on illegal type */
        inter_sp = sp;
        inter_pc = pc;
        errorf("(lvalue11)Indexing on illegal type '%s'.\n", typename(type));
        return NULL;
    } /* for(ever) */

    /* NOTREACHED */
    return NULL;
} /* protected_index_lvalue() */

/*-------------------------------------------------------------------------*/
static INLINE svalue_t *
protected_rindex_lvalue (svalue_t *sp, bytecode_p pc)

/* Operator F_PROTECTED_RINDEX_LVALUE (string|vector &v=sp[0], int   i=sp[-1])
 *
 * Compute the index &(*v[<i]) of lvalue <v>, wrap it into a protector, and
 * push the reference to the protector as PROTECTED_LVALUE onto the stack.
 *
 * If <v> is a protected non-string-lvalue, the protected_lvalue referenced
 * by <v>.u.lvalue will be deallocated, and the protector itself will be
 * stored in <last_indexing_protector> for the time being.
 *
 * If <v> is a string-lvalue, it is made a malloced string if necessary.
 */

{
    svalue_t *vec;   /* the indexed value */
    svalue_t *i;     /* the index */
    short     type;  /* type of <vec> */

    /* Get arguments */
    vec = sp->u.lvalue;
    i = sp -1;

    /* The loop unravels the (possible) lvalue chain starting at vec.
     * When a non-lvalue is encountered, the indexing takes place
     * the function returns.
     */
    for (;;)
    {
        type = vec->type;

        /* Index a vector.
         */
        if (type == T_POINTER)
        {
            vector_t *v = vec->u.vec;
            struct protected_lvalue *lvalue;
            svalue_t *item;

            item = get_vector_r_item(v, i, sp, pc);

            /* Create the protector for the result */

            lvalue = (struct protected_lvalue *)xalloc(sizeof *lvalue);
            lvalue->v.type = T_PROTECTED_LVALUE;
            lvalue->v.u.lvalue = item;
            put_ref_array(&(lvalue->protector), v);

            /* Drop the arguments and return the result */

            sp = i;

            sp->type = T_LVALUE;
            sp->u.lvalue = &lvalue->v;
            return sp;
        }

        /* Index a string.
         */
        if (type == T_STRING)
        {
            struct protected_char_lvalue *val;
            char * cp;

            cp = get_string_r_item(vec, i, /* make_singular: */ MY_TRUE
                                  , /* allow_one_past: */ MY_FALSE
                                  , sp, pc);

            /* Add another reference to the string to keep it alive while
             * we use it.
             */
            (void)ref_mstring(vec->u.str);

            /* Build the protector */
            val = (struct protected_char_lvalue *)xalloc(sizeof *val);
            val->v.type = T_PROTECTED_CHAR_LVALUE;
            val->v.u.charp = cp;
            val->lvalue = vec;
            val->start = get_txt(vec->u.str);
            val->protector.type = T_INVALID;

            /* Drop the arguments and return the result */
            sp = i;

            sp->type = T_LVALUE;
            sp->u.protected_char_lvalue = val;

            return sp;
        }

        /* lvalues are just dereferenced.
         */
        if (type == T_LVALUE)
        {
            vec = vec->u.lvalue;
            continue;
        }

        /* Non-string protected lvalues are dereferenced, a protected
         * string lvalue is indexed immediately.
         */
        if (type == T_PROTECTED_LVALUE)
        {
            struct protected_lvalue *lvalue;
            struct protected_char_lvalue *val;
            char * cp;

            lvalue = (struct protected_lvalue *)vec;

            if (lvalue->v.u.lvalue->type != T_STRING)
            {
                /* Deref a non-string protected lvalue.
                 * If this is the lvalue passed to the operator, also free
                 * the protector structure (since its stack space will be
                 * used for the result), but keep the protector itself
                 * in a global variable.
                 */
                if (vec == sp->u.lvalue)
                {
                    free_protector_svalue(&last_indexing_protector);
                    last_indexing_protector = lvalue->protector;
                    vec = lvalue->v.u.lvalue;
                    xfree(lvalue);
                    continue;
                }
                vec = lvalue->v.u.lvalue;
                continue;
            }

            vec = lvalue->v.u.lvalue; /* it's a string... */
            cp = get_string_r_item(vec, i, /* make_singular: */ MY_TRUE
                                  , /* allow_one_past: */ MY_FALSE
                                  , sp, pc);

            /* Add another reference to the string to keep it alive while
             * we use it.
             */
            (void)ref_mstring(vec->u.str);

            /* Build the protector */
            val = (struct protected_char_lvalue *)xalloc(sizeof *val);
            val->v.type = T_PROTECTED_CHAR_LVALUE;
            val->v.u.charp = cp;
            val->lvalue = vec;
            val->start = get_txt(vec->u.str);

            /* Drop the arguments and return the result.
             * If this was the lvalue passed to the operator in the
             * first place, adopt the protecting value and free the old
             * operator structure. If not, just don't assign a protecting
             * value.
             */
            if (lvalue == sp->u.protected_lvalue)
            {
                val->protector = lvalue->protector;
                xfree(lvalue);
            }
            else
            {
                val->protector.type = T_INVALID;
            }

            sp = i;
            sp->type = T_LVALUE;
            sp->u.protected_char_lvalue = val;

            return sp;
        }

        /* Indexing on illegal type */
        inter_sp = sp;
        inter_pc = pc;
        errorf("(lvalue12)Indexing on illegal type '%s'.\n", typename(type));
        return NULL;
    } /* for(ever) */

    /* NOTREACHED */
    return NULL;
} /* protected_rindex_lvalue() */

/*-------------------------------------------------------------------------*/
static INLINE svalue_t *
protected_aindex_lvalue (svalue_t *sp, bytecode_p pc)

/* Operator F_PROTECTED_AINDEX_LVALUE (string|vector &v=sp[0], int   i=sp[-1])
 *
 * Compute the index &(*v[>i]) of lvalue <v>, wrap it into a protector, and
 * push the reference to the protector as PROTECTED_LVALUE onto the stack.
 *
 * If <v> is a protected non-string-lvalue, the protected_lvalue referenced
 * by <v>.u.lvalue will be deallocated, and the protector itself will be
 * stored in <last_indexing_protector> for the time being.
 *
 * If <v> is a string-lvalue, it is made a malloced string if necessary.
 */

{
    svalue_t *vec;   /* the indexed value */
    svalue_t *i;     /* the index */
    short     type;  /* type of <vec> */

    /* Get arguments */
    vec = sp->u.lvalue;
    i = sp -1;

    /* The loop unravels the (possible) lvalue chain starting at vec.
     * When a non-lvalue is encountered, the indexing takes place
     * the function returns.
     */
    for (;;)
    {
        type = vec->type;

        /* Index a vector.
         */
        if (type == T_POINTER)
        {
            vector_t *v = vec->u.vec;
            struct protected_lvalue *lvalue;
            svalue_t *item;

            item = get_vector_a_item(v, i, sp, pc);

            /* Create the protector for the result */

            lvalue = (struct protected_lvalue *)xalloc(sizeof *lvalue);
            lvalue->v.type = T_PROTECTED_LVALUE;
            lvalue->v.u.lvalue = item;
            put_ref_array(&(lvalue->protector), v);

            /* Drop the arguments and return the result */

            sp = i;

            sp->type = T_LVALUE;
            sp->u.lvalue = &lvalue->v;
            return sp;
        }

        /* Index a string.
         */
        if (type == T_STRING)
        {
            struct protected_char_lvalue *val;
            char * cp;

            cp = get_string_a_item(vec, i, /* make_singular: */ MY_TRUE
                                  , /* allow_one_past: */ MY_FALSE
                                  , sp, pc);

            /* Add another reference to the string to keep it alive while
             * we use it.
             */
            (void)ref_mstring(vec->u.str);

            /* Build the protector */
            val = (struct protected_char_lvalue *)xalloc(sizeof *val);
            val->v.type = T_PROTECTED_CHAR_LVALUE;
            val->v.u.charp = cp;
            val->lvalue = vec;
            val->start = get_txt(vec->u.str);
            val->protector.type = T_INVALID;

            /* Drop the arguments and return the result */
            sp = i;

            sp->type = T_LVALUE;
            sp->u.protected_char_lvalue = val;

            return sp;
        }

        /* lvalues are just dereferenced.
         */
        if (type == T_LVALUE)
        {
            vec = vec->u.lvalue;
            continue;
        }

        /* Non-string protected lvalues are dereferenced, a protected
         * string lvalue is indexed immediately.
         */
        if (type == T_PROTECTED_LVALUE)
        {
            struct protected_lvalue *lvalue;
            struct protected_char_lvalue *val;
            char * cp;

            lvalue = (struct protected_lvalue *)vec;

            if (lvalue->v.u.lvalue->type != T_STRING)
            {
                /* Deref a non-string protected lvalue.
                 * If this is the lvalue passed to the operator, also free
                 * the protector structure (since its stack space will be
                 * used for the result), but keep the protector itself
                 * in a global variable.
                 */
                if (vec == sp->u.lvalue)
                {
                    free_protector_svalue(&last_indexing_protector);
                    last_indexing_protector = lvalue->protector;
                    vec = lvalue->v.u.lvalue;
                    xfree(lvalue);
                    continue;
                }
                vec = lvalue->v.u.lvalue;
                continue;
            }

            vec = lvalue->v.u.lvalue; /* it's a string... */
            cp = get_string_a_item(vec, i, /* make_singular: */ MY_TRUE
                                  , /* allow_one_past: */ MY_FALSE
                                  , sp, pc);

            /* Add another reference to the string to keep it alive while
             * we use it.
             */
            (void)ref_mstring(vec->u.str);

            /* Build the protector */
            val = (struct protected_char_lvalue *)xalloc(sizeof *val);
            val->v.type = T_PROTECTED_CHAR_LVALUE;
            val->v.u.charp = cp;
            val->lvalue = vec;
            val->start = get_txt(vec->u.str);

            /* Drop the arguments and return the result.
             * If this was the lvalue passed to the operator in the
             * first place, adopt the protecting value and free the old
             * operator structure. If not, just don't assign a protecting
             * value.
             */
            if (lvalue == sp->u.protected_lvalue)
            {
                val->protector = lvalue->protector;
                xfree(lvalue);
            }
            else
            {
                val->protector.type = T_INVALID;
            }

            sp = i;
            sp->type = T_LVALUE;
            sp->u.protected_char_lvalue = val;

            return sp;
        }

        /* Indexing on illegal type */
        inter_sp = sp;
        inter_pc = pc;
        errorf("(lvalue13)Indexing on illegal type '%s'.\n", typename(type));
        return NULL;
    } /* for(ever) */

    /* NOTREACHED */
    return NULL;
} /* protected_aindex_lvalue() */

/*-------------------------------------------------------------------------*/

/* Code values used by range_lvalue() and protected_range_lvalue()
 */

#define NN_RANGE (0)
#define RN_RANGE (1 << 0)
#define AN_RANGE (2 << 0)
#define NR_RANGE (1 << 2)
#define NA_RANGE (2 << 2)

#define RR_RANGE (RN_RANGE|NR_RANGE)
#define RA_RANGE (RN_RANGE|NA_RANGE)
#define AR_RANGE (AN_RANGE|NR_RANGE)
#define AA_RANGE (AN_RANGE|NA_RANGE)

#define NX_MASK (3)
#define XN_MASK (3 << 2)

static svalue_t *
range_lvalue (int code, svalue_t *sp)

/* Operator F_RANGE_LVALUE (string|vector &v=sp[0], int i2=sp[-1], i1=sp[-2])
 * and the operators F_*_RANGE_LVALUE.
 *
 * Compute the range &(v[i1..i2]) of lvalue <v> and push it into the stack.
 * The value pushed is a lvalue pointing to <special_lvalue>. <special_lvalue>
 * then is the POINTER_RANGE_- resp. STRING_RANGE_LVALUE.
 *
 * <code> is a four-bit flag determining whether the indexes are counted
 * from the beginning ('[i1..' and '..i2]'), the end of the vector
 * or string ('[<i1..' and '..<i2]'), or depending on the sign of the
 * index either from the beginning or end ('[>i1..' and '..>i2]').
 * <code>&NX_MASK determines the mode for the lower index (NN_RANGE,
 * RN_RANGE or AN_RANGE), <code>&XN_MASK the upper index (NN_RANGE,
 * NR_RANGE or NA_RANGE).
 */

{
    svalue_t *vec;         /* the indexed vector or string */
    svalue_t *i;           /* the index */
    int            ind1, ind2;  /* Lower and upper range index */
    short          type;        /* type of <vec> */
    mp_int         size;        /* size of <vec> in elements */

    /* Get the arguments */
    vec = sp;
    i = sp-1;

#ifdef DEBUG
    if (sp->type != T_LVALUE) {
        inter_sp = sp;
        errorf("wrong type to range_lvalue: got %s, expected lvalue\n"
             , typename(sp->type));
        return NULL;
    }
#endif

    /* Deref the initial, and possibly more, lvalues.
     */
    do {
        vec = vec->u.lvalue;
        type = vec->type;
    } while (type == T_LVALUE || type == T_PROTECTED_LVALUE);

    /* Determine the type of the result, and the input's size.
     */
    switch(type)
    {
    case T_POINTER:
        special_lvalue.v.type = T_POINTER_RANGE_LVALUE;
        size = (mp_int)VEC_SIZE(vec->u.vec);
        break;
    case T_STRING:
        special_lvalue.v.type = T_STRING_RANGE_LVALUE;
        size = (mp_int)mstrsize(vec->u.str);
        break;
    default:
        inter_sp = sp;
        errorf("(lvalue)Range index on illegal type '%s'.\n", typename(type));
        return NULL;
    }

    /* Get and check the upper bound i2 */

    if (i->type != T_NUMBER)
    {
        inter_sp = sp;
        errorf("Illegal upper range index: got '%s', expected 'number'.\n"
             , typename(i->type));
        return NULL;
    }

    if ((code & XN_MASK) == NR_RANGE)
    {
        ind2 = size - i->u.number;
    }
    else if ((code & XN_MASK) == NA_RANGE)
    {
        if (i->u.number < 0)
            ind2 = size + i->u.number;
        else
            ind2 = i->u.number;
    }
    else
    {
        ind2 = i->u.number;
    }


    if (++ind2 < 0 || ind2 > size+1)
    {
        inter_sp = sp;
        errorf("Upper range index out of bounds: %"PRIdPINT
               ", size: %"PRIdMPINT".\n"
             , i->u.number, size);
        return NULL;
    }

    /* Get and check the lower bound i1 */

    if ((--i)->type != T_NUMBER)
    {
        inter_sp = sp;
        errorf("Illegal lower range index: got %s, expected number.\n"
             , typename(i->type));
        return NULL;
    }

    if ((code & NX_MASK) == RN_RANGE)
    {
        ind1 = size - i->u.number;
    }
    else if ((code & NX_MASK) == AN_RANGE)
    {
        if (i->u.number < 0)
            ind1 = size + i->u.number;
        else
            ind1 = i->u.number;
    }
    else
    {
        ind1 = i->u.number;
    }

    if (ind1 < 0 || ind1 > size)
    {   /* Appending (ind1 == size) is allowed */
        inter_sp = sp;
        errorf("Lower range index out of bounds: %"PRIdPINT
               ", size: %"PRIdMPINT".\n"
             , i->u.number, size);
        return NULL;
    }


    /* Check the range for consistency */

    if (ind2 < ind1)
    {
        inter_sp = sp;
        errorf("Range of negative size given: %"PRIdPINT
               "..%"PRIdPINT" .\n"
             , i->u.number, (i+1)->u.number);
        return NULL;
    }

    if (ind1 == size) /* again allow appending */
        ind2 = ind1;
    else if (ind2 > size)
    {
        inter_sp = sp;
        errorf("Upper range index out of bounds: %"PRIdPINT
               ", size: %"PRIdMPINT".\n"
             , (i+1)->u.number, size);
        return NULL;
    }

    /* Finish the special_lvalue structure
     */
    special_lvalue.v.u.lvalue = vec;
    special_lvalue.size = size;
    special_lvalue.index1 = ind1;
    special_lvalue.index2 = ind2;

    /* Drop the arguments and return the result. */

    sp = i;

    sp->type = T_LVALUE;
    sp->u.lvalue = &special_lvalue.v;

    return sp;
} /* range_lvalue() */

/*-------------------------------------------------------------------------*/
static svalue_t *
protected_range_lvalue (int code, svalue_t *sp)

/* Operator F_PROTECTED_RANGE_LVALUE
 *                       (string|vector &v=sp[0], int i2=sp[-1], i1=sp[-2])
 * and the x-operators F_PROTECTED_*_RANGE_LVALUE and
 * F_PROTECTED_LVALUE.
 *
 * Compute the range &(v[i1..i2]) of lvalue <v>, wrap it into a protector,
 * and push the reference to the protector onto the stack.
 *
 * If <v> is a protected lvalue itself, its protecting svalue will be used
 * in the result protector.
 *
 * If <v> is a string-lvalue, it is made a malloced string if necessary.
 *
 * <code> is a four-bit flag determining whether the indexes are counted
 * from the beginning ('[i1..' and '..i2]'), the end of the vector
 * or string ('[<i1..' and '..<i2]'), or depending on the sign of the
 * index either from the beginning or end ('[>i1..' and '..>i2]').
 * <code>&NX_MASK determines the mode for the lower index (NN_RANGE,
 * RN_RANGE or AN_RANGE), <code>&XN_MASK the upper index (NN_RANGE,
 * NR_RANGE or NA_RANGE).
 */

{
    svalue_t *vec;         /* the indexed vector or string */
    svalue_t *i;           /* the index */
    int            ind1, ind2;  /* Lower and upper range index */
    short          type;        /* type of <vec> */
    mp_int         size;        /* size of <vec> in elements */
    short          lvalue_type; /* Result type */
    svalue_t  protector;   /* Protecting svalue saved from v */
    struct protected_range_lvalue *new_lvalue;
                                /* Result protector structure */

#ifdef DEBUG
    if (sp->type != T_LVALUE)
    {
        inter_sp = sp;
        errorf("wrong type to protected_range_lvalue: got %s, expected lvalue\n"
             , typename(sp->type));
        return NULL;
    }
#endif
    /* Get the arguments, and also remember the protector in case v
     * is a protected lvalue.
     */
    vec = sp->u.lvalue; /* deref initial lvalue */
    i = sp - 1;

    type = vec->type;

    if (type != T_PROTECTED_LVALUE)
        protector.type = T_INVALID;
    else
        protector = ((struct protected_lvalue*)vec)->protector;

    /* Deref any possibly following lvalues
     */
    while (type == T_LVALUE || type == T_PROTECTED_LVALUE)
    {
        vec = vec->u.lvalue;
        type = vec->type;
    }

    /* Determine the type of the result, and the input's size.
     * Also massage the input value a bit.
     */
    switch(type)
    {
    case T_POINTER:
        (void)ref_array(vec->u.vec); /* Count the coming protector */
        lvalue_type = T_PROTECTED_POINTER_RANGE_LVALUE;
        size = (mp_int)VEC_SIZE(vec->u.vec);
        break;

    case T_STRING:
        /* If the string is tabled, i.e. not changeable, or has more than
         * one reference, allocate a new copy which can be changed safely.
         */
        if (!mstr_singular(vec->u.str))
        {
            string_t *p;

            memsafe(p = unshare_mstring(vec->u.str), mstrsize(vec->u.str)
                   , "modifiable string");
            vec->u.str = p;
        }

        /* Add another reference to the string to keep it alive while
         * we use it.
         */
        (void)ref_mstring(vec->u.str);

        lvalue_type = T_PROTECTED_STRING_RANGE_LVALUE;
        size = (mp_int)mstrsize(vec->u.str);
        break;

    default:
        inter_sp = sp;
        errorf("(lvalue)Range index on illegal type '%s'.\n", typename(type));
        return NULL;
    }

    /* Get and check the upper index i2 */

    if (i->type != T_NUMBER)
    {
        inter_sp = sp;
        errorf("Illegal upper range index: got '%s', expected 'number'.\n"
             , typename(i->type));
        return NULL;
    }

    if ((code & XN_MASK) == NR_RANGE)
    {
        ind2 = size - i->u.number;
    }
    else if ((code & XN_MASK) == NA_RANGE)
    {
        if (i->u.number < 0)
            ind2 = size + i->u.number;
        else
            ind2 = i->u.number;
    }
    else
    {
        ind2 = i->u.number;
    }

    if (++ind2 < 0 || ind2 > size) {
        inter_sp = sp;
        errorf("Upper range index out of bounds: %"PRIdPINT
               ", size: %"PRIdMPINT".\n"
             , i->u.number, size);
        return NULL;
    }

    /* Get and check the lower index i1 */

    if ((--i)->type != T_NUMBER)
    {
        inter_sp = sp;
        errorf("Illegal lower range index: got %s, expected number.\n"
             , typename(i->type));
        return NULL;
    }

    if ((code & NX_MASK) == RN_RANGE)
    {
        ind1 = size - i->u.number;
    }
    else if ((code & NX_MASK) == AN_RANGE)
    {
        if (i->u.number < 0)
            ind1 = size + i->u.number;
        else
            ind1 = i->u.number;
    }
    else
    {
        ind1 = i->u.number;
    }

    if (ind1 < 0 || ind1 > size)
    {
        /* Appending (ind1 == size) is allowed */
        inter_sp = sp;
        errorf("Lower range index out of bounds: %"PRIdPINT
               ", size: %"PRIdMPINT".\n"
             , i->u.number, size);
        return NULL;
    }

    /* Build the protector */
    new_lvalue = (struct protected_range_lvalue *)xalloc(sizeof *new_lvalue);
    new_lvalue->v.type = lvalue_type;
    new_lvalue->v.u = vec->u;
    new_lvalue->protector = protector;
    new_lvalue->lvalue = vec;
    new_lvalue->index2 = ind2;
    new_lvalue->index1 = ind1;
    new_lvalue->size = size;

    /* Drop the arguments and return the result */

    sp = i;

    sp->type = T_LVALUE;
    sp->u.protected_range_lvalue = new_lvalue;

    return sp;
} /* protected_range_lvalue() */

/*-------------------------------------------------------------------------*/
static INLINE svalue_t *
push_indexed_value (svalue_t *sp, bytecode_p pc)

/* Operator F_INDEX (string|vector v=sp[-1], int   i=sp[0])
 *          F_INDEX (mapping       v=sp[-1], mixed i=sp[0])
 *          F_S_INDEX (struct      v=sp[-1], string|int i=sp[0])
 *
 * Compute the value (v[i]) and push it onto the stack.
 * If the value would be a destructed object, 0 is pushed onto the stack
 * and the ref to the object is removed from the vector/mapping.
 */

{
    svalue_t *vec;  /* the indexed value */
    svalue_t *i;    /* the index */

    /* Get arguments */
    i = sp;
    vec = sp - 1;

    switch (vec->type)
    {
    case T_STRING:
      {
        int c;

        c = (unsigned char)
            *get_string_item(vec, i, /* make_singular: */ MY_FALSE
                            , /* allow_one_past: */ MY_TRUE
                            , sp, pc);

        /* Drop the args and return the result */

        free_string_svalue(vec);

        sp = vec; /* == sp-1 */
        put_number(sp, c);

        return sp;
      }

    case T_POINTER:
      {
        svalue_t *item;

        item = get_vector_item(vec->u.vec, i, sp, pc);

        /* Drop the arguments */
        sp = vec; /* == sp-1 */

        /* Assign the indexed element to the sp entry holding vec.
         * Decrement the vector ref manually to optimize the case that
         * this is the last ref to the vector.
         */
        if (vec->u.vec->ref == 1)
        {
            svalue_t tmp;

            /* Copy the indexed element into <tmp>
             */
            tmp = *item;

            /* Invalidate the old space of the result value and free
             * the vector.
             */
            item->type = T_INVALID;
            free_array(vec->u.vec);

            /* Return the result */
            *sp = tmp;
            return sp;
        }

        deref_array(vec->u.vec);

        /* The vector continues to live: keep the refcount as it is
         * and just assign the indexed element for the result.
         */
        assign_checked_svalue_no_free(sp, item);
        return sp;
      }

    case T_MAPPING:
      {
        svalue_t item;
        mapping_t *m;

        m = vec->u.map;

        if (!m->num_values)
        {
            inter_sp = sp;
            inter_pc = pc;
            errorf("(value)Indexing a mapping of width 0.\n");
            return NULL;
        }

        /* Get the item.
         * We are getting a copy in case the subsequent free() actions
         * free the mapping and all it's data.
         */
        assign_checked_svalue_no_free(&item, get_map_value(m, i));

        /* Drop the arguments */

        free_svalue(i);
        free_mapping(m);

        /* Return the result */
        sp = vec; /* == sp-1 */
        transfer_svalue_no_free(sp, &item);
        return sp;
      }

#ifdef USE_STRUCTS
    case T_STRUCT:
      {
        struct_t * st = vec->u.strct;
        svalue_t * item;

        item = get_struct_item(st, i, sp, pc);

        /* Drop the 'i' argument */
        free_svalue(sp);
        sp--;

        /* Assign the value */
        assign_svalue_no_free(sp, item);

        /* Drop the struct reference */
        free_struct(st);
        return sp;
      }
#endif /* USE_STRUCTS */

    default:
        inter_sp = sp;
        inter_pc = pc;
        errorf("(value)Indexing on illegal type '%s'.\n", typename(vec->type));
        return NULL;
    }

    /* NOTREACHED */
    return NULL;
} /* push_indexed_value() */

/*-------------------------------------------------------------------------*/
static INLINE svalue_t *
push_rindexed_value (svalue_t *sp, bytecode_p pc)

/* Operator F_RINDEX (string|vector v=sp[0], int   i=sp[-1])
 *
 * Compute the value (v[<i]) and push it onto the stack.
 * If the value would be a destructed object, 0 is pushed onto the stack
 * and the ref to the object is removed from the vector/mapping.
 */

{
    svalue_t *vec;  /* the indexed value */
    svalue_t *i;    /* the index */

    /* Get arguments */
    i = sp;
    vec = sp - 1;

    switch (vec->type)
    {
    case T_STRING:
      {
        int c;

        c = (unsigned char)
            *get_string_r_item(vec, i, /* make_singular: */ MY_FALSE
                              , /* allow_one_past: */ MY_TRUE
                              , sp, pc);

        /* Drop the args and return the result */

        free_string_svalue(vec);

        sp = vec; /* == sp-1 */
        put_number(sp, c);
        return sp;
      }

    case T_POINTER:
      {
        svalue_t *item;

        item = get_vector_r_item(vec->u.vec, i, sp, pc);

        /* Drop the arguments */
        sp = vec;

        /* Assign the indexed element to the sp entry holding vec.
         * Decrement the vector ref manually to optimize the case that
         * this is the last ref to the vector.
         */
        if (vec->u.vec->ref == 1)
        {
            svalue_t tmp;

            /* Copy the indexed element into <tmp>
             */
            tmp = *item;

            /* Invalidate the old space of the result value and free
             * the vector.
             */
            item->type = T_INVALID;
            free_array(vec->u.vec);

            /* Return the result */
            *sp = tmp;
            return sp;
        }

        deref_array(vec->u.vec);

        /* The vector continues to live: keep the refcount as it is
         * and just assign the indexed element for the result.
         */
        assign_checked_svalue_no_free(sp, item);
        return sp;
      }

    default:
        inter_sp = sp;
        inter_pc = pc;
        errorf("(lvalue)Range index on illegal type '%s'.\n", typename(vec->type));
        return NULL;
    }

    /* NOTREACHED */
    return NULL;
} /* push_rindexed_value() */

/*-------------------------------------------------------------------------*/
static INLINE svalue_t *
push_aindexed_value (svalue_t *sp, bytecode_p pc)

/* Operator F_AINDEX (string|vector v=sp[0], int   i=sp[-1])
 *
 * Compute the value (v[>i]) and push it onto the stack.
 * If the value would be a destructed object, 0 is pushed onto the stack
 * and the ref to the object is removed from the vector/mapping.
 */

{
    svalue_t *vec;  /* the indexed value */
    svalue_t *i;    /* the index */

    /* Get arguments */
    i = sp;
    vec = sp - 1;

    switch (vec->type)
    {
    case T_STRING:
      {
        int c;

        c = (unsigned char)
            *get_string_a_item(vec, i, /* make_singular: */ MY_FALSE
                              , /* allow_one_past: */ MY_TRUE
                              , sp, pc);

        /* Drop the args and return the result */

        free_string_svalue(vec);

        sp = vec; /* == sp-1 */
        put_number(sp, c);
        return sp;
      }

    case T_POINTER:
      {
        svalue_t *item;

        item = get_vector_a_item(vec->u.vec, i, sp, pc);

        /* Drop the arguments */
        sp = vec;

        /* Assign the indexed element to the sp entry holding vec.
         * Decrement the vector ref manually to optimize the case that
         * this is the last ref to the vector.
         */
        if (vec->u.vec->ref == 1)
        {
            svalue_t tmp;

            /* Copy the indexed element into <tmp>
             */
            tmp = *item;

            /* Invalidate the old space of the result value and free
             * the vector.
             */
            item->type = T_INVALID;
            free_array(vec->u.vec);

            /* Return the result */
            *sp = tmp;
            return sp;
        }

        deref_array(vec->u.vec);

        /* The vector continues to live: keep the refcount as it is
         * and just assign the indexed element for the result.
         */
        assign_checked_svalue_no_free(sp, item);
        return sp;
      }

    default:
        inter_sp = sp;
        inter_pc = pc;
        errorf("(lvalue)Range index on illegal type '%s'.\n", typename(vec->type));
        return NULL;
    }

    /* NOTREACHED */
    return NULL;
} /* push_aindexed_value() */

/*=========================================================================*/
/*-------------------------------------------------------------------------*/
void
m_indices_filter ( svalue_t *key
                 , svalue_t *data UNUSED
                 , void *extra /* is a svalue_t ** */ )

/* Filter function used by mapping:m_indices() to implement the
 * m_indices() efun. It is here take advantage of the inline expansion
 * of assign_svalue_no_free().
 *
 * <key> points to a key in a mapping, <extra> points to a svalue_t*
 * pointing to a storage place. *key is assigned to **extra, *extra is
 * incremented afterwards.
 */

{
#ifdef __MWERKS__
#    pragma unused(data)
#endif
    svalue_t **svpp = (svalue_t **)extra;

    assign_svalue_no_free( (*svpp)++, key );
} /* m_indices_filter() */

/*-------------------------------------------------------------------------*/
void m_values_filter ( svalue_t *key UNUSED
                     , svalue_t *data
                     , void *extra /* is a struct mvf_info * */ )

/* Filter function used by efun m_values().
 *
 * <data> points to a data entry in a mapping, <extra> points to
 * a struct mvf_info describing the amount of data to copy, and the
 * target place. The <data> is copied to where <extra> points and <*extra>
 * is updated.
 */

{
#ifdef __MWERKS__
#    pragma unused(key)
#endif
    struct mvf_info * vip = (struct mvf_info *)extra;

    assign_svalue_no_free( vip->svp++, data + vip->num);
} /* m_values_filter() */

/*-------------------------------------------------------------------------*/
void
m_unmake_filter ( svalue_t *key
                , svalue_t *data
                , void *extra)

/* Filter function used by efun unmkmapping().
 *
 * <key>/<data> point to key and data entry in a mapping, <extra> points to
 * a struct mvf_info describing the amount of data to copy, and the
 * target place. The <keu> and <data> is copied to where <extra> points
 * and <*extra> is updated.
 */

{
    struct mvf_info * vip = (struct mvf_info *)extra;
    int i;

    assign_svalue_no_free(vip->svp->u.vec->item + vip->num, key);
    for (i = 0; i < vip->width; i++)
        assign_svalue_no_free(vip->svp[i+1].u.vec->item + vip->num, data+i);
    vip->num++;
} /* m_unmake_filter() */

/*-------------------------------------------------------------------------*/
static INLINE svalue_t *
find_value (int num)

/* Return the address of object-global variable number <num> in the
 * current variable block.
 *
 * <num> is the index of the variable in the current object's variable
 * array.
 */

{
    /* Make sure that we are not calling from a set_this_object()
     * context.
     */
    if (is_sto_context())
    {
        errorf("find_value: Can't execute with "
              "set_this_object() in effect.\n"
             );
    }

#ifdef DEBUG
    if (num >= current_object->prog->num_variables)
    {
        fatal("Illegal variable access %d(%d).\n",
            num, current_object->prog->num_variables);
    }
#endif
    return &current_variables[num];
} /* find_value() */

/*-------------------------------------------------------------------------*/
static INLINE svalue_t *
find_virtual_value (int num)

/* For the virtually inherited variable <num> (given as index within
 * the current object's variable block) return the address of the actual
 * variable.
 *
 * If the program for this variable was inherited more than one time,
 * this function returns the address of the corresponding variable svalue
 * of the very first inheritance. If the program was inherited just once,
 * this function is identical to find_value().
 *
 * TODO: It would be nicer if the driver would 'know' here which inherit
 * TODO:: to use, either by giving the inherit index in the code, or
 * TODO:: by putting a reference to the base instance in the struct
 * TODO:: inherit.
 */

{
    inherit_t *inheritp;
    program_t *progp;
    char *progpp; /* actually a program_t **, but some compilers... */

    /* Make sure that we are not calling from a set_this_object()
     * context.
     */
    if (is_sto_context())
    {
        errorf("find_virtual_value: Can't execute with "
              "set_this_object() in effect.\n"
             );
    }

    /* Set inheritp to the inherited program which defines variable <num>
     */
    inheritp = current_prog->inherit;
    while
      (   inheritp->variable_index_offset + inheritp->prog->num_variables <= num
       || inheritp->variable_index_offset > num)
    {
        inheritp++;
    }

    /* Get the index of the variable within the inherited program.
     */
    num -= inheritp->variable_index_offset;

    /* Set inheritp to the first instance of this inherited program.
     * A cleaner, but slighly slower way to write the following segment
     * is: for (inheritp = current_object->prog_inherit
     *         ; inheritp->prog != progp
     *         ; inheritp++) NOOP;
     */
    progp = inheritp->prog;
    progpp = (char *)&current_object->prog->inherit->prog;
    while (*(program_t **)progpp != progp)
        progpp += sizeof(inherit_t);
    inheritp = (inherit_t *)
                 (((PTRTYPE)(progpp)) - offsetof(inherit_t, prog));

    /* Compute the actual variable address */

    num += inheritp->variable_index_offset;

#ifdef DEBUG
    if (!current_object->variables
     || num >= current_object->prog->num_variables
       )
    {
        if (num)
            fatal("%s Fatal: find_virtual_value() on object %p '%s' "
                  "w/o variables, num %d\n"
                 , time_stamp(), current_object, get_txt(current_object->name)
                 , num);
        else
            errorf("%s Error: find_virtual_value() on object %p '%s' "
                  "w/o variables, num %d\n"
                 , time_stamp(), current_object, get_txt(current_object->name)
                 , num);
    }
#endif

    return &current_object->variables[num];
      /* TODO: Why not '&current_variables[num]'? */
} /* find_virtual_value() */


/*=========================================================================*/

/*                  T Y P E S   A N D   E R R O R S                        */

/*-------------------------------------------------------------------------*/
/* The following functions deal with the readable display of LPC runtime
 * types, and of errors in general.
 *
 *   typename(type) : Return a descriptive string for a type.
 *   efun_arg_typename(type) : Return a descriptive string for the bit-
 *                    encoded type information of an efun.
 *   complete_instruction(instr) : Return the name of the given instruction,
 *                    resp. of the instruction found a the given negative
 *                    offset.
 *   raise_bad_arg(instr, arg) : Argument no. <arg> for the instruction
 *                    was bad.
 *   vefun_bad_arg(arg,sp) : Argument no. <arg> for the current vefun
 *                    was bad. Also restore inter_sp from sp.
 *   raise_arg_error(instr, arg, expected, got) : (internal) The argument
 *                    no. <arg> to the instruction did not have the
 *                    <expected> type (bit-encoded), but instead <got>
 *                    (the LPC type tag).
 *   (v)efun_gen_arg_error(arg, got, sp): Argument no. <arg> to the current
 *                    tabled (v)efun had the wrong type <got>. inter_sp is
 *                    restored from <sp>.
 *   (v)efun_arg_error(arg, expected, got, sp): Argument no. <arg> to the
 *                    current tabled (v)efun had the wrong type <got> (LPC
 *                    type tag), not the type <expected> (LPC type tag).
 *                    inter_sp is restored from <sp>.
 *   (v)efun_exp_arg_error(arg, expected, got, sp): Argument no. <arg> to the
 *                    current tabled (v)efun had the wrong type <got> (LPC
 *                    type tag), not the type <expected> (bit-encoded).
 *                    inter_sp is restored from <sp>.
 *   code_arg_error(arg, expected, got, pc, sp): Argument no. <arg> to the
 *                    current one-byte instruction had the wrong type <got>
 *                    (LPC type tag), not the type <expected> (LPC type tag).
 *                    inter_sp is restored from <sp>, inter_pc from <pc>.
 *   code_exp_arg_error(arg, expected, got, pc, sp): Argument no. <arg> to the
 *                    current one-byte instruction had the wrong type <got>
 *                    (LPC type tag), not the type <expected> (bit-encoded).
 *                    inter_sp is restored from <sp>, inter_pc from <pc>.
 *   op_arg_error(arg, expected, got, pc, sp): Argument no. <arg> to the
 *                    current one-byte operator had the wrong type <got>
 *                    (LPC type tag), not the type <expected> (LPC type tag).
 *                    inter_sp is restored from <sp>, inter_pc from <pc>.
 *   op_exp_arg_error(arg, expected, got, pc, sp): Argument no. <arg> to the
 *                    current one-byte operator had the wrong type <got>
 *                    (LPC type tag), not the type <expected> (bit-encoded).
 *                    inter_sp is restored from <sp>, inter_pc from <pc>.
 *
 *     The difference between code_... and op_... is that the op_...
 *     will use 'right' and 'left' for the argument names.
 *
 *   test_efun_args(instr, args, argp): (internal) Test the types for
 *                    <args> arguments for the given instruction, starting
 *                    at <argp> against the expected types according to
 *                    efun_lpc_types[].
 */

/*-------------------------------------------------------------------------*/
static INLINE const char *
typename_inline (int type)

/* Translate the svalue <type> into a readable string.
 */

{
    type &= ~(T_MOD_SWAPPED);

    if (type < 0
     || (size_t)type >= sizeof(svalue_typename)/sizeof(svalue_typename[0])
       )
        fatal("Unknown typevalue %d\n", type);

    return svalue_typename[type];
} /* typename_inline() */

const char * typename (int type) { return typename_inline(type); }

#define typename(type) typename_inline(type)

/*-------------------------------------------------------------------------*/
const char *
efun_arg_typename (long type)

/* Translate the bit-encoded efun argument <type> into a readable
 * string and return it. The type encoding is the one used in
 * efun_lpc_types[].
 * Result is a pointer to a static buffer.
 * TODO: this function should use snprintf() for preventing buffer overflows,
 * TODO::especially changing svalue_typename is otherwise risky.
 */

{
    static char result[400];
    int numtypes, i;

    /* TODO: better write into result and return the static buffer */
    if (type == TF_ANYTYPE)
        return "mixed";

    result[0] = '\0';
    numtypes = sizeof(svalue_typename)/sizeof(svalue_typename[0]);

    for (i = 0; i < numtypes; i++)
    {
        if ((1 << i) & type)
        {
            if (result[0] != '\0')
                strcat(result, "/");
            strcat(result, typename(i));
        }
        type &=~(1 << i);
    }

    if (type != 0)
    {
        char tmp[100];
        if (result[0] != '\0')
            strcat(result, "/");
        sprintf(tmp, "unknown %lx", type);
        strcat(result, tmp);
    }
    return (const char *)result;
} /* efun_arg_typename() */

/*-------------------------------------------------------------------------*/
static INLINE int
complete_instruction (int instr)

/* If <instr> is negative, read the current instruction from
 * inter_pc - <instr> and return it; otherwise return <instr> itself.
 */

{
    if (instr < 0)
    {
        /* Find and decode the actual instruction at the given offset */
        bytecode_p pc = inter_pc + instr;

        instr = *pc;
        switch(instr)
        {
        case F_EFUN0:  instr = pc[1] + EFUN0_OFFSET; break;
        case F_EFUN1:  instr = pc[1] + EFUN1_OFFSET; break;
        case F_EFUN2:  instr = pc[1] + EFUN2_OFFSET; break;
        case F_EFUN3:  instr = pc[1] + EFUN3_OFFSET; break;
        case F_EFUN4:  instr = pc[1] + EFUN4_OFFSET; break;
        case F_EFUNV:  instr = pc[1] + EFUNV_OFFSET; break;
        default:
            /* This is the instruction code we need */
            NOOP;
            break;
        }
    }

    return instr;
} /* complete_instruction() */

/*-------------------------------------------------------------------------*/
static INLINE void
raise_bad_arg (int instr, int arg)
  NORETURN;

static INLINE void
raise_bad_arg (int instr, int arg)

/* The argument <arg> to <instr> was unusable for some reason.
 * If <instr> is negative, the instruction code is read from
 * inter_pc - <instr>; otherwise it is the instruction code itself.
 *
 * inter_sp and inter_pc are assumed to be correct.
 * Raise a proper error.
 */

{
    instr = complete_instruction(instr);

    errorf("Bad argument %d to %s().\n", arg, get_f_name(instr));
    /* NOTREACHED */
} /* raise_bad_arg() */

/*-------------------------------------------------------------------------*/
void
vefun_bad_arg (int arg, svalue_t *sp)

/* The argument <arg> to the current tabled vefun was unusable.
 * inter_pc is assumed to be correct, inter_sp will be set from <sp>.
 */

{
    inter_sp = sp;
    raise_bad_arg(-2, arg);
    /* NOTREACHED */
} /* vefun_bad_arg() */

/*-------------------------------------------------------------------------*/
static INLINE void
raise_arg_error (int instr, int arg, long expected, int got)
  NORETURN;

static INLINE void
raise_arg_error (int instr, int arg, long expected, int got)

/* The argument <arg> to <instr> had the wrong type: expected was the
 * type <expected> (bit-encoded as in the efun_lpc_types[]), but
 * it got the type <got> (the svalue type tag).
 * If <instr> is negative, the instruction code is read from
 * inter_pc - <instr>; otherwise it is the instruction code itself.
 *
 * If <expected> is 0, the expected type is read from the
 * instrs[] table.
 *
 * inter_sp and inter_pc are assumed to be correct.
 * Raise a proper error.
 */

{
    instr = complete_instruction(instr);

    if (!expected)
        expected = efun_lpc_types[instrs[instr].lpc_arg_index];

    errorf("Bad arg %d to %s(): got '%s', expected '%s'.\n"
         , arg, get_f_name(instr), typename(got), efun_arg_typename(expected)
         );
    /* NOTREACHED */
} /* raise_arg_error() */

/*-------------------------------------------------------------------------*/
void
efun_gen_arg_error (int arg, int got, svalue_t *sp)

/* The argument <arg> to the current tabled efun had the wrong type <got>.
 * inter_pc is assumed to be correct, inter_sp will be set from <sp>.
 */

{
    inter_sp = sp;
    raise_arg_error(-2, arg, 0, got);
    /* NOTREACHED */
} /* efun_gen_arg_error() */

/*-------------------------------------------------------------------------*/
void
vefun_gen_arg_error (int arg, int got, svalue_t *sp)

/* The argument <arg> to the current tabled vefun had the wrong type <got>.
 * inter_pc is assumed to be correct, inter_sp will be set from <sp>.
 */

{
    inter_sp = sp;
    raise_arg_error(-2, arg, 0, got);
    /* NOTREACHED */
} /* vefun_gen_arg_error() */

/*-------------------------------------------------------------------------*/
void
efun_arg_error (int arg, int expected, int got, svalue_t *sp)

/* The argument <arg> to the current tabled efun had the wrong type:
 * expected was the type <expected>, but it got the type <got>
 * (both values are the svalue type tag).
 * inter_pc is assumed to be correct, inter_sp will be set from <sp>.
 */

{
    inter_sp = sp;
    raise_arg_error(-2, arg, 1 << expected, got);
    /* NOTREACHED */
} /* efun_arg_error() */

/*-------------------------------------------------------------------------*/
void
efun_exp_arg_error (int arg, long expected, int got, svalue_t *sp)

/* The argument <arg> to the current tabled efun had the wrong type:
 * expected was the type <expected> (given as bitflags), but it got the type
 * <got> (given as svalue type tag).
 * inter_pc is assumed to be correct, inter_sp will be set from <sp>.
 */

{
    inter_sp = sp;
    raise_arg_error(-2, arg, expected, got);
    /* NOTREACHED */
} /* efun_arg_error() */

/*-------------------------------------------------------------------------*/
void
vefun_arg_error (int arg, int expected, int got, svalue_t *sp)

/* The argument <arg> to the current tabled vefun had the wrong type:
 * expected was the type <expected>, but it got the type <got>
 * (both values are the svalue type tag).
 * inter_pc is assumed to be correct, inter_sp will be set from <sp>.
 */

{
    inter_sp = sp;
    raise_arg_error(-2, arg, 1 << expected, got);
    /* NOTREACHED */
} /* vefun_arg_error() */

/*-------------------------------------------------------------------------*/
void
vefun_exp_arg_error (int arg, long expected, int got, svalue_t *sp)

/* The argument <arg> to the current tabled vefun had the wrong type:
 * expected was the type <expected> (in the bit-encoded format), but
 * it got the type <got> (the svalue type tag).
 * inter_pc is assumed to be correct, inter_sp will be set from <sp>.
 */

{
    inter_sp = sp;
    raise_arg_error(-2, arg, expected, got);
    /* NOTREACHED */
} /* vefun_exp_arg_error() */

/*-------------------------------------------------------------------------*/
static INLINE void
code_exp_arg_error (int arg, long expected, int got, bytecode_p pc, svalue_t *sp)
  NORETURN;

static INLINE void
code_exp_arg_error (int arg, long expected, int got, bytecode_p pc, svalue_t *sp)

/* The argument <arg> to the current one-byte instruction had the wrong type:
 * expected was the type <expected> (in bit-flag encoding), but it got the
 * type <got> (the svalue type tag).
 * inter_pc will be set from <pc>, inter_sp will be set from <sp>.
 */

{
    int instr;

    inter_sp = sp;
    inter_pc = pc;

    instr = complete_instruction(-1);

    errorf("Bad arg %d to %s: got '%s', expected '%s'.\n"
         , arg, get_f_name(instr), typename(got), efun_arg_typename(expected)
         );
    /* NOTREACHED */
} /* code_exp_arg_error() */

/*-------------------------------------------------------------------------*/
static INLINE void
code_arg_error (int arg, int expected, int got, bytecode_p pc, svalue_t *sp)
  NORETURN;

static INLINE void
code_arg_error (int arg, int expected, int got, bytecode_p pc, svalue_t *sp)

/* The argument <arg> to the current one-byte instruction had the wrong type:
 * expected was the type <expected>, but it got the type <got>
 * (both values are the svalue type tag).
 * inter_pc will be set from <pc>, inter_sp will be set from <sp>.
 */

{
    code_exp_arg_error(arg, 1 << expected, got, pc,sp);
    /* NOTREACHED */
} /* code_arg_error() */

/*-------------------------------------------------------------------------*/
static INLINE void
op_exp_arg_error (int arg, long expected, int got, bytecode_p pc, svalue_t *sp)
  NORETURN;

static INLINE void
op_exp_arg_error (int arg, long expected, int got, bytecode_p pc, svalue_t *sp)

/* The argument <arg> to the current one-byte operator had the wrong type:
 * expected was the type <expected> (bit-encoded as in efun_lpc_types[]),
 * but it got the type <got> (the svalue type tag).
 * inter_pc will be set from <pc>, inter_sp will be set from <sp>.
 *
 * This function is to be used with binary operators like + or *; the
 * error message will say 'left' and 'right' instead of 'arg 1' or 'arg 2'.
 */

{
    int instr;

    inter_sp = sp;
    inter_pc = pc;

    instr = complete_instruction(-1);

    errorf("Bad %s arg to %s: got '%s', expected '%s'.\n"
         , arg == 1 ? "left" : "right"
         , get_f_name(instr), typename(got), efun_arg_typename(expected)
         );
    /* NOTREACHED */
} /* op_exp_arg_error() */

/*-------------------------------------------------------------------------*/
static INLINE void
op_arg_error (int arg, int expected, int got, bytecode_p pc, svalue_t *sp)
  NORETURN;

static INLINE void
op_arg_error (int arg, int expected, int got, bytecode_p pc, svalue_t *sp)

/* The argument <arg> to the current one-byte operator had the wrong type:
 * expected was the type <expected>, but it got the type <got>
 * (both values are the svalue type tag).
 * inter_pc will be set from <pc>, inter_sp will be set from <sp>.
 *
 * This function is to be used with binary operators like + or *; the
 * error message will say 'left' and 'right' instead of 'arg 1' or 'arg 2'.
 */

{
    op_exp_arg_error(arg, 1 << expected, got, pc, sp);
    /* NOTREACHED */
} /* op_arg_error() */

/*-------------------------------------------------------------------------*/
static INLINE void
test_efun_args (int instr, int args, svalue_t *argp)

/* Test the types of the <args> arguments for (v)efun <instr> starting at
 * <argp> for their correct types according to efun_lpc_types[].
 * Raise an error if they aren't correct (requires inter_pc and inter_sp
 * to be valid).
 */

{
    int i;
    long * typep, type;

    typep = &(efun_lpc_types[instrs[instr].lpc_arg_index]);
    for (i = 1; i <= args; i++, typep++, argp++)
    {
        type = *typep;
        if (argp->type == T_NUMBER && !argp->u.number
         && (type & TF_NULL)
           )
            continue;
        if (!(*typep & (1 << argp->type)))
            raise_arg_error(instr, i, *typep, argp->type);
    }
} /* test_efun_args() */


/*-------------------------------------------------------------------------*/
/* general errorhandler */
static void
generic_error_handler( svalue_t * arg)
/* The error handler: free the allocated buffer and the errorhandler structure.
 * Note: it is static, but the compiler will have to emit a function and
 * symbol for this because the address of the function is taken and it is
 * therefore not suitable to be inlined.
 */
{
  errorhandler_t *handler = (errorhandler_t *)arg;
  if (handler->buff)
    xfree(handler->buff);
  xfree(handler);
} /* general_error_handler() */

/*-------------------------------------------------------------------------*/
void *
xalloc_with_error_handler(size_t size)
/* Allocates <size> bytes from the heap. Additionally an error handler is
 * pushed onto the value stack so that the requested memory is safely freed,
 * either by manually freeing the svalue on the stack or during stack
 * unwinding during errorf().
 * inter_sp has to point to the top-of-stack before calling and is updated to
 * point to the error handler svalue (new top-of-stack)!
 */
{
  void *buffer;
  errorhandler_t *handler;
  /* get the memory for the handler first and fail if out-of-memory */
  handler = xalloc(sizeof(*handler));
  if (!handler)
  {
    return NULL;
  }
  /* then get the requested memory - upon error de-allocate the handler */
  buffer = xalloc(size);
  if (!buffer)
  {
    xfree(handler);
    return NULL;
  }
  handler->buff = buffer;
  /* now push error handler onto the value stack */
  push_error_handler(generic_error_handler, &(handler->head));
  return buffer;
} /* alloc_with_error_handler */


/*=========================================================================*/
/*-------------------------------------------------------------------------*/
Bool
privilege_violation (string_t *what, svalue_t *arg, svalue_t *sp)

/* Call the mudlib to check for a privilege violation:
 *
 *   master->privilege_violation(what, current_object, arg)
 *
 * where <what> describes the type of the violation (uncounted string ref),
 * and <where> is the data used in the violation.
 * <sp> is the current stack setting.
 *
 * If the apply returns a positive number, the privilege is granted and
 * the function returns TRUE.
 * If the apply returns 0, the privilege is gently denied and the function
 * returns FALSE.
 * If the apply returns something else, or if the lfun doesn't exist,
 * an error is raised.
 *
 * If the current_object is the master or simul_efun object, this function
 * immediately returns TRUE.
 *
 * <inter_sp> is updated to <sp>, <inter_pc> is assumed to be correct.
 */

{
    return privilege_violation2(what, arg, NULL, sp);
} /* privilege_violation() */

/*-------------------------------------------------------------------------*/
Bool
privilege_violation2 ( string_t *what, svalue_t *arg, svalue_t *arg2
                     , svalue_t *sp)

/* Call the mudlib to check for a privilege violation:
 *
 *   master->privilege_violation(what, current_object, arg, arg2)
 *
 * where <what> describes the type of the violation (uncounted string ref),
 * and <arg>, <arg2> is the data used in the violation.
 * <sp> is the current stack setting.
 *
 * <arg2> may be NULL and is then ignored.
 *
 * If the apply returns a positive number, the privilege is granted and
 * the function returns TRUE.
 * If the apply returns 0, the privilege is gently denied and the function
 * returns FALSE.
 * If the apply returns something else, or if the lfun doesn't exist,
 * an error is raised.
 *
 * If the current_object is the master or simul_efun object, this function
 * immediately returns TRUE.
 *
 * <inter_sp> is updated to <sp>, <inter_pc> is assumed to be correct.
 */

{
    svalue_t *svp;
    int num_arg = 3;

    /* Trusted objects */
    if (current_object == master_ob) return MY_TRUE;
    if (current_object == simul_efun_object) return MY_TRUE;

    /* Setup and call the lfun */
    push_ref_string(sp, what);
    push_ref_valid_object(sp, current_object, "privilege violation");
    sp++;
    assign_svalue_no_free(sp, arg);
    if (arg2 != NULL)
    {
        sp++;
        assign_svalue_no_free(sp, arg2);
        num_arg++;
    }
    inter_sp = sp;
    svp = apply_master(STR_PRIVILEGE, num_arg);

    /* Is there a lfun to call? */
    if (!svp || svp->type != T_NUMBER || svp->u.number < 0)
    {
        inter_sp = sp-num_arg;
        errorf("privilege violation: %s\n", get_txt(what));
        /* TODO: Print full args and types */
    }

    /* Return the result */
    return svp->u.number > 0;
} /* privilege_violation2() */

/*-------------------------------------------------------------------------*/
Bool
privilege_violation4 ( string_t *what,    object_t *whom
                     , string_t *how_str, int how_num
                     , svalue_t *sp)

/* Call the mudlib to check for a privilege violation:
 *
 *   !whom:
 *       master->privilege_violation(what, current_object, how_str, how_num)
 *   whom && how_str:
 *       master->privilege_violation(what, current_object, whom, how_str)
 *   whom && !how_str:
 *       master->privilege_violation(what, current_object, whom, how_num)
 *
 * where <what> describes the type of the violation, and <whom>/<how_str>/
 * <how_num> are data used in the violation. <sp> is the current stack setting.
 * All strings are not counted.
 *
 * If the apply returns a positive number, the privilege is granted and
 * the function returns TRUE.
 * If the apply returns 0, the privilege is gently denied and the function
 * returns FALSE.
 * If the apply returns something else, or if the lfun doesn't exist,
 * an error is raised.
 *
 * If the current_object is the master or simul_efun object, this function
 * immediately returns TRUE.
 *
 * If the lfun doesn't exist, or returns anything else but a positive
 * number, an error is raised.
 *
 * <inter_sp> is updated to <sp>, <inter_pc> is assumed to be correct.
 */

{
    svalue_t *svp;

    /* Trust these objects */
    if (current_object == master_ob) return MY_TRUE;
    if (current_object == simul_efun_object) return MY_TRUE;

    /* Set up the lfun call */

    push_ref_string(sp, what);
    push_ref_valid_object(sp, current_object, "privilege_violation");
    if (!whom)
    {
        if (how_str)
            push_ref_string(sp, how_str);
        else
            push_number(sp, 0);
        push_number(sp, how_num);
    }
    else
    {
        push_ref_object(sp, whom, "privilege_violation");
        if (how_str)
            push_ref_string(sp, how_str);
        else
            push_number(sp, how_num);
    }
    inter_sp = sp;
    svp = apply_master(STR_PRIVILEGE, 4);

    /* Was it the proper lfun to call? */
    if (!svp || svp->type != T_NUMBER || svp->u.number < 0)
    {
        inter_sp = sp-4;
        errorf("privilege violation : %s\n", get_txt(what));
        /* TODO: Print full args and types */
    }

    /* Return the result */
    return svp->u.number > 0;
} /* privilege_violation4() */

/*-------------------------------------------------------------------------*/
Bool
privilege_violation_n ( string_t *what, object_t *whom, svalue_t *sp, int num_arg)

/* Call the mudlib to check for a privilege violation:
 *
 *   master->privilege_violation(what, current_object, whom,
 *                               sp[-num_arg+1], ...., sp)
 *
 * where <what> describes the type of the violation, and <whom> and the last
 * <num_arg> values of the stack are data used in the violation. <sp> is
 * also the current stack setting. All strings are not counted.
 *
 * If the apply returns a positive number, the privilege is granted and
 * the function returns TRUE.
 * If the apply returns 0, the privilege is gently denied and the function
 * returns FALSE.
 * If the apply returns something else, or if the lfun doesn't exist,
 * an error is raised.
 *
 * If the current_object is the master or simul_efun object, this function
 * immediately returns TRUE.
 *
 * If the lfun doesn't exist, or returns anything else but a positive
 * number, an error is raised.
 *
 * <inter_sp> is updated to <sp>, <inter_pc> is assumed to be correct.
 */

{
    svalue_t *svp, *arg;
    int num;

    /* Trust these objects */
    if (current_object == master_ob) return MY_TRUE;
    if (current_object == simul_efun_object) return MY_TRUE;

    /* Set up the lfun call */

    arg = sp + 1 - num_arg;

    push_ref_string(sp, what);
    push_ref_valid_object(sp, current_object, "privilege_violation");
    if (!whom)
    {
        push_number(sp, 0);
    }
    else
    {
        push_ref_object(sp, whom, "privilege_violation");
    }

    for (num = num_arg; num--; arg++)
    {
        sp++;
        assign_svalue_no_free(sp,  arg);
    }

    inter_sp = sp;
    svp = apply_master(STR_PRIVILEGE, 3 + num_arg);

    /* Was it the proper lfun to call? */
    if (!svp || svp->type != T_NUMBER || svp->u.number < 0)
    {
        inter_sp = sp - 3 - num_arg;
        errorf("privilege violation : %s\n", get_txt(what));
        /* TODO: Print full args and types */
    }

    /* Return the result */
    return svp->u.number > 0;
} /* privilege_violation_n() */

/*-------------------------------------------------------------------------*/
static Bool
trace_test (int b)

/* Test if tracing of the given option(s) <b> is allowed right now.
 * The function tests the options <b> against what the current interactive
 * requested, and if a trace_prefix is given, if the prefix matches the
 * name of the current object.
 */

{
    interactive_t *ip;

    return current_interactive
        && O_SET_INTERACTIVE(ip, current_interactive)
        && (ip->trace_level & b)
        && (ip->trace_prefix == NULL
            || (current_object
                && mstrprefixed(ip->trace_prefix, current_object->name)))
    ;
} /* trace_test() */

/*-------------------------------------------------------------------------*/
static void
do_trace (char *msg, char *fname, char *post)

/* If not in a heartbeat, or if heartbeat tracing is allowed, generate
 * a tracemessage of the form '<tracedepth> <msg> <objname> <fname> <post>'
 * and print it to the player using add_message().
 *
 * Don't do anything if the current command_giver is not interactive.
 *
 * <obj_name> is filled in only if TRACE_OBJNAME is requested, else
 * the empty string is used.
 */

{
    char buf[10000];
    char *objname;

    if (!TRACEHB)
        return;
    objname = TRACETST(TRACE_OBJNAME)
              ? (current_object && current_object->name
                   ? get_txt(current_object->name)
                   : "?")
              : "";
    sprintf(buf, "*** %d %*s %s %s %s%s", tracedepth, tracedepth, ""
               , msg, objname, fname, post);
    add_message("%s", buf);
#ifdef DEBUG
    add_message(message_flush);
#endif
} /* do_trace() */

/*-------------------------------------------------------------------------*/
static void
do_trace_call (fun_hdr_p funstart, Bool is_lambda)

/* Trace a call to the function starting at <funstart>.
 */

{
    if (!++traceing_recursion || !TRACE_IS_INTERACTIVE()) /* Do not recurse! */
    {
        int save_var_ix_offset = variable_index_offset;
          /* TODO: Might be clobbered, but where? */

        /* Trace the function itself */
        if (is_lambda)
            do_trace("Call direct ", "lambda-closure", " ");
        else
        {
            string_t *name;

            memcpy(&name, FUNCTION_NAMEP(funstart), sizeof name);
            do_trace("Call direct ", get_txt(name), " ");
        }

        /* If requested, also trace the arguments */
        if (TRACEHB)
        {
            if (TRACETST(TRACE_ARGS))
            {
                int i;
                svalue_t *svp;

                add_message(" with %d arguments: "
                           , FUNCTION_NUM_ARGS(funstart) & 0x7f);
                svp = inter_fp;
                for (i = (FUNCTION_NUM_ARGS(funstart) & 0x7f); --i >= 0; )
                {
                    print_svalue(svp++);
                    add_message(" ");
                }
            }
            add_message("\n");
        }
        variable_index_offset = save_var_ix_offset;
    }
    traceing_recursion--;
} /* do_trace_call() */

/*-------------------------------------------------------------------------*/
static void
do_trace_return (svalue_t *sp)

/* Trace the return from a function call; <sp> is the current stack pointer,
 * pointing to the result.
 */

{
    if (!++traceing_recursion || !TRACE_IS_INTERACTIVE())
    {
        if (trace_test(TRACE_RETURN))
        {
            inter_sp = sp;
            do_trace("Return", "", "");
            if (TRACEHB) {
                if (TRACETST(TRACE_ARGS)) {
                    add_message(" with value: ");
                    print_svalue(sp);
                }
                add_message("\n");
            }
        }
    }
    traceing_recursion--;

    /* If requested, (re)activate TRACE_EXEC */
    SET_TRACE_EXEC;
}

/*-------------------------------------------------------------------------*/
struct longjump_s *
push_error_context (svalue_t *sp, int catch_flags)

/* Create a catch recovery context, using <sp> as the stackpointer to save,
 * link it into the recovery stack and return the longjmp context struct.
 * The actual type of the catch context is determined by the <catch_flags>.
 */

{
    struct catch_context *p;

    p = xalloc (sizeof *p);
    p->save_sp = sp;
    p->save_csp = csp;
    p->save_command_giver = command_giver;
    p->recovery_info.rt.last = rt_context;
    p->recovery_info.rt.type = ERROR_RECOVERY_CATCH;
    p->recovery_info.flags = catch_flags;
    p->catch_value.type = T_INVALID;
    rt_context = (rt_context_t *)&p->recovery_info.rt;
    return &p->recovery_info.con;
} /* push_error_context() */

/*-------------------------------------------------------------------------*/
void
pop_error_context (void)

/* Pop and discard the top entry in the error recovery stack, assuming
 * that it's a catch recovery entry.
 *
 * This function is called when the catch() completed normally.
 */

{
    struct catch_context *p;

    p = (struct catch_context *)rt_context;

#ifdef DEBUG
    if (!ERROR_RECOVERY_CAUGHT(p->recovery_info.rt.type))
        fatal("Catch: runtime stack underflow");
    if (csp != p->save_csp-1)
        fatal("Catch: Lost track of csp");
    /* Note: the command_giver might have changed (with the exec() efun),
     * so testing it is of no use.
     */
#endif
    rt_context = p->recovery_info.rt.last;
    xfree(p);
} /* pop_error_context() */

/*-------------------------------------------------------------------------*/
svalue_t *
pull_error_context (svalue_t *sp, svalue_t *msg)

/* Restore the context saved by a catch() after a throw() or runtime error
 * occured. <sp> is the current stackpointer and is used to pop the elements
 * pushed since the catch().
 *
 * The function pops the topmost recovery entry, which must be the catch
 * recovery entry, restores the important global variables and returns
 * the saved stack pointer.
 *
 * If <msg> is not NULL the caught error message is put there.
 */

{
    struct catch_context *p;
    struct control_stack *csp2;

    p = (struct catch_context *)rt_context;

    if (!ERROR_RECOVERY_CAUGHT(p->recovery_info.rt.type))
        fatal("Catch: runtime stack underflow");

    /* If there was a call_other() or similar, previous_ob and current_object
     * must be restored. For this, find the control frame where the call
     * occured and get the proper values from there.
     */
    csp2 = p->save_csp;
    while (++csp2 <= csp)
    {
        if (csp2->extern_call)
        {
            previous_ob = csp2->prev_ob;
            current_object = csp2->ob;
            break;
        }
    }

    /* If there was a lambda call, we have to restore current_lambda */
    for (csp2 = csp; csp2 >p->save_csp; csp2--)
    {
        if (current_lambda.type == T_CLOSURE)
            free_closure(&current_lambda);
        current_lambda = csp2->lambda;
    }

    /* Restore the global variables and the evaluator stack */
    csp = p->save_csp;
    pop_n_elems(sp - p->save_sp);
    command_giver = p->save_command_giver;

    /* Save the error message */
    if (msg)
        transfer_svalue_no_free(msg, &p->catch_value);
    else
        free_svalue(&p->catch_value);

    /* Remove the context from the context stack */
    rt_context = p->recovery_info.rt.last;
    xfree(p);

    return sp;
} /* pull_error_context() */

/*-------------------------------------------------------------------------*/
void
transfer_error_message (svalue_t *v, rt_context_t *rt)
 /* Saves the message <v> in the error context <rt> assuming that
  * it's a catch recovery context. <v> is freed afterwards.
  */
{
    struct catch_context *p;

    p = (struct catch_context *)rt;
    transfer_svalue_no_free(&p->catch_value, v);
}

/*-------------------------------------------------------------------------*/
void
push_control_stack ( svalue_t   *sp
                   , bytecode_p  pc
                   , svalue_t   *fp
#ifdef USE_NEW_INLINES
                   , svalue_t   *context
#endif /* USE_NEW_INLINES */
                   )

/* Push the current execution context onto the control stack.
 * On stack overflow, raise a 'too deep recursion' error.
 */

{

    /* Check for overflow */
    if (csp >= &CONTROL_STACK[MAX_USER_TRACE-1])
    {
        if (!num_error || csp == &CONTROL_STACK[MAX_TRACE-1])
        {
            ERRORF(("Too deep recursion: depth %"PRIdMPINT
                    ", limit %d user/%d max.\n"
                   , (mp_int)(csp - CONTROL_STACK + 1)
                   , MAX_USER_TRACE, MAX_TRACE));
        }
    }

    /* Move csp to the next entry and fill it with the current context
     */
    csp++;

    /* csp->funstart  has to be set later, it is used only for tracebacks. */
    csp->fp = fp;
#ifdef USE_NEW_INLINES
    csp->context = context;
#endif /* USE_NEW_INLINES */
    csp->prog = current_prog;
    csp->lambda = current_lambda; put_number(&current_lambda, 0);
    /* csp->extern_call = MY_FALSE; It is set by eval_instruction() */
    csp->catch_call = MY_FALSE;
    csp->pc = pc;
    csp->function_index_offset = function_index_offset;
    csp->current_variables = current_variables;
    csp->break_sp = break_sp;
#ifdef EVAL_COST_TRACE
    csp->eval_cost = eval_cost;
#endif
} /* push_control_stack() */

/*-------------------------------------------------------------------------*/
void
pop_control_stack (void)

/* Pop the last entry from the control stack and restore the execution
 * context from it - except for extern_call of which the old value will
 * be used immediately after the pop.
 */

{
#ifdef DEBUG
    if (csp < CONTROL_STACK)
        fatal("Popped out of the control stack");
#endif

    if ( NULL != (current_prog = csp->prog) ) /* is 0 when we reach the bottom */
    {
        current_strings = current_prog->strings;
    }
    if (current_lambda.type == T_CLOSURE)
        free_closure(&current_lambda);
    current_lambda = csp->lambda;
    inter_pc = csp->pc;
    inter_fp = csp->fp;
#ifdef USE_NEW_INLINES
    inter_context = csp->context;
#endif /* USE_NEW_INLINES */
    function_index_offset = csp->function_index_offset;
    current_variables     = csp->current_variables;
    break_sp = csp->break_sp;
    csp--;
} /* pop_control_stack() */

/*-------------------------------------------------------------------------*/
inherit_t *
adjust_variable_offsets ( const inherit_t * inheritp
                        , const program_t * prog
                        , const object_t  * obj
                        )

/* If we do an explicit call into a virtually inherited base class we
 * have to find the first instance of the inherited variables.
 * This cannot be done at compile time because it depends on the
 * _object_ (i.e. the runtime environment) in which the program
 * is running.
 *
 * <inheritp> is the intended target for the call, <prog> is the
 * currently running program, <obj> is the currently used object.
 * The result is either NULL if no adjustment is required (then the caller
 * has to use the original <inheritp> passed in), or the pointer to the
 * inheritance structure to be used.
 *
 * TODO: A better compiler might do some backpatching and at least
 * TODO:: leave hints where the variables are, so that we can omit
 * TODO:: the explicite search. Or some load-time patching.
 */
{
    inherit_t * inh = NULL;

    if (prog != obj->prog
     && inheritp->prog->num_variables
     && (prog->variables[inheritp->variable_index_offset
                         +inheritp->prog->num_variables-1
                        ].type.typeflags & TYPE_MOD_VIRTUAL)
     && !(inheritp->prog->variables[inheritp->prog->num_variables-1
                                   ].type.typeflags & TYPE_MOD_VIRTUAL)
       )
    {
        /* Now search for the first virtual inheritance of the program
         * in the inherit list of the topmost program.
         * Don't get confused by normal inherits, though.
         */

        int i = obj->prog->num_inherited;
        inh = obj->prog->inherit;

        while (i)
        {
            if (inh->prog == inheritp->prog
             && obj->prog->variables[inh->variable_index_offset
                                     +inh->prog->num_variables-1
                                    ].type.typeflags&TYPE_MOD_VIRTUAL
               )
                break;
            inh++;
            i--;
        }

        /* i should always be != 0 here, with inh pointing the the
         * inherit structure we're looking for.
         */

#ifdef DEBUG
        if (!i)
        {
            char *ts;
            ts = time_stamp();
            fprintf(stderr,
                    "%s Adjusting variable offsets because of virtual "
                        "inheritance for call\n"
                    "%s from %s into %s (topmost program %s) FAILED.\n"
                    "%s Please check the inherit tree and report it.\n"
                   , ts, ts
                   , get_txt(prog->name)
                   , get_txt(inheritp->prog->name)
                   , get_txt(obj->prog->name)
                   , ts);
            inh = NULL;
        }
#endif
    }

    return inh;
} /* adjust_variable_offsets() */

/*-------------------------------------------------------------------------*/
static inherit_t *
setup_inherited_call (unsigned short inhIndex)

/* Setup the global variables for a call to an explicitly inherited
 * function, inherited from <inhIndex>. Result is the pointer to the
 * inherit structure.
 */

{
    inherit_t * inheritp = &current_prog->inherit[inhIndex];

#ifdef DEBUG
    if (inhIndex >= current_prog->num_inherited)
        errorf("(setup_inherited_call): inhIndex %ld > number of inherits %ld "
              "in program '%s'\n"
             , (long)inhIndex
             , (long)current_prog->num_inherited
             , get_txt(current_prog->name)
             );
#endif

    /* If we do an explicit call into a virtually inherited base class we
     * have to find the first instance of the inherited variables.
     * This cannot be done at compile time because it depends on the
     * _object_ (i.e. the runtime environment) in which current_prog
     * is running.
     */
    {
        inherit_t * inh;

        inh = adjust_variable_offsets(inheritp, current_prog, current_object);
        if (inh)
        {
            /* Found a virtual base class, so un-adjust the offsets. */
            inheritp = inh;
            current_variables = current_object->variables;
            function_index_offset = 0;
        }
    }

    /* Set the current program to the inherited program so that the
     * caller can search for the function.
     */
    current_prog = inheritp->prog;

    return inheritp;
} /* setup_inherited_call() */

/*-------------------------------------------------------------------------*/
static INLINE funflag_t
setup_new_frame1 (int fx, int fun_ix_offs, int var_ix_offs)

/* Setup current_prog, function_ and variable_index_offset for a call
 * to function index <fx> in the current program.
 *
 * <fun_ix_offs> and <var_ix_offs> are offsets to be added to the
 * functions given offsets - this is necessary when <fx> is given relative
 * to some inherited program and needs to be adjusted for the topmost
 * program.
 *
 * Return the 'flags' for the function.
 */

{
    program_t *progp;
    funflag_t flags;

    progp = current_prog;

    flags = progp->functions[fx];

    /* Handle a cross-define.
     * This is a rather rare occasion and usually happens only with functions
     * like heart_beat() which are called by function index and not by name.
     * This index, determined at compile time, might point to the
     * cross-defined function entry.
     */
    if (flags & NAME_CROSS_DEFINED)
    {
        fx += CROSSDEF_NAME_OFFSET(flags);
        flags = progp->functions[fx];
    }

    /* If the function is inherited, find the real function definition
     * and adjust the offsets to point to its code and variables.
     * This is an iteration walking along the inherit chain.
     */
    fun_ix_offs += fx;
    while (flags & NAME_INHERITED)
    {
        inherit_t *inheritp;

        inheritp = &progp->inherit[flags & INHERIT_MASK];
        progp = inheritp->prog;
        fx -= inheritp->function_index_offset;
        var_ix_offs += inheritp->variable_index_offset;
          /* Remember here that function offset is relative to current_prog,
           * but variable_offset is relative to current_object.
           */
        flags = progp->functions[fx];
    }
    /* fx is now the 'pure' function index without any offsets */

    /* Setup the variables and return */
    current_prog = progp;
    function_index_offset = fun_ix_offs - fx;
    variable_index_offset = var_ix_offs;

    return flags;
} /* setup_new_frame1() */

/*-------------------------------------------------------------------------*/
static INLINE svalue_t *
setup_new_frame2 (fun_hdr_p funstart, svalue_t *sp
                 , Bool allowRefs, Bool is_lambda)

/* Before calling the function at <funstart>, massage the data on the
 * stack ending at <sp> to match the formal argumentlist of the function
 * (excessive args are removed, missing args are provided as 0),
 * and allocate the local variables on the stack.
 *
 * If <allowRefs> is TRUE, references may be passed as extended varargs
 * ('(varargs mixed *)'). Currently this is used only for simul efuns.
 * TODO: Investigate if holding references in arrays is really such a
 * TODO:: a bad thing. Maybe it's just an implementation issue.
 * TODO:: This also affects apply_low() and call_lambda().
 *
 * <is_lambda> has to be TRUE if the function is a lambda closure.
 * This information is needed for proper tracing.
 *
 * csp->num_local_variables is supposed to hold the number of actual
 * arguments on the stack.
 *
 * Result is the new stackpointer, the framepointer <inter_fp>,
 * csp->num_local_variables and <break_sp> are set up.
 * The context pointer <inter_context> is cleared.
 */

{
    int i;        /* Difference between number of formal and actual args;
                   * Number of (uninitialized) local variables
                   */
    int num_arg;  /* Number of formal args */

    /* Setup the frame pointer */
    inter_fp = sp - csp->num_local_variables + 1;

#ifdef USE_NEW_INLINES
    /* By default there is no context */
    inter_context = NULL;
#endif /* USE_NEW_INLINES */

    /* (Re)move excessive arguments.
     * TODO: This code uses that bit7 makes num_arg negative.
     */
    num_arg = FUNCTION_NUM_ARGS(funstart);
    if ((i = csp->num_local_variables - num_arg) > 0)
    {
        /* More actual than formal args, or the function has
         * a 'varargs' argument.
         */

        if (num_arg < 0)
        {
            /* Function has a 'varargs' argument */

            num_arg &= 0x7f;

            if ((i = csp->num_local_variables - num_arg + 1) < 0)
            {
                /* More formal than actual parameters. */

                csp->num_local_variables = num_arg;

                /* First, fill in zero for the rest... */
                do {
                    *++sp = const0;
                } while (++i);

                /* ...and an empty array for the varargs portion */
                ++sp;
                put_array(sp, allocate_uninit_array(0));
            }
            else
            {
                /* More actual than formal parameters */

                vector_t *v;

                csp->num_local_variables = num_arg;

                /* Move the extra args into an array and put that
                 * onto the stack
                 */
                v = allocate_uninit_array(i);
                while (--i >= 0)
                {
                    if (!allowRefs && sp->type == T_LVALUE)
                        num_arg = -1; /* mark error condition */
                    v->item[i] = *sp--;
                }

                ++sp;
                put_array(sp, v);

                if (num_arg < 0)
                {
                    bytecode_p pc = funstart; /* for the ERROR() macro */

                    ERROR("Varargs argument passed by reference.\n");
                }
            }
        }
        else
        {
            /* Function takes a fixed number of arguments */

            /* Pop the extraneous args */
            do {
                free_svalue(sp--);
                csp->num_local_variables--;
            } while(--i);

        } /* if(varargs or fixedargs) */

        /* Clear the local variables */

        if ( 0 != (i = FUNCTION_NUM_VARS(funstart)) )
        {
            csp->num_local_variables += i;
            do {
                *++sp = const0;
            } while (--i);
        }
    }
    else
    {
        /* Enough or too little arguments supplied to a fixed-args
         * function: initialize the missing args and the locals
         * in one swoop.
         */

        if ( 0 != (i = FUNCTION_NUM_VARS(funstart) - i) )
        {
            csp->num_local_variables += i;
            do {
                *++sp = const0;
            } while (--i);
        }
    }

    /* Check for stack overflow. Since the actual stack size is
     * larger than EVALUATOR_STACK_SIZE, this check at the
     * end should be sufficient. If not, stack_overflow() will
     * generate a fatal error and we have to resize.
     */
    if ( sp >= &VALUE_STACK[EVALUATOR_STACK_SIZE] )
        stack_overflow(sp, csp->fp, funstart);

    /* Count the call depth for traces and handle tracing */
    tracedepth++;
    if (TRACEP(TRACE_CALL) && TRACE_IS_INTERACTIVE())
    {
      inter_sp = sp;
      do_trace_call(funstart, is_lambda);
    }


    /* Initialize the break stack, pointing to the entry above
     * the first available svalue.
     */
    break_sp = (bytecode_p *)&sp[1].u.str;

    return sp;
} /* setup_new_frame2() */

/*-------------------------------------------------------------------------*/
static void
setup_new_frame (int fx, program_t *inhProg)

/* Setup a call for function <fx> in the current program.
 * If <inhProg> is not NULL, it is the program of the inherited function
 * to call.
 * Result are the flags for the function. Global csp->funstart is set
 * to the start of the function bytecode.
 */

{
    funflag_t flags;

    if (inhProg)
    {
        program_t *progp;
        int       fun_ix_offs;
        int       var_ix_offs;

        progp = current_prog;
        fun_ix_offs = 0;
        var_ix_offs = 0;

        while (progp != inhProg)
        {
            inherit_t      *inheritp, *inh;

#ifdef DEBUG
            if (!progp->num_inherited)
                errorf("(setup_new_frame): Couldn't find program '%s' "
                       "in program '%s' with function index %ld. "
                       "Found program '%s' instead.\n"
                     , get_txt(inhProg->name)
                     , get_txt(current_prog->name)
                     , (long) fx
                     , get_txt(progp->name)
                     );
#endif
            inheritp = search_function_inherit(progp, fx);
            fx -= inheritp->function_index_offset;

            inh = adjust_variable_offsets(inheritp, progp, current_object);
            if (inh)
            {
                /* Virtual base class. Reset offsets. */
                inheritp = inh;
                fun_ix_offs = 0;
                var_ix_offs = 0;
            }

            fun_ix_offs += inheritp->function_index_offset;
            var_ix_offs += inheritp->variable_index_offset;
            progp = inheritp->prog;

#ifdef DEBUG
            if (fx >= progp->num_functions)
                errorf("(setup_new_frame): fx %ld > number of "
                       "functions %ld in program '%s'\n"
                     , (long) fx
                     , (long) progp->num_functions
                     , get_txt(progp->name)
                     );
#endif
        }

        current_prog = inhProg;

        flags = setup_new_frame1(fx, fun_ix_offs, var_ix_offs);
    }
    else
        flags = setup_new_frame1(fx, 0, 0);

    /* Setting csp->funstart is not just convenient, but also
     * required for proper error handling in setup_new_frame2()
     */
    csp->funstart = current_prog->program + (flags & FUNSTART_MASK);

    inter_sp = setup_new_frame2(csp->funstart, inter_sp, MY_FALSE, MY_FALSE);
#ifdef DEBUG
    if (!current_object->variables && variable_index_offset)
        fatal("%s Fatal: new frame for object %p '%s' w/o variables, "
              "but offset %d\n"
             , time_stamp(), current_object, get_txt(current_object->name)
             , variable_index_offset);
#endif
    current_variables = current_object->variables;
    if (current_variables)
        current_variables += variable_index_offset;
    current_strings = current_prog->strings;
} /* setup_new_frame() */

/*-------------------------------------------------------------------------*/
void
reset_machine (Bool first)

/* Reset the virtual machine. <first> is true on the very first call
 * (the cold boot, so to speak). Subsequent calls pass <first> as false
 * and this way make sure that all values currently on the stack
 * are properly removed.
 */

{
    traceing_recursion = -1;
    if (first)
    {
        csp = CONTROL_STACK - 1;
        inter_sp = VALUE_STACK - 1;
        tracedepth = 0;
        put_number(&current_lambda, 0);
    }
    else
    {
        inter_sp = _pop_n_elems(inter_sp - VALUE_STACK + 1, inter_sp);
        if (current_lambda.type == T_CLOSURE)
            free_closure(&current_lambda);
        put_number(&current_lambda, 0);
        while (csp >= CONTROL_STACK)
        {
            if (csp->lambda.type == T_CLOSURE)
                free_closure(&csp->lambda);
            csp--;
        }
    }
} /* reset_machine() */

/*-------------------------------------------------------------------------*/
#ifdef DEBUG
int
check_state (void)

/* Check the virtual machine for consistency. Return 0 when it is, else
 * print a debug message and return an error code.
 *
 * As this function can be costly, it is by default not called from
 * the backend loop.
 */

{
    int rc;

    rc = 0;

    if (rt_context->type != ERROR_RECOVERY_BACKEND) {
        debug_message("%s rt_context stack inconsistent: type %d instead of %d\n"
                     , time_stamp(), rt_context->type, ERROR_RECOVERY_BACKEND);
        printf("%s rt_context stack inconsistent: type %d instead of %d\n"
              , time_stamp(), rt_context->type, ERROR_RECOVERY_BACKEND);
        if (!rc) rc = 1;
    }
    if (csp != CONTROL_STACK - 1) {
        debug_message("%s csp inconsistent: %p instead of %p\n"
                     , time_stamp(), csp, CONTROL_STACK-1);
        printf("%s csp inconsistent: %p instead of %p\n"
              , time_stamp(), csp, CONTROL_STACK-1);
        if (!rc) rc = 2;
    }
    if (inter_sp != VALUE_STACK - 1) {
        debug_message("%s sp inconsistent: %p instead of %p\n"
                     , time_stamp(), inter_sp, VALUE_STACK - 1);
        printf("%s sp inconsistent: %p instead of %p\n"
              , time_stamp(), inter_sp, VALUE_STACK - 1);
        if (!rc) rc = 3;
    }

    return rc;
} /* check_state() */
#endif

/*-------------------------------------------------------------------------*/
void
free_interpreter_temporaries (void)

/* Free all svalue the interpreter holds in global variables.
 * Usually the values are freed whenever a new value is stored, but
 * this function allows e.g. the garbage collector to free them all
 * at once.
#ifdef TRACE_CODE
 * The function also cleans out all destructed objects from the
 * instruction trace.
#endif
 */

{
    free_protector_svalue(&last_indexing_protector);
    last_indexing_protector.type = T_NUMBER;
    free_svalue(&indexing_quickfix);
    indexing_quickfix.type = T_NUMBER;
    free_svalue(&apply_return_value);
    apply_return_value.type = T_NUMBER;

#ifdef TRACE_CODE
    {
        int i;

        for (i = TOTAL_TRACE_LENGTH; --i >= 0; )
        {
            object_t *ob;

            if (NULL != (ob = previous_objects[i])
             && ob->flags & O_DESTRUCTED
               )
            {
                free_object(ob, "free_interpreter_temporaries");
                previous_objects[i] = NULL;
                previous_instruction[i] = 0;
            }
        }
    }
#endif

} /* free_interpreter_temporaries() */

/*-------------------------------------------------------------------------*/
void
remove_object_from_stack (object_t *ob)

/* Object <ob> was/will be destructed, so remove all references from
 * to it from the stack, including references through closures.
 */

{
    svalue_t *svp;

    for (svp = VALUE_STACK; svp <= inter_sp; svp++)
    {
        if (object_ref(svp, ob))
        {
            free_svalue(svp);
            put_number(svp, 0);
        }
    } /* foreach svp in stack */
} /* remove_object_from_stack() */

/*-------------------------------------------------------------------------*/
static INLINE void
put_default_argument (svalue_t *sp, int instruction)

/* Evaluate <instruction> and put it's result into *<sp>.
 * This function is used to generate default arguments for efuns at runtime,
 * and therefor implements just the instructions F_CONST0, F_CONST1,
 * F_NCONST1, F_TIME, F_THIS_OBJECT, and F_THIS_PLAYER.
 */

{
    switch(instruction)
    {
    case F_CONST0:
        put_number(sp, 0);
        break;

    case F_CONST1:
        put_number(sp, 1);
        break;

    case F_NCONST1:
        put_number(sp, -1);
        break;

    case F_TIME:
        put_number(sp, current_time);
        break;

    case F_THIS_OBJECT:
        if (current_object->flags & O_DESTRUCTED)
        {
            put_number(sp, 0);
            break;
        }
        put_ref_object(sp, current_object, "default: this_object");
        break;

    case F_THIS_PLAYER:
        if (command_giver && !(command_giver->flags & O_DESTRUCTED))
            put_ref_object(sp, command_giver, "default: this_player");
        else
            put_number(sp, 0);
        break;

    default:
        fatal("Unimplemented runtime default argument '%s' to %s().\n"
             , get_f_name(instruction), get_f_name(complete_instruction(-2))
             );
        break;
    }
} /* put_default_argument() */

/*-------------------------------------------------------------------------*/
Bool
eval_instruction (bytecode_p first_instruction
                 , svalue_t *initial_sp)

/* Evaluate the code starting at <first_instruction>, using <inital_sp>
 * as the stack pointer.
 *
 * All other variables like current_prog must be setup before the call.
 * The function will return upon encountering a F_RETURN instruction
 * for which .extern_call or .catch_call is true, or upon encountering
 * a F_END_CATCH instruction.
 *
 * The result will state the reason for returning: FALSE for F_RETURN,
 * and TRUE for F_END_CATCH.
 *
 * This also means that for every intra-object call eval_instruction()
 * is called recursively.
 *
 * There must not be destructed objects on the stack. The destruct_object()
 * function will automatically remove all occurences. The effect is that
 * all called efuns know that they won't have destructed objects as
 * arguments.
 *
 * All instructions/functions callable from LPC must return a value or be
 * declared void. This does not apply to internal control codes like F_JUMP.
 */

{
    register bytecode_p     pc;  /* Current program pointer */
    register svalue_t *fp;  /* Current frame pointer */
    register svalue_t *sp;  /* Current stack pointer */
      /* For speed reasons, these variables shadow their global counterparts,
       * allowing more optimisations.
       * gcc feels better about setjmp() when variables are declared register.
       * Still we might get 'variable foo might be clobbered' warnings, but
       * declaring them as volatile would degrade optimization, so we don't.
       */
    int num_arg;      /* Number of arguments given to the current instr */
    int instruction;  /* The current instruction code */
    int full_instr;   /* The full instruction code; including any additional
                       * code bytes (e.g. for efuns)
                       */
#ifdef DEBUG
    svalue_t *expected_stack; /* Expected stack at the instr end */
#endif

    svalue_t *ap;
      /* Argument frame pointer: pointer to first outgoing argument to be
       * passed to called function.
       */
    Bool use_ap;
      /* TRUE if the next simul_efun/efun call is to determine the number of
       * arguments from the current *ap value. This variable is static in order
       * to survive longjmp()s, its actual scope is just within one execution
       * of eval_instruction().
       */


    /* Handy macros:
     *
     *   GET_NUM_ARG: Get the number of arguments, resp. check if the
     *                number was read correctly.
     *
     *   RAISE_ARG_ERROR(arg,expected,got),
     *   OP_ARG_ERROR(arg,expected,got):
     *                Argument <arg> had type <got> (LPC type tag), not
     *                type <expected> (bit-encoded).
     *
     *   BAD_ARG_ERROR(arg,expected,got),
     *   BAD_OP_ARG(arg,expected,got):
     *                Argument <arg> had type <got> (LPC type tag), not
     *                type <expected> (LPC type tag).
     *
     *   TYPE_TEST1/2/3/4(arg, t): Test argument <arg> of a one-byte
     *                instruction if it has type <t> (LPC type tag).
     *                The 1/2/3/4 is the number of the argument.
     *   TYPE_TEST_LEFT(arg, t), TYPE_TEST_RIGHT(arg, t): Test the
     *                argument <arg> if it has type <t> (LPC type tag).
     *                It is either the left or the right argument to a
     *                one-byte operator.
     *   TYPE_TEST_EXP_LEFT(arg, t), TYPE_TEST_EXP_RIGHT(arg, t): Test the
     *                argument <arg> if it has type <t> (bit-encoded).
     *                It is either the left or the right argument to a
     *                one-byte operator.
     *
     */

#   ifdef DEBUG
#       define GET_NUM_ARG \
            if (num_arg != GET_UINT8(pc-1)) {\
                fatal("Argument count error for %s: %d vs. %d.\n", get_f_name(instruction), num_arg, GET_UINT8(pc-1));}
        /* The macro catches two faults: getting num_arg for instructions
         * which don't take arguments, and getting num_arg after incrementing
         * the pc too far.
         */
#   else /* DEBUG */
#       define GET_NUM_ARG num_arg = GET_UINT8(pc); inter_pc = ++pc;
#   endif /* DEBUG */
      /* Get and/or test the number of arguments.
       */

#   define ARG_ERROR_TEMPL(fun, arg, expected, got) \
       do {\
           inter_sp = sp; \
           inter_pc = pc; \
           fun(instruction, arg, expected, got); \
       }while(0)

#   define RAISE_ARG_ERROR(arg, expected, got) \
       ARG_ERROR_TEMPL(raise_arg_error, arg, expected, got)

#   define BAD_ARG_ERROR(arg, expected, got) \
       ARG_ERROR_TEMPL(raise_arg_error, arg, 1 << expected, got)

#   define OP_ARG_ERROR_TEMPL(fun, arg, expected, got) \
       do {\
           inter_sp = sp; \
           inter_pc = pc; \
           fun(arg, expected, got, pc, sp); \
       }while(0)

#   define BAD_OP_ARG(arg, expected, got) \
       OP_ARG_ERROR_TEMPL(op_arg_error, arg, expected, got)

#   define OP_ARG_ERROR(arg, expected, got) \
       OP_ARG_ERROR_TEMPL(op_exp_arg_error, arg, expected, got)

#   define TYPE_TEST_TEMPL(num, arg, t) \
        if ( (arg)->type != t ) code_arg_error(num, t, (arg)->type, pc, sp); else NOOP;
#   define OP_TYPE_TEST_TEMPL(num, arg, t) \
        if ( (arg)->type != t ) op_arg_error(num, t, (arg)->type, pc, sp); else NOOP;
#   define EXP_TYPE_TEST_TEMPL(num, arg, t) \
        if (!( (1 << (arg)->type) & (t)) ) op_exp_arg_error(num, (t), (arg)->type, pc, sp); else NOOP;

#   define TYPE_TEST1(arg, t) TYPE_TEST_TEMPL(1, arg, t)
#   define TYPE_TEST2(arg, t) TYPE_TEST_TEMPL(2, arg, t)
#   define TYPE_TEST3(arg, t) TYPE_TEST_TEMPL(3, arg, t)
#   define TYPE_TEST4(arg, t) TYPE_TEST_TEMPL(4, arg, t)

#   define TYPE_TEST_LEFT(arg, t)  OP_TYPE_TEST_TEMPL(1, arg, t)
#   define TYPE_TEST_RIGHT(arg, t) OP_TYPE_TEST_TEMPL(2, arg, t)

#   define TYPE_TEST_EXP_LEFT(arg, t)  EXP_TYPE_TEST_TEMPL(1, arg, t)
#   define TYPE_TEST_EXP_RIGHT(arg, t) EXP_TYPE_TEST_TEMPL(2, arg, t)
      /* Test the type of a certain argument.
       */

#   ifdef MARK
#        define CASE(x) case (x): MARK(x);
#   else
#        define CASE(x) case (x):
#   endif
      /* Macro to build the case: labels for the evaluator switch.
       * 'MARK' adds profiling support.
       */

    /* Setup the variables.
     * The next F_RETURN at this level will return out of eval_instruction().
     */
    if (!csp->catch_call)
        csp->extern_call = MY_TRUE;
    sp = initial_sp;
    pc = first_instruction;
    fp = inter_fp;
    ap = inter_fp; /* so that call_lambda() can call us for efun closures */
    use_ap = MY_FALSE;
    runtime_no_warn_deprecated = MY_FALSE;
    runtime_array_range_check = MY_FALSE;
    SET_TRACE_EXEC;

    /* ------ The evaluation loop ------ */

again:
    /* Get the next instruction and increment the pc */

    full_instr = instruction = LOAD_CODE(pc);
    if (full_instr == F_EFUN0)
        full_instr = GET_CODE(pc) + EFUN0_OFFSET;
    else if (full_instr == F_EFUN1)
        full_instr = GET_CODE(pc) + EFUN1_OFFSET;
    else if (full_instr == F_EFUN2)
        full_instr = GET_CODE(pc) + EFUN2_OFFSET;
    else if (full_instr == F_EFUN3)
        full_instr = GET_CODE(pc) + EFUN3_OFFSET;
    else if (full_instr == F_EFUN4)
        full_instr = GET_CODE(pc) + EFUN4_OFFSET;
    else if (full_instr == F_EFUNV)
        full_instr = GET_CODE(pc) + EFUNV_OFFSET;

#if 0
    if (full_instr != instruction)
        printf("DEBUG: %p (%p): %3d %s %s\n"
              , pc-1, sp
              , full_instr, get_f_name(instruction), get_f_name(full_instr));
    else
        printf("DEBUG: %p (%p): %3d %s\n"
              , pc-1, sp
              , full_instr, get_f_name(full_instr));
    fflush(stdout);
#endif

#   ifdef TRACE_CODE
        /* Store some vitals in the trace buffer */

#       if TOTAL_TRACE_LENGTH & TOTAL_TRACE_LENGTH-1
            if (++last == TOTAL_TRACE_LENGTH)
                last = 0;
#       else
            last = (last+1) & (TOTAL_TRACE_LENGTH-1);
#       endif
        previous_instruction[last] = instruction;
        previous_pc[last] = pc-1;
        stack_size[last] = sp - fp - csp->num_local_variables;
        abs_stack_size[last] = sp - VALUE_STACK;
        if (previous_objects[last])
        {
            /* Need to free the previously stored object */
            free_object(previous_objects[last], "TRACE_CODE");
        }
        previous_objects[last] = ref_object(current_object, "TRACE_CODE");
        previous_programs[last] = current_prog;
#   endif  /* ifdef TRACE_CODE */

#   ifdef MALLOC_LPC_TRACE
        inter_pc = pc;
#   endif

#   ifdef OPCPROF
        opcount[full_instr]++;
#   endif

    /* If requested, trace the instruction.
     * Print the name of the instruction, but guard against recursions.
     */
    if (trace_exec_active && TRACE_EXEC_P && TRACE_IS_INTERACTIVE())
    {
        if (!++traceing_recursion)
        {
            inter_sp = sp;
            do_trace("Exec ", get_f_name(full_instr), "\n");
            instruction = EXTRACT_UCHAR(pc-1);
        }
        traceing_recursion--;
    }

    /* Test the evaluation cost.
     * eval_cost < 0 signify a wrap-around - unlikely, but with these crazy
     * wizards everything is possible.
     */
    if (add_eval_cost(1))
    {
        rt_context_t * context;

        /* Evaluation too long. Restore some globals and throw
         * an error.
         */

        printf("%s eval_cost too big %ld\n", time_stamp(), (long)eval_cost);

        assign_eval_cost_inl();

        /* If the error isn't caught, reset the eval costs */
        for (context = rt_context
            ; !ERROR_RECOVERY_CONTEXT(context->type)
            ; context = context->last
            ) NOOP;
        if (context->type <= ERROR_RECOVERY_BACKEND)
        {
            CLEAR_EVAL_COST;
            RESET_LIMITS;
        }

        inter_pc = pc;
        inter_fp = fp;
        ERROR("Too long evaluation. Execution aborted.\n");
    }

#if defined(DEBUG)

    /* Get the expected number of arguments and determined the expected
     * stack setting.
     * Note that the code deliberately looks at instruction and not
     * full_instr, as all multibyte instructions do not store the number
     * of arguments in code.
     */
    if (instrs[instruction].min_arg != instrs[instruction].max_arg
     && instruction != F_CALL_OTHER
     && instruction != F_CALL_DIRECT
       )
    {
        num_arg = GET_UINT8(pc);
        pc++;
    }
    else
    {
        /* Safety measure. It is supposed that the evaluator knows
         * the number of arguments.
         */
        num_arg = -1;
    }

    if (num_arg != -1 && !use_ap)
    {
        expected_stack = sp - num_arg +
            ( instrs[full_instr].ret_type.typeflags == TYPE_VOID ? 0 : 1 );
    }
    else if (use_ap)
    {
        expected_stack = ap -
            ( instrs[full_instr].ret_type.typeflags == TYPE_VOID ? 1 : 0 );
    }
    else
    {
        expected_stack = NULL;
    }
#endif /* DEBUG */

    /* The monster switch to execute the instruction.
     * The order of the cases is held (mostly) in the order
     * the instructions appear in func_spec.
     */
    inter_sp = sp;
    inter_pc = pc;
      /* TODO: This continual update is crude, but circumvents a lot
       * TODO:: of situations where an error is thrown but inter_sp
       * TODO:: is invalid (heck, every assign_svalue() could cause that). In
       * TODO:: the long run, we should do this only for efuns (which are by
       * TODO:: then hopefully all tabled).
       */
    switch(instruction)
    {
    default:
        fatal("Undefined instruction '%s' (%d)\n", get_f_name(instruction),
              instruction);
        /* NOTREACHED */
        return MY_FALSE; /* hint for data flow analysis */

#ifdef F_ILLEGAL
    CASE(F_ILLEGAL);                /* --- illegal             --- */
        inter_pc = pc;
        fatal("'illegal' instruction encountered.\n");
        /* NOTREACHED */
#endif /* F_ILLEGAL */

    CASE(F_UNDEF);                  /* --- undef               --- */
      {
        /* Catch-all instructions for declared but not implemented
         * (defined) functions. Usually used by the compiler to
         * handle prototypes (in that case it is the first and only
         * instruction of the generated stub), it is also inserted
         * into lambda closures when they referenced a function
         * that went missing because of a replace_program.
         *
         * Note: this instruction MUST be the first in the function.
         */

        string_t *name;

        /* pc has already been incremented */
        if (pc > current_prog->program && pc <= PROGRAM_END(*current_prog))
        {
            /* Copy the function name pointer into name.
             */
            memcpy(&name, FUNCTION_NAMEP(FUNCTION_FROM_CODE(pc-1)), sizeof name);
        }
        else
        {
            /* It is a lambda closure after a replace_program. */
            name = STR_DANGLING_LAMBDA;
        }
        ERRORF(("Undefined function: %s\n", get_txt(name)));
      }

    CASE(F_EFUN0);                  /* --- efun0 <code>        --- */
    {
        /* Call the tabled efun EFUN0_OFFSET + <code>, where <code> is
         * a uint8.
         * The efun takes no argument.
         */

        int code;

        /* Check the number of arguments on the stack */
        if (use_ap)
        {
            int numarg = sp - ap + 1;

            if (numarg < 0)
                ERRORF(("Not enough args for %s: got %d, expected none.\n"
                       , instrs[instruction].name, numarg));
            if (numarg > 0)
                ERRORF(("Too many args for %s: got %d, expected none.\n"
                       , instrs[instruction].name, numarg));
            use_ap = MY_FALSE;
        }

        code = LOAD_UINT8(pc);
#ifdef TRACE_CODE
        previous_instruction[last] = code + EFUN0_OFFSET;
#endif
#ifdef OPCPROF
        opcount[code+EFUN0_OFFSET]++;
#endif
        inter_sp = sp;
        inter_pc = pc;
        assign_eval_cost_inl();
        sp = (*efun_table[code+EFUN0_OFFSET-TEFUN_OFFSET])(sp);
#ifdef CHECK_OBJECT_REF
        check_all_object_shadows();
#endif /* CHECK_OBJECT_REF */
        break;
    }

    CASE(F_EFUN1);                  /* --- efun1 <code>        --- */
    {
        /* Call the tabled efun EFUN1_OFFSET + <code>, where <code> is
         * a uint8.
         * The efun takes one argument.
         */

        int code;

        code = LOAD_UINT8(pc);
        instruction = code + EFUN1_OFFSET;

        /* Correct then number of arguments on the stack */
        if (use_ap)
        {
            int numarg = sp - ap + 1;
            int def;

            if (numarg == 0 && (def = instrs[instruction].Default) != 0)
            {
                put_default_argument(++sp, def);
                numarg++;
            }

            if (numarg < 1)
                ERRORF(("Not enough args for %s: got %d, expected 1.\n"
                       , instrs[instruction].name, numarg));
            if (numarg > 1)
                ERRORF(("Too many args for %s: got %d, expected 1.\n"
                       , instrs[instruction].name, numarg));
            use_ap = MY_FALSE;
        }

#ifdef TRACE_CODE
        previous_instruction[last] = instruction;
#endif
#ifdef OPCPROF
        opcount[instruction]++;
#endif
        inter_sp = sp;
        inter_pc = pc;
        assign_eval_cost_inl();
        test_efun_args(instruction, 1, sp);
        sp = (*efun_table[instruction-TEFUN_OFFSET])(sp);
#ifdef CHECK_OBJECT_REF
        check_all_object_shadows();
#endif /* CHECK_OBJECT_REF */
        break;
    }

    CASE(F_EFUN2);                  /* --- efun2 <code>        --- */
    {
        /* Call the tabled efun EFUN2_OFFSET + <code>, where <code> is
         * a uint8.
         * The efun takes two arguments.
         */

        int code;

        code = LOAD_UINT8(pc);
        instruction = code + EFUN2_OFFSET;

        /* Correct then number of arguments on the stack */
        if (use_ap)
        {
            int numarg = sp - ap + 1;
            int def;

            if (numarg == 1 && (def = instrs[instruction].Default) != 0)
            {
                put_default_argument(++sp, def);
                numarg++;
            }

            if (numarg < 2)
                ERRORF(("Not enough args for %s: got %d, expected 2.\n"
                       , instrs[instruction].name, numarg));
            if (numarg > 2)
                ERRORF(("Too many args for %s: got %d, expected 2.\n"
                       , instrs[instruction].name, numarg));
            use_ap = MY_FALSE;
        }

#ifdef TRACE_CODE
        previous_instruction[last] = instruction;
#endif
#ifdef OPCPROF
        opcount[instruction]++;
#endif
        inter_sp = sp;
        inter_pc = pc;
        assign_eval_cost_inl();
        test_efun_args(instruction, 2, sp-1);
        sp = (*efun_table[instruction-TEFUN_OFFSET])(sp);
#ifdef CHECK_OBJECT_REF
        check_all_object_shadows();
#endif /* CHECK_OBJECT_REF */
        break;
    }

    CASE(F_EFUN3);                  /* --- efun3 <code>        --- */
    {
        /* Call the tabled efun EFUN3_OFFSET + <code>, where <code> is
         * a uint8.
         * The efun takes three arguments.
         */

        int code;

        code = LOAD_UINT8(pc);
        instruction = code + EFUN3_OFFSET;

        /* Correct then number of arguments on the stack */
        if (use_ap)
        {
            int numarg = sp - ap + 1;
            int def;

            if (numarg == 2 && (def = instrs[instruction].Default) != 0)
            {
                put_default_argument(++sp, def);
                numarg++;
            }

            if (numarg < 3)
                ERRORF(("Not enough args for %s: got %d, expected 3.\n"
                       , instrs[instruction].name, numarg));
            if (numarg > 3)
                ERRORF(("Too many args for %s: got %d, expected 3.\n"
                       , instrs[instruction].name, numarg));
            use_ap = MY_FALSE;
        }


#ifdef TRACE_CODE
        previous_instruction[last] = instruction;
#endif
#ifdef OPCPROF
        opcount[instruction]++;
#endif
        inter_sp = sp;
        inter_pc = pc;
        assign_eval_cost_inl();
        test_efun_args(instruction, 3, sp-2);
        sp = (*efun_table[instruction-TEFUN_OFFSET])(sp);
#ifdef CHECK_OBJECT_REF
        check_all_object_shadows();
#endif /* CHECK_OBJECT_REF */
        break;
    }

    CASE(F_EFUN4);                  /* --- efun4 <code>        --- */
    {
        /* Call the tabled efun EFUN4_OFFSET + <code>, where <code> is
         * a uint8.
         * The efun takes four arguments.
         */

        int code;

        code = LOAD_UINT8(pc);
        instruction = code + EFUN4_OFFSET;

        /* Correct then number of arguments on the stack */
        if (use_ap)
        {
            int numarg = sp - ap + 1;
            int def;

            if (numarg == 3 && (def = instrs[instruction].Default) != 0)
            {
                put_default_argument(++sp, def);
                numarg++;
            }

            if (numarg < 4)
                ERRORF(("Not enough args for %s: got %d, expected 4.\n"
                       , instrs[instruction].name, numarg));
            if (numarg > 4)
                ERRORF(("Too many args for %s: got %d, expected 4.\n"
                       , instrs[instruction].name, numarg));
            use_ap = MY_FALSE;
        }

#ifdef TRACE_CODE
        previous_instruction[last] = instruction;
#endif
#ifdef OPCPROF
        opcount[instruction]++;
#endif
        inter_sp = sp;
        inter_pc = pc;
        assign_eval_cost_inl();
        test_efun_args(instruction, 4, sp-3);
        sp = (*efun_table[instruction-TEFUN_OFFSET])(sp);
#ifdef CHECK_OBJECT_REF
        check_all_object_shadows();
#endif /* CHECK_OBJECT_REF */
        break;
    }

    CASE(F_EFUNV);                  /* --- efunv <code>        --- */
    {
        /* Call the tabled efun EFUNV_OFFSET + <code>, where <code> is
         * a uint8, with the number of arguments determined through the
         * ap pointer.
         * The number of arguments accepted by the efun is given by the
         * .min_arg and .max_arg entries in the instrs[] table.
         */

        int code;
        int min_arg, max_arg, numarg;

        code = LOAD_UINT8(pc);
        instruction = code + EFUNV_OFFSET;

        numarg = sp - ap + 1;
        use_ap = MY_FALSE;

#ifdef TRACE_CODE
        previous_instruction[last] = instruction;
#endif
#ifdef OPCPROF
        opcount[instruction]++;
#endif

        inter_sp = sp;
        inter_pc = pc;
        assign_eval_cost_inl();

        min_arg = instrs[instruction].min_arg;
        max_arg = instrs[instruction].max_arg;

        if (numarg < min_arg)
            ERRORF(("Not enough args for %s: got %d, expected %d.\n"
                   , instrs[instruction].name, numarg, min_arg));
        if (max_arg >= 0 && numarg > max_arg)
            ERRORF(("Too many args for %s: got %d, expected %d.\n"
                   , instrs[instruction].name, numarg, max_arg));

        test_efun_args(instruction, max_arg >= 0 ? numarg : min_arg
                      , sp-numarg+1);
        sp = (*vefun_table[instruction-EFUNV_OFFSET])(sp, numarg);
#ifdef CHECK_OBJECT_REF
        check_all_object_shadows();
#endif /* CHECK_OBJECT_REF */
        break;
    }

    /* --- Predefined functions with counterparts in LPC --- */

    CASE(F_IDENTIFIER);             /* --- identifier <var_ix> --- */
        /* Push value of object variable <var_ix>.
         * It is possible that it is a variable that points to
         * a destructed object. In that case, it has to be replaced by 0.
         *
         * <var_ix> is a uint8.
         */
        sp++;
        assign_checked_svalue_no_free(sp, find_value((int)(LOAD_UINT8(pc))) );
        break;

    CASE(F_STRING);                /* --- string <ix>          --- */
    {
        /* Push the string current_strings[<ix>] onto the stack,
         * <ix> being a (16-Bit) ushort, stored low byte first.
         * See also the F_CSTRINGx functions.
         */
        unsigned short string_number;

        LOAD_SHORT(string_number, pc);
        push_ref_string(sp, current_strings[string_number]);
        break;
    }

    CASE(F_CSTRING3);               /* --- cstring3 <ix>       --- */
    {
        /* Push the string current_strings[0x3<ix>] onto the stack.
         * <ix> is a 8-Bit uint.
         */
        unsigned int ix = LOAD_UINT8(pc);
        push_ref_string(sp, current_strings[ix+0x300]);
        break;
    }

    CASE(F_CSTRING2);               /* --- cstring2 <ix>       --- */
    {
        /* Push the string current_strings[0x2<ix>] onto the stack.
         * <ix> is a 8-Bit uint.
         */
        unsigned int ix = LOAD_UINT8(pc);
        push_ref_string(sp, current_strings[ix+0x200]);
        break;
    }

    CASE(F_CSTRING1);               /* --- cstring1 <ix>       --- */
    {
        /* Push the string current_strings[0x1<ix>] onto the stack.
         * <ix> is a 8-Bit uint.
         */
        unsigned int ix = LOAD_UINT8(pc);
        push_ref_string(sp, current_strings[ix+0x100]);
        break;
    }

    CASE(F_CSTRING0);               /* --- cstring0 <ix>       --- */
    {
        /* Push the string current_strings[0x0<ix>] onto the stack.
         * <ix> is a 8-Bit uint.
         */
        unsigned int ix = LOAD_UINT8(pc);
        push_ref_string(sp, current_strings[ix]);
        break;
    }

    CASE(F_NUMBER);                 /* --- number <num>        --- */
    {
        /* Push the number <num> onto the stack.
         * <num> is a p_int stored in the host format.
         * See also the F_CONSTx functions.
         * TODO: It should be rewritten to use the LOAD_ macros (but
         * TODO:: then the compiler needs to use them, too.
         */
        sp++;
        sp->type = T_NUMBER;
        memcpy(&sp->u.number, pc, sizeof sp->u.number);
        pc += sizeof sp->u.number;
        break;
    }

    CASE(F_CONST0);                 /* --- const0              --- */
        /* Push the number 0 onto the stack.
         */
        push_number(sp, 0);
        break;

    CASE(F_CONST1);                 /* --- const1              --- */
        /* Push the number 1 onto the stack.
         */
        push_number(sp, 1);
        break;

    CASE(F_NCONST1);                /* --- nconst1             --- */
        /* Push the number -1 onto the stack.
         */
        push_number(sp, -1);
        break;

    CASE(F_CLIT);                   /* --- clit <num>          --- */
    {
        /* Push the number <num> onto the stack.
         * <num> is a 8-Bit uint.
         */
        push_number(sp, (p_int)LOAD_UINT8(pc));
        break;
    }

    CASE(F_NCLIT);                  /* --- nclit <num>         --- */
    {
        /* Push the number -<num> onto the stack.
         * <num> is a 8-Bit uint.
         */
        push_number(sp, -(p_int)LOAD_UINT8(pc));
        break;
    }

    CASE(F_FCONST0);                /* --- fconst0             --- */
    {
        /* Push the float 0.0 onto the stack.
         * The binary format is the one determined by STORE_DOUBLE in
         * datatypes.h
         * TODO: This code makes heavy assumptions about data sizes and
         * TODO:: layout. E.g. there need not be a 16-Bit integral type
         * TODO:: available.
         * TODO: It should be rewritten to use the LOAD_ macros (but
         * TODO:: then the compiler needs to use them, too.
         */

        double zero = 0.0;
        STORE_DOUBLE_USED

        sp++;
        sp->type = T_FLOAT;
        STORE_DOUBLE(sp, zero);
        break;
    }

    CASE(F_FLOAT);                  /* --- float <mant> <exp>  --- */
    {
        /* Push the float build from <mant> (4 bytes) and <exp> (2 bytes)
         * onto the stack. The binary format is the one determined
         * by STORE_DOUBLE in datatypes.h
         * TODO: This code makes heavy assumptions about data sizes and
         * TODO:: layout. E.g. there need not be a 16-Bit integral type
         * TODO:: available.
         * TODO: short doesn't to be a 16 bit wide type (which the float format
         * TODO:: expects). LOAD_INT16 would be nice (change in compiler as well).
         */

        int32 mantissa;
        short exponent;

        sp++;
        sp->type = T_FLOAT;
        LOAD_INT32(mantissa, pc);
        LOAD_SHORT(exponent, pc);
        sp->u.mantissa = mantissa;
        sp->x.exponent = exponent;
        break;
    }

    CASE(F_CLOSURE);            /* --- closure <ix> <inhIndex> --- */
#ifdef USE_NEW_INLINES
    CASE(F_CONTEXT_CLOSURE); /* --- context_closure <ix> <vix> <num_ex> <num_im> --- */
#endif /* USE_NEW_INLINES */
    {
        /* Push the closure value <ix> and <inhIndex> onto the stack.
         * Both <ix> and <inhIndex> are uint16, stored low byte first.
         *
         * For <ix>:
         * Values 0xf000..0xffff are efun and simul-efun symbols, the others
         * are operators and literals (0xf000 == CLOSURE_EFUN_OFFS)
         * Simul-efun symbols (0xf800..0xffff) and true efun symbolx (0xf000..
         * 0xf7ff for which instrs[].Default >= 0) are made signed and stored
         * as they are. (0xf800 == CLOSURE_SIMUL_EFUN_OFFS)
         * Operator symbols (0xf000..0xf7ff for which instrs[].Default == -1)
         * are moved into their 0xe800..0xefff range, then made signed and
         * stored.
         *
         * For <inhIndex>:
         * If not 0 for lfun closures, it is the (inheritance index + 1)
         * of the directly referenced inherited function.
#ifdef USE_NEW_INLINES
         *
         * If it is a context closure, the context is sized to
         * uint16 <num_ex>+<num_in> values, uint16 <num_ex> values
         * are taken from the local variables beginning at <vix>,
         * uint16 <num_im> values are taken from the stack.
#endif
         */

        /* TODO: uint16 */ unsigned short tmp_ushort;
        /* TODO: int32 */ int ix;
        /* TODO: uint16 */ unsigned short inhIndex;
#ifdef USE_NEW_INLINES
        unsigned short explicit_context_size, implicit_context_size;
        svalue_t * explicit_context;
#endif /* USE_NEW_INLINES */

        inhIndex = 0;
#ifdef USE_NEW_INLINES
        explicit_context_size = implicit_context_size = 0;
#endif /* USE_NEW_INLINES */
        LOAD_SHORT(tmp_ushort, pc);
#ifdef USE_NEW_INLINES
        if (instruction == F_CONTEXT_CLOSURE)
        {
            explicit_context = fp + LOAD_UINT8(pc);
            LOAD_SHORT(explicit_context_size, pc);
            LOAD_SHORT(implicit_context_size, pc);
        }
        else
        {
            explicit_context = NULL; /* Makes the compiler happy. */
            LOAD_SHORT(inhIndex, pc);
        }
#else /* USE_NEW_INLINES */
        LOAD_SHORT(inhIndex, pc);
#endif /* USE_NEW_INLINES */

        ix = tmp_ushort;
        if (ix < CLOSURE_EFUN_OFFS)
        {
            sp++;
            inter_sp = sp;
            inter_pc = pc;
#ifndef USE_NEW_INLINES
            closure_literal(sp, ix, inhIndex);
#else /* USE_NEW_INLINES */
            closure_literal(sp, ix, inhIndex, explicit_context_size + implicit_context_size);
#endif /* USE_NEW_INLINES */
            /* If out of memory, this will set sp to svalue-0 and
             * throw an error.
             */

#ifdef USE_NEW_INLINES
#ifdef DEBUG
            if (instruction == F_CONTEXT_CLOSURE
             && sp->x.closure_type != CLOSURE_LFUN
               )
                fatal("(eval_instruction) context_closure used for non-lfun "
                      "closure type %d.\n", sp->x.closure_type);
#endif
            /* Now copy the context values */
            if (explicit_context_size != 0)
            {
                unsigned short i;
                svalue_t * context = sp->u.lambda->context;

                for (i = 0; i < explicit_context_size; i++)
                {
                    transfer_svalue_no_free(context+i, explicit_context+i);

                    /* Set it to T_INVALID, as it is still a variable of
                     * the function frame and will be freed on return.
                     */
                    explicit_context[i].type = T_INVALID;
                }
            }

            if (implicit_context_size != 0)
            {
                unsigned short i;
                svalue_t * arg = sp - implicit_context_size;
                svalue_t * context = sp->u.lambda->context + explicit_context_size;

                for (i = 0; i < implicit_context_size; i++)
                    transfer_svalue_no_free(context+i, arg+i);

                /* Now move the created closure to the new top of the stack */
                *arg = *sp;
                inter_sp = sp = arg;
            }
#endif /* USE_NEW_INLINES */
        }
        else
        {
#ifdef USE_NEW_INLINES
#ifdef DEBUG
            if (instruction == F_CONTEXT_CLOSURE)
                fatal("(eval_instruction) context_closure used for non-lfun.\n");
#endif
#endif /* USE_NEW_INLINES */
            sp++;
            sp->type = T_CLOSURE;
            sp->u.ob = ref_object(current_object, "closure");
            if (ix >= CLOSURE_SIMUL_EFUN_OFFS)
            {
                /* Sefun closure */
                sp->x.closure_type = (short)ix;
            }
            else
            {
                /* Efun or operator closure */
                if (!runtime_no_warn_deprecated
                 && instrs[ix - CLOSURE_EFUN_OFFS].deprecated != NULL)
                {
                    WARNF(("Warning: %s() is deprecated: %s\n"
                          , instrs[ix - CLOSURE_EFUN_OFFS].name
                          , instrs[ix - CLOSURE_EFUN_OFFS].deprecated
                         ));
                }

                sp->x.closure_type
                  = (short)(  instrs[ix - CLOSURE_EFUN_OFFS].Default == -1
                            ? ix + CLOSURE_OPERATOR-CLOSURE_EFUN
                            : ix);
            }
        }
        break;
    }

    CASE(F_SYMBOL);                 /* --- symbol <ix> <num>   --- */
    {
        /* Push a symbol of current_strings[<ix>] with <num> quotes
         * onto the stack.
         * <ix> is a uint16, stored low byte first. <num> is a uint8.
         */

        /* TODO: uint16 */ unsigned short string_number;

        LOAD_SHORT(string_number, pc);

        sp++;
        sp->type = T_SYMBOL;
        sp->x.quotes = LOAD_UINT8(pc);
        sp->u.str = ref_mstring(current_strings[string_number]);
        break;
    }

    CASE(F_DEFAULT_RETURN);         /* --- default_return      --- */
        /* Inserted at the end of value-returning function, this instruction
         * provides a default 'return 0' in case the programmer forgot about
         * it. The instruction also prints a warning so that the code can be
         * corrected.
         */
        warnf("Missing 'return <value>' statement.\n");

        /* Warn only once per missing return and program. */
        PUT_UINT8(pc-1, F_RETURN0);
        /* FALLTHROUGH */

    CASE(F_RETURN0);                /* --- return0             --- */
        /* Return from the function with result value 0.
         */
        push_number(sp, 0);
        /* FALLTHROUGH */

    CASE(F_RETURN);                 /* --- return              --- */
    {
        /* Return from the function with the result topmost on the stack.
         * If this is an .extern_call, eval_instruction()
         * is left here.
         */

        svalue_t *pResult;  /* Return value on stack */
        svalue_t *efp = fp+csp->num_local_variables; /* Expected end of frame */

        pResult = sp;

        /* Remove any intermediate error contexts */
        while (csp->catch_call)
        {
            pop_control_stack();
            pop_error_context();
        }

        /* The caller might have a yet-unterminated SAVE_ARG_FRAME in
         * effect (this can happen in lambda closures, when the subclosure
         * to compute an efun argument executes a #'return) - undo them.
         */

        while (ap && ap > efp)
        {
            while (sp > ap)
                free_svalue(--sp);
            sp = ap-1;
            ap = sp->u.lvalue;
        }

        /* Deallocate frame, but not the result value.
         */
#ifdef DEBUG
        if (efp > sp)
            fatal("Bad stack at F_RETURN, %"PRIdMPINT" values too low\n"
                 , (mp_int)(efp - sp));
        else if (efp < sp)
            fatal("Bad stack at F_RETURN, %"PRIdMPINT" values too high\n"
                 , (mp_int)(sp - efp));
#endif
        while (sp != fp)
        {
            free_svalue(--sp);
        }
        *sp = *pResult;

        /* Restore the previous execution context */
        if ( NULL != (current_prog = csp->prog) ) /* is 0 when we reach the bottom */
        {
            current_strings = current_prog->strings;
        }

        function_index_offset = csp->function_index_offset;
        current_variables     = csp->current_variables;
        break_sp = csp->break_sp;
#ifdef USE_NEW_INLINES
        inter_context = csp->context;
#endif /* USE_NEW_INLINES */
        if (current_lambda.type == T_CLOSURE)
            free_closure(&current_lambda);
        current_lambda = csp->lambda;

        tracedepth--; /* We leave this level */

        if (csp->extern_call)
        {
            /* eval_instruction() must be left - setup the globals */

            assign_eval_cost_inl();
            current_object = csp->ob;
            previous_ob = csp->prev_ob;
            inter_pc = csp->pc;
            inter_fp = csp->fp;

            if (trace_level)
            {
                do_trace_return(sp);
                if (csp == CONTROL_STACK - 2)
                    /* TODO: This can't be legal according to ISO C */
                    traceing_recursion = -1;
            }
            csp--;
            inter_sp = sp;
#ifdef CHECK_OBJECT_REF
            check_all_object_shadows();
#endif /* CHECK_OBJECT_REF */
            return MY_FALSE;
        }

        /* We stay in eval_instruction() */

        if (trace_level)
            do_trace_return(sp);
        pc = csp->pc;
        fp = csp->fp;
        csp--;
        break;
    }

    CASE(F_BREAK);                  /* --- break               --- */
    {
        /* Break out of a switch() by pulling the continuation address
         * from the break stack.
         */

        pc = *break_sp;
        break_sp += sizeof(svalue_t)/sizeof(*break_sp);
        break;
    }

    CASE(F_SWITCH);            /* --- switch <lots of data...> --- */
    {
        /* The switch()-Statement: pop the topmost value from the stack,
         * search it in the given case values and set the pc to the
         * associated code. Also push the address of the next instruction
         * as break address onto the break stack.
         *
         * The compiler makes sure that there is always a 'default' case
         * and that all execution paths eventually execute a F_BREAK.
         *
         * The layout created by the LPC compiler is this:
         *
         *     switch b1 a2 b2 [b3 [b4] ]
         *            instructions (sans the first byte 'i0')...
         *            l[]
         *            [c0 [c1]]
         *            a0 a1 i0
         *            v*n
         *            o*n
         *            [d0]
         *
         * b1 & 0x03 is 0, marking this switch statement as unaligned.
         * Since for an efficient search the tables v*n and o*n must be
         * 4-Byte aligned (TODO: on some machines 8-Byte), the interpreter
         * will on first execution of such a switch align it (using
         * closure:align_switch()) by arranging the bytes a0..a2 around
         * the tables. The aligned layout is this:
         *
         *     switch b1 b2 [b3 [b4] ]
         *            instructions...
         *            l[]
         *            [c0 [c1]]            <-- p0 = pc + offset
         *            a0..
         *            v[]                  <-- tabstart
         *            o[]                  <-- end_tab = pc + offset + tablen
         *            ..a2                 <-- p1
         *            [d0]
         *
         *  b1 (bits 1..0) = len: the length in bytes needed to store
         *        'offset', 'tablen', 'default offset', 'o*n' and the
         *        length of lookup tables for table ranges.
         *  b1 (bits 7..2) = tablen lo
         *  c0 = tablen mid (optional)
         *  c1 = tablen hi  (optional)
         *  b2 = offset lo
         *  b3 = offset med (optional)
         *  b4 = offset hi  (optional)
         *  a0, a1 = default-case offset lo and med in host byte order
         *  d0     = default-case offset hi (optional)
         *  a2 'type' (bits 0..4): start position for search (used to index
         *                         a table with the real offsets)
         *            (bit  5)   : 0: numeric switch , 1: string switch
         *            (bits 6..7): in an unaligned switch, the true value
         *                         of <len> (b1, bits 1..0).
         *  l[]: range lookup table: each <len> bytes, network byte order
         *       (numeric switch only)
         *  v[]: case values, string_t* or p_int, host byte order
         *  o[]: case offsets : each <len> bytes, network byte order
         *
         * The case value table v[] holds (sorted numerically) all values
         * appearing in the case statements, both singular values and range
         * bounds. Range bound values (which are inclusive) always appear
         * next to each other.
         *
         * The offset table o[] holds the associated offset with
         * this interpretation:
         *
         *   singular cases: jump destination offsets relative to pc.
         *
         *   range cases:    the 'offset' for the lower bound is 1, the
         *                   offset for the upper bound gives the jump
         *                   destination relative to pc.
         *
         *   lookup ranges:  the 'offset' for the lower bound is 0, the
         *                   offset for the upper bound is an offset
         *                   pointing into the lookup table.
         *                   The real jump offset is then
         *                     l[o[i] + <value> - lower-bound].
         *
         *   The lookup ranges are used for an efficient implementation of
         *   sparse ranges like 'case 0: case 2: case 5: ...'.
         *
         *   TODO: This code still makes too many un-macro'ed mem accesses.
         */

        Bool useDefault; /* TRUE: Immediately jump to the default case */
        mp_int offset;  /* Length of instruction and range-table area */
        mp_int def_offs;  /* Offset to code for the 'default' case */
        int tablen; /* Number of single case entries, multiplied by 4 */
        int len;    /* Number of bytes per offset/length value (1..3) */
        int type;   /* Start position for search */
        static int32 off_tab[] = {
                0*sizeof(char*), 0x00001*sizeof(char*), 0x00003*sizeof(char*),
          0x00007*sizeof(char*), 0x0000f*sizeof(char*), 0x0001f*sizeof(char*),
          0x0003f*sizeof(char*), 0x0007f*sizeof(char*), 0x000ff*sizeof(char*),
          0x001ff*sizeof(char*), 0x003ff*sizeof(char*), 0x007ff*sizeof(char*),
          0x00fff*sizeof(char*), 0x01fff*sizeof(char*), 0x03fff*sizeof(char*),
          0x07fff*sizeof(char*), 0x0ffff*sizeof(char*), 0x1ffff*sizeof(char*),
          0x3ffff*sizeof(char*), 0x7ffff*sizeof(char*)
        };
          /* Start offsets for the binary search for different table sizes.
           * This table is indexed by <type> & 0x1f, and the compiler choses
           * the start position to be the first power of 2 which is at least
           * half the table size. This way the search algorithm only needs
           * to check for the upper table end.
           * TODO: Is the choice really so?
           */
        bytecode_p p0;
          /* Points after the range lookup tables (initially). */
        bytecode_p p1;
          /* Points to the table of offsets. */
        bytecode_p tabstart;
          /* Points to the 'v*n' table of cases */
        bytecode_p end_tab;
          /* Points to the 'o*n' table of offsets for the cases */
        bytecode_p break_addr;
          /* Address of the first bytecode after the switch, will be pushed
           * onto the break stack.
           */
        mp_int s;
          /* Search value for the lookup, derived from the stack value.
           * It is either u.number or the numeric value of u.string.
           */
        /* TODO: opcode? */ unsigned char *l;
          /* Current search pointer into the value table v[] */
        mp_int r;
          /* Current value retrieved from *<l> */
        mp_int d;
          /* Half the distance between <l> and the current upper resp. lower
           * bound of the search partition
           */
        /* TODO: opcode? */ unsigned char *p2;
          /* For a found case, the pointer into o[] */
        mp_int o0, o1;
          /* The offsets read from *(p2-1) and *p2, resp. *p2 and *(p2+1) */
        int i; /* Temporary */

        /* Extract the basic tablen and len */
        tablen = EXTRACT_UCHAR(pc);
        if ( !(len = tablen & SWITCH_VALUELEN) )
        {
            /* Oops, first lets align the switch */
            align_switch(pc);
            tablen = EXTRACT_UCHAR(pc);
            len = tablen & SWITCH_VALUELEN;
        }
        tablen &= ~SWITCH_VALUELEN;
        /* SWITCH_TABLEN_SHIFT is 2, so don't need to do
         *   tablen = (tablen >> SWITCH_TABLEN_SHIFT) * 4
         */

        /* Get the offset, aka the length of instruction and range table
         * part, and let p0 point after them.
         */
        offset = EXTRACT_UCHAR(pc+1);
        if (len > 1)
        {
            offset += EXTRACT_UCHAR(pc+2) << 8;
            if (len > 2)
            {
                offset += EXTRACT_UCHAR(pc+3) << 16;
            }
        }
        p0 = pc + offset;

        /* Get the full tablen, aka the number of single case entries,
         * and set p1 to point _after_ the offset table 'o*n'.
         * The computed formula is
         *
         *   p1 = p0 + tablen * sizeof(char*) + tablen * len * sizeof(char)
         *               (length of v*n)           (length of o*n)
         *
         * with the code taking into account that the _variable_ tablen
         * already comes as 'tablen * sizeof(char*)'.
         */
        if (len > 1)
        {
            tablen += *(unsigned char *)(p0++) << 8;
            if (len > 2)
            {
                tablen += *(unsigned char *)(p0++) << 16;
#if SIZEOF_CHAR_P == 4
                p1 = (unsigned char *)(p0 + (tablen << 1) - (tablen >> 2));
            }
            else
            {
                p1 = (unsigned char *)(p0 + tablen + (tablen >> 1));
#else
                p1 = (unsigned char *)(p0 + tablen + tablen*3/sizeof(p_int) );
            }
            else
            {
                p1 = (unsigned char *)(p0 + tablen + tablen*2/sizeof(p_int) );
#endif
            }
        }
        else
        {
            p1 = (unsigned char *)(p0 + tablen + tablen / sizeof(p_int) );
        }

        /* Gather the 'default offset' and the 'type' from the alignment
         * bytes before v[] (pointer to by p0) and the bytes after
         * o[] (pointed to by p1).
         * Set 'tabstart' to the real start of 'v*n'.
         * Set 'break_addr' to the first instruction after the switch.
         */

        {
            int a, b;
            union { unsigned char b[sizeof(p_int)-1]; unsigned short s; } abuf;
              /* TODO: Assumes sizeof(p_int)-1 >= sizeof(short) */
              /* TODO: Assumes sizeof(p_int) == 4 */
              /* TODO: Assumes sizeof(short) == 2 */

            /* Gather the bytes a0..a2 into abuf.b[] */
            b = (int)(((p_int)p0-1) & sizeof abuf.b);
              /* The number of a-bytes after 'o*n' */
            memcpy((char *)abuf.b, p0, sizeof abuf.b);
            a = (int)(sizeof abuf.b - b);
              /* The number of remaining bytes */
            memcpy((char *)(abuf.b + a), (char *)(p1 + a), (size_t)b);
            def_offs = abuf.s;
            type = abuf.b[2];
            if (len > 2)
            {
                def_offs += p1[sizeof(p_int)-1] << 16;
                break_addr = p1 + sizeof(p_int);
            }
            else
            {
                break_addr = p1 + sizeof(p_int)-1;
            }
            tabstart = p0 + a;
        }

        /* Set 'end_tab' to point to the 'o*n' table,
         * push the break address onto the break stack.
         */
        end_tab  = tabstart + tablen;
        break_sp -= sizeof(svalue_t)/sizeof(*break_sp);
        *break_sp = break_addr;

        /* Get the search value from the argument passed on the
         * stack. This also does the type checking.
         */
        useDefault = MY_FALSE;
        if (type & SWITCH_TYPE)
        {
            /* String switch */

            if ( sp->type == T_NUMBER && !sp->u.number )
            {
                /* Special case: uninitialized string '0'.
                 * Use a magic value for this one.
                 */
                s = (mp_int)ZERO_AS_STR_CASE_LABEL;
            }
            else if ( sp->type == T_STRING )
            {
                /* The case strings in the program shared, so whatever
                 * string we get on the stack, it must at least have
                 * a shared twin to be sensible. Get the address of
                 * that twin.
                 */
                s = (mp_int)find_tabled(sp->u.str);
            }
            else
            {
                /* Non-string value for string switch: use default */
                useDefault = MY_TRUE;
                s = 0;
            }
        }
        else if (sp->type == T_NUMBER)
        {
            /* Numeric switch and number given */
            s = sp->u.number;
        }
        else
        {
            /* Non-number value for numeric switch: use default */
            useDefault = MY_TRUE;
            s = 0;
        }
        pop_stack();

        if (useDefault)
        {
            o1 = def_offs;
        }
        else
        {
            /* Setup the binary search:
             *   l points roughly into the middle of the table,
             *   d is 1/4 of the (assumed) total size of the table
             */
            i = type & SWITCH_START;
            l = tabstart + off_tab[i];
            d = (mp_int)((off_tab[i]+sizeof(p_int)) >> 1 & ~(sizeof(p_int)-1));
              /* '+sizeof()' to make the off_tab[] value even and non-0 */

            /* Binary search for the value <s> in the table, starting at
             * position <l> and first subdivision size <d>.
             * The algorithm runs until <d> falls below the size of a case value
             * (sizeof(p_int)).
             *
             * After the loop terminates, o1 will be the jump offset relative
             * to the pc, which might be the 'default' offset if the value <s>
             * was not found.
             */
            for(;;)
            {
                r = *(p_int*)l; /* Get the case value */

                if (s < r)
                {

                    /* --- s < r --- */

                    if (d < (mp_int)sizeof(p_int))
                    {
                        if (!d)
                        {
                            /* End of search: s not found.
                             *
                             * Set p2 to the offset matching <l> and retrieve
                             * o0 and o1 from there.
                             *
                             * s might still be in a range, then <l>/<p2> point to
                             * the entries for the upper bound.
                             */
                            p2 =   tabstart + tablen
                                 + ((p_int*)l - (p_int*)tabstart)*len;
                            o0 = EXTRACT_UCHAR(p2-1);
                            o1 = EXTRACT_UCHAR(p2);
                            if (len > 1)
                            {
                                o0 += EXTRACT_UCHAR(p2-2) << 8;
                                o1 = EXTRACT_UCHAR(p2+1) + (o1 << 8);
                                if (len > 2)
                                {
                                    o0 += EXTRACT_UCHAR(p2-3) << 16;
                                    o1 = EXTRACT_UCHAR(p2+2) + (o1 << 8);
                                }
                            }
                            /* Because the pre-table alignment area is in the
                             * indexing underflow memory region, we can't make
                             * useful predictions on the peeked o0 value in case
                             * of underflow.
                             */

                            /* Test for a range */

                            if (o0 <= 1 && l > tabstart)
                            {
                                /* No indexing underflow: test if s is in range */

                                r = ((p_int*)l)[-1]; /* the lower bound */
                                if (s >= r)
                                {
                                    /* s is in the range */
                                    if (!o0)
                                    {
                                        /* Look up the real jump offset */
                                        l = pc + o1 + (s-r) * len;
                                        o1 = 0;
                                        i = len;
                                        do {
                                            o1 = (o1 << 8) + *l++;
                                        } while (--i);
                                        break;
                                    }
                                    /* o1 holds jump destination */
                                    break;
                                }
                                /* s is not in the range */
                            }

                            /* <s> not found at all: use 'default' address */
                            o1 = def_offs;

                            /* o1 holds jump destination */
                            break;
                        } /* if (!d) */

                        /* Here is 0 < d < sizeof(p_int).
                         * Set d = 0 and finish the loop in the next
                         * iteration.
                         * TODO: Why the delay?
                         */
                        d = 0;
                    }
                    else
                    {
                        /* Move <l> down and half the partition size <d>. */
                        l -= d;
                        d >>= 1;
                    }
                }
                else if (s > r)
                {

                    /* --- s > r --- */

                    if (d < (mp_int)sizeof(p_int))
                    {
                        if (!d)
                        {
                            /* End of search: s not found.
                             *
                             * Set p2 to the offset matching <l> and retrieve
                             * o0 and o1 from there.
                             *
                             * s might still be in a range, then <l> points to
                             * the entry of the lower bound, and <p2> is set to
                             * the entry for the upper bound.
                             */
                            p2 = tabstart + tablen
                                 + (((p_int*)l - (p_int*)tabstart) + 1)*len;
                            o0 = EXTRACT_UCHAR(p2-1);
                            o1 = EXTRACT_UCHAR(p2);
                            if (len > 1)
                            {
                                o0 += EXTRACT_UCHAR(p2-2) << 8;
                                o1 = EXTRACT_UCHAR(p2+1) + (o1 << 8);
                                if (len > 2)
                                {
                                    o0 += EXTRACT_UCHAR(p2-3) << 16;
                                    o1 = EXTRACT_UCHAR(p2+2) + (o1 << 8);
                                }
                            }

                            /* Test for a range */

                            if (o0 <= 1)
                            {
                                /* It is a range. */

                                if (s <= ((p_int*)l)[1])
                                {
                                    /* s is in the range, and r is already correct
                                     * (ie the upper bound)
                                     */
                                    if (!o0)
                                    {
                                        /* Lookup the real jump offset */
                                        l = pc + o1 + (s-r) * len;
                                        o1 = 0;
                                        i = len;
                                        do {
                                            o1 = (o1 << 8) + *l++;
                                        } while (--i);
                                        break;
                                    }
                                    /* o1 holds jump destination */
                                    break;
                                }
                                /* s is not in the range */
                            }

                            /* <s> not found at all: use 'default' address */
                            o1 = def_offs;

                            /* o1 holds jump destination */
                            break;
                        } /* !d */

                        /* Here is 0 < d < sizeof(p_int).
                         * Set d = 0 and finish the loop in the next
                         * iteration.
                         * TODO: Why the delay?
                         */
                        d = 0;
                    }
                    else
                    {
                        /* Move <l> up, and half the partition size <d>
                         * If this would push l beyond the table, repeat the
                         * steps 'move <l> down and half the partition size'
                         * until <l> is within the table again.
                         */

                        l += d;
                        while (l >= end_tab)
                        {
                            d >>= 1;
                            if (d <= (mp_int)sizeof(p_int)/2)
                            {
                                /* We can't move l further - finish the loop */
                                l -= sizeof(p_int);
                                d = 0;
                                break;
                            }
                            l -= d;
                        }
                        d >>= 1;
                    }
                }
                else
                {
                    /* --- s == r --- */

                    /* End of search: s found.
                     *
                     * Set p2 to the offset matching <l> and retrieve
                     * o0 and o1 from there.
                     *
                     * We don't distinguish between a singular case match
                     * and a match with an upper range bound, but we have
                     * to take extra steps in case <s> matched a lower range
                     * bound. In that light, o0 need not be an exact value.
                     */
                    p2 = tabstart + tablen + ((p_int*)l - (p_int*)tabstart)*len;
                    o0 = EXTRACT_UCHAR(p2-1);
                    o1 = EXTRACT_UCHAR(p2);
                    if (len > 1)
                    {
                        o0 |= EXTRACT_UCHAR(p2-2);
                        o1 = EXTRACT_UCHAR(p2+1) + (o1 << 8);
                        if (len > 2)
                        {
                            o0 |= EXTRACT_UCHAR(p2-3);
                            o1 = EXTRACT_UCHAR(p2+2) + (o1 << 8);
                        }
                    }

                    /* Test if <s> matched the end of a range with a lookup table.
                     */
                    /* TODO: Does this mean that the compiler never creates
                     * TODO:: an ordinary range at the beginning of v[]?
                     */
                    if (!o0 && l > tabstart)
                    {
                        r = ((p_int*)l)[-1]; /* the lower bound */
                        l = pc + o1 + (s-r) * len;
                        o1 = 0;
                        i = len;
                        do
                        {
                            o1 = (o1 << 8) + *l++;
                        } while (--i);
                        /* o1 holds jump destination */
                        break;
                    }

                    /* Test if <s> matched the start of a range */
                    if (o1 <= 1)
                    {
                        /* Yup. Realign p2 and reget o1 */
                        p2 += len;

                        /* Set l to point to the jump offset */
                        if (o1)
                        {
                            /* start of ordinary range */
                            l = p2;
                        }
                        else
                        {
                            /* start of range with lookup table */
                            i = len;
                            do {
                                o1 = (o1 << 8) + *p2++;
                            } while (--i);
                            l = pc + o1;
                        }

                        /* Get the jump offset from where <l> points */
                        o1 = 0;
                        i = len;
                        do {
                            o1 = (o1 << 8) + *l++;
                        } while (--i);

                        /* o1 holds jump destination */
                        break;
                    }

                    /* At this point, s was a match with a singular case, and
                     * o1 already holds the jump destination.
                     */
                    break;
                }
            } /* binary search */
        } /* if (useDefault) */

        /* o1 is now the offset to jump to. */
        pc += o1;
        break;
    }

    CASE(F_SSCANF);                 /* --- sscanf <numarg>     --- */
    {
        /* EFUN sscanf()
         *
         *   int sscanf(string str, string fmt, mixed var1, mixed var2, ...)
         *
         * Scanf <str> according to <fmt> and store the resultes in var1...
         * The compiler knows that var1... have to be passed as lvalues.
         *
         * Result is the number of variables assigned.
         */
        int i;
        svalue_t *arg;

        num_arg = LOAD_UINT8(pc);
          /* GET_NUM_ARG doesn't work here. Trust me on that. */
        inter_sp = sp;
        inter_pc = pc;
        arg = sp - num_arg + 1;
        if (arg[0].type != T_STRING)
            BAD_ARG_ERROR(1, T_STRING, arg[0].type);
        if (arg[1].type != T_STRING)
            BAD_ARG_ERROR(2, T_STRING, arg[1].type);
        i = e_sscanf(num_arg, sp);
        pop_n_elems(num_arg-1);
        free_svalue(sp);
        put_number(sp, i);
        break;
    }

#ifdef USE_PARSE_COMMAND
    CASE(F_PARSE_COMMAND);      /* --- parse_command <numargs> --- */
    {
        /* EFUN parse_command()
         *
         *   int parse_command(string cmd, object|object* objs
         *                    , string fmt, mixed var1, mixed var2...)
         *
         * Parse the command <cmd> against <objs> and the format <fmt>
         * and assign the parsed values to variables var1....
         * The compiler knows that var1... have to be passed as lvalues.
         *
         * Result is TRUE if the pattern matches, and FALSE if not.
         */
        int i;
        svalue_t *arg;
        string_t *str;

        assign_eval_cost_inl();
        num_arg = LOAD_UINT8(pc);
          /* GET_NUM_ARG doesn't work here either. */
        arg = sp - num_arg + 1;
        if (arg[0].type != T_STRING)
            BAD_ARG_ERROR(1, T_STRING, arg[0].type);
        if (arg[1].type != T_OBJECT && arg[1].type != T_POINTER)
            RAISE_ARG_ERROR(2, TF_OBJECT|TF_POINTER, arg[1].type);
        if (arg[2].type != T_STRING)
            BAD_ARG_ERROR(3, T_STRING, arg[2].type);
        if (arg[1].type == T_POINTER)
            check_for_destr(arg[1].u.vec);

        inter_sp = sp;
        inter_pc = pc;

        str = trim_all_spaces(arg[0].u.str);
        free_mstring(arg[0].u.str);
        arg[0].u.str = str;

        str = trim_all_spaces(arg[2].u.str);
        free_mstring(arg[2].u.str);
        arg[2].u.str = str;

        i = e_parse_command(arg[0].u.str, &arg[1], arg[2].u.str
                           , &arg[3], num_arg-3);
        pop_n_elems(num_arg);        /* Get rid of all arguments */
        push_number(sp, i ? 1 : 0);      /* Push the result value */
        break;
    }
#endif /* USE_PARSE_COMMAND */

    CASE(F_LOCAL);                  /* --- local <ix>          --- */

        /* Fetch the value of local variable <ix> and push it
         * onto the stack.
         */
        sp++;
        assign_local_svalue_no_free(sp, fp + LOAD_UINT8(pc));
        break;

    CASE(F_CATCH);       /* --- catch <flags> <offset> <guarded code> --- */
    {
        /* catch(...instructions...)
         *
         * Execute the instructions (max. uint8 <offset> bytes) following the
         * catch statement. If an error occurs, or a throw() is executed,
         * catch that exception, push the <catch_value> (a global var)
         * onto the stack and continue execution at instruction
         * <pc>+1+<offset>.
         *
         * The attributes of the catch are given as uint8 <flags>.
         * If CATCH_FLAG_RESERVE is set, the top most stack value denotes
         * the eval cost to reserve for the catch handling - it is removed
         * from the stack before continuing.
         *
         * The implementation is such that a control-stack entry is created
         * as if the instructions following catch are called as a subroutine
         * from <pc>+1+<offset>. Additionally an appropriate error context
         * is pushed. This way the error handling will have the VM 'return'
         * to the right place automatically.
         *
         * The last instruction of the guarded code is F_END_CATCH which
         * will clean up the control and error stack.
         *
         * If the actual guarded code is longer than 256 Bytes, the compiler
         * will generate appropriate branches:
         *
         *                  catch 2
         *                  branch guarded_code
         *                  branch continuation
         *    guarded_code: ...
         */

        uint offset;
        int  flags;
        int32 reserve_cost = CATCH_RESERVED_COST;

        /* Get the flags */
        flags = LOAD_UINT8(pc);

        if (flags & CATCH_FLAG_RESERVE)
        {
            if (sp->type != T_NUMBER)
            {
                ERRORF(("Illegal 'reserve' type for catch(): got %s, expected number.\n"
                       , typename(sp->type)
                       ));
            }

            if (sp->u.number <= 0)
            {
                ERRORF(("Illegal 'reserve' value for catch(): got %"PRIdPINT
                        ", expected a positive value.\n"
                       , sp->u.number
                       ));
            }

            reserve_cost = sp->u.number;
            sp--;
        }
        /* Get the offset to the next instruction after the CATCH statement.
         */
        offset = LOAD_UINT8(pc);

        /* Save the important variables in their global locations */
        inter_pc = pc;
        inter_sp = sp;
        inter_fp = fp;

        /* Perform the catch() */
        if (!catch_instruction(flags, offset
#ifndef __INTEL_COMPILER
                              , (volatile svalue_t ** volatile) &inter_sp
#else
                              , (svalue_t ** volatile) &inter_sp
#endif
                              , inter_pc, inter_fp
                              , reserve_cost
#ifdef USE_NEW_INLINES
                              , inter_context
#endif /* USE_NEW_INLINES */
                              )
           )
        {
#ifdef CHECK_OBJECT_REF
            check_all_object_shadows();
#endif /* CHECK_OBJECT_REF */
            return MY_FALSE; /* Guarded code terminated with 'return' itself */
        }

        /* Restore the important variables */
        pc = inter_pc;
        sp = inter_sp;
        fp = inter_fp;

        /* Not really necessary, but tells gcc to complain less */
        ap = NULL; /* Will be restored with a restore_arg_frame */
        use_ap = MY_FALSE;
        instruction = F_CATCH;
        num_arg = -1;
#ifdef DEBUG
        expected_stack = NULL;
#endif
        break;
    }

    CASE(F_INC);                    /* --- inc                 --- */
    {
        /* void inc (mixed & sp[0])
         *
         * Increment the (numeric) value designed by the lvalue on top
         * of the stack, then remove the lvalue from the
         * stack (not free()!, this lvalue is just a copy).
         */

        svalue_t *svp;

        /* Get the designated value */
        TYPE_TEST1(sp, T_LVALUE);
        svp = sp->u.lvalue;

        /* Now increment where we can */
        if (svp->type == T_NUMBER)
        {
            if (svp->u.number == PINT_MAX)
            {
                ERRORF(("Numeric overflow: (%"PRIdPINT")++\n",
                        svp->u.number));
                /* NOTREACHED */
                break;
            }
            svp->u.number++;
            sp--;
            break;
        }
        else if (svp->type == T_FLOAT)
        {
            STORE_DOUBLE_USED
            double d;

            d = READ_DOUBLE(svp) + 1.0;
            if (d < (-DBL_MAX) || d > DBL_MAX)
                ERRORF(("Numeric overflow: (%g)++\n", READ_DOUBLE(svp)));
            sp->type = T_FLOAT;
            STORE_DOUBLE(svp, d);
            sp--;
            break;
        }
        else if (svp->type == T_CHAR_LVALUE)
        {
            (*svp->u.charp)++;
            sp--;
            break;
        }
        else if (svp->type == T_LVALUE
              || svp->type == T_PROTECTED_LVALUE)
        {
            inter_sp = sp;
            add_number_to_lvalue(svp, 1, NULL, NULL);
            sp--;
            break;
        }

        ERRORF(("Bad arg to ++: got '%s', expected numeric type.\n"
               , typename(svp->type)
               ));
        break;
    }

    CASE(F_DEC);                    /* --- dec                 --- */
    {
        /* void dec (mixed & sp[0])
         *
         * Decrement the (numeric) value designed by the lvalue on top
         * of the stack, then remove the lvalue from the
         * stack (not free()!, this lvalue is just a copy).
         */

        svalue_t *svp;

        /* Get the designated value */
        TYPE_TEST1(sp, T_LVALUE);
        svp = sp->u.lvalue;

        /* Now decrement where we can */
        if (svp->type == T_NUMBER)
        {
            if (svp->u.number == PINT_MIN)
            {
                ERRORF(("Numeric overflow: (%"PRIdPINT")--\n",
                        svp->u.number));
                /* NOTREACHED */
                break;
            }
            svp->u.number--;
            sp--;
            break;
        }
        else if (svp->type == T_FLOAT)
        {
            STORE_DOUBLE_USED
            double d;

            d = READ_DOUBLE(svp) - 1.0;
            if (d < (-DBL_MAX) || d > DBL_MAX)
                ERRORF(("Numeric overflow: (%g)--\n", READ_DOUBLE(svp)));
            sp->type = T_FLOAT;
            STORE_DOUBLE(svp, d);
            sp--;
            break;
        }
        else if (svp->type == T_CHAR_LVALUE)
        {
            (*svp->u.charp)--;
            sp--;
            break;
        }
        else if (svp->type == T_LVALUE
              || svp->type == T_PROTECTED_LVALUE)
        {
            inter_sp = sp;
            add_number_to_lvalue(svp, -1,  NULL, NULL);
            sp--;
            break;
        }

        ERRORF(("Bad arg to --: got '%s', expected numeric type.\n"
               , typename(svp->type)
               ));
        break;
    }

    CASE(F_POST_INC);               /* --- post_inc            --- */
    {
        /* mixed post_inc (mixed & sp[0])
         *
         * Increment the numeric value designated by the lvalue on top
         * of the stack, and replace the stack entry with the value
         * before the increment. The lvalue itself is simply removed, not
         * free()d.
         */

        svalue_t *svp;

        /* Get the designated value */
        TYPE_TEST1(sp, T_LVALUE);
        svp = sp->u.lvalue;

        /* Do the push and increment */
        if (svp->type == T_NUMBER)
        {
            if (svp->u.number == PINT_MAX)
            {
                ERRORF(("Numeric overflow: (%"PRIdPINT")++\n",
                        svp->u.number));
                /* NOTREACHED */
                break;
            }
            put_number(sp,  svp->u.number++ );
            break;
        }
        else if (svp->type == T_FLOAT)
        {
            STORE_DOUBLE_USED
            double d;

            d = READ_DOUBLE(svp);
            sp->type = T_FLOAT;
            STORE_DOUBLE(sp, d);
            d += 1.0;
            if (d < (-DBL_MAX) || d > DBL_MAX)
                ERRORF(("Numeric overflow: (%g)++\n", READ_DOUBLE(svp)));
            STORE_DOUBLE(svp, d);
            break;
        }
        else if (svp->type == T_CHAR_LVALUE)
        {
            put_number(sp,  (unsigned char)(*svp->u.charp) );
            (*svp->u.charp)++;
            break;
        }
        else if (svp->type == T_LVALUE
              || svp->type == T_PROTECTED_LVALUE)
        {
            inter_sp = sp;
            add_number_to_lvalue(svp, 1, sp, NULL);
            break;
        }

        ERRORF(("Bad arg to ++: got '%s', expected numeric type.\n"
               , typename(svp->type)
               ));
        break;
    }

    CASE(F_POST_DEC);               /* --- post_dec            --- */
    {
        /* mixed post_dec (mixed & sp[0])
         *
         * Decrement the numeric value designated by the lvalue on top
         * of the stack, and replace the stack entry with the value
         * before the decrement. The lvalue itself is simply removed, not
         * free()d.
         */

        svalue_t *svp;

        /* Get the designated value */
        TYPE_TEST1(sp, T_LVALUE);
        svp = sp->u.lvalue;

        /* Do the push and decrement */
        if (svp->type == T_NUMBER)
        {
            if (svp->u.number == PINT_MIN)
            {
                ERRORF(("Numeric overflow: (%"PRIdPINT")--\n",
                        svp->u.number));
                /* NOTREACHED */
                break;
            }
            put_number(sp,  svp->u.number-- );
            break;
        }
        else if (svp->type == T_FLOAT)
        {
            STORE_DOUBLE_USED
            double d;

            d = READ_DOUBLE(svp);
            sp->type = T_FLOAT;
            STORE_DOUBLE(sp, d);
            d -= 1.0;
            if (d < (-DBL_MAX) || d > DBL_MAX)
                ERRORF(("Numeric overflow: (%g)--\n", READ_DOUBLE(svp)));
            STORE_DOUBLE(svp, d);
            break;
        }
        else if (svp->type == T_CHAR_LVALUE)
        {
            put_number(sp, (unsigned char)(*svp->u.charp) );
            (*svp->u.charp)--;
            break;
        }
        else if (svp->type == T_LVALUE
              || svp->type == T_PROTECTED_LVALUE)
        {
            inter_sp = sp;
            add_number_to_lvalue(svp, -1, sp, NULL);
            break;
        }

        ERRORF(("Bad arg to --: got '%s', expected numeric type.\n"
               , typename(svp->type)
               ));
        break;
    }

    CASE(F_PRE_INC);                /* --- pre_inc             --- */
    {
        /* mixed pre_inc (mixed & sp[0])
         *
         * Increment the numeric value designated by the lvalue on top
         * of the stack, and replace the stack entry with the incremented
         * value. The lvalue itself is simply removed, not free()d.
         */

        svalue_t *svp;

        /* Get the designated value */
        TYPE_TEST1(sp, T_LVALUE);
        svp = sp->u.lvalue;

        /* Do the increment and push */
        if (svp->type == T_NUMBER)
        {
            if (svp->u.number == PINT_MAX)
            {
                ERRORF(("Numeric overflow: ++(%"PRIdPINT")\n",
                        svp->u.number));
                /* NOTREACHED */
                break;
            }
            put_number(sp,  ++(svp->u.number) );
            break;
        }
        else if (svp->type == T_FLOAT)
        {
            STORE_DOUBLE_USED
            double d;

            d = READ_DOUBLE(svp) + 1.0;
            if (d < (-DBL_MAX) || d > DBL_MAX)
                ERRORF(("Numeric overflow: ++(%g)\n", READ_DOUBLE(svp)));
            sp->type = T_FLOAT;
            STORE_DOUBLE(sp, d);
            STORE_DOUBLE(svp, d);
            break;
        }
        else if (svp->type == T_CHAR_LVALUE)
        {
            ++(*svp->u.charp);
            put_number(sp,  (unsigned char)(*svp->u.charp) );
            break;
        }
        else if (svp->type == T_LVALUE
              || svp->type == T_PROTECTED_LVALUE)
        {
            inter_sp = sp;
            add_number_to_lvalue(svp, 1, NULL, sp);
            break;
        }

        ERRORF(("Bad arg to ++: got '%s', expected numeric type.\n"
               , typename(svp->type)
               ));
        break;
    }

    CASE(F_PRE_DEC);                /* --- pre_dec             --- */
    {
        /* mixed pre_dec (mixed & sp[0])
         *
         * Decrement the numeric value designated by the lvalue on top
         * of the stack, and replace the stack entry with the decremented
         * value. The lvalue itself is simply removed, not free()d.
         */

        svalue_t *svp;

        /* Get the designated value */
        TYPE_TEST1(sp, T_LVALUE);
        svp = sp->u.lvalue;

        /* Do the decrement and push */
        if (svp->type == T_NUMBER)
        {
            if (svp->u.number == PINT_MIN)
            {
                ERRORF(("Numeric overflow: --(%"PRIdPINT")\n",
                        svp->u.number));
                /* NOTREACHED */
                break;
            }
            put_number(sp,  --(svp->u.number) );
            break;
        }
        else if (svp->type == T_FLOAT)
        {
            STORE_DOUBLE_USED
            double d;

            d = READ_DOUBLE(svp) - 1.0;
            if (d < (-DBL_MAX) || d > DBL_MAX)
                ERRORF(("Numeric overflow: --(%g)\n", READ_DOUBLE(svp)));
            sp->type = T_FLOAT;
            STORE_DOUBLE(sp, d);
            STORE_DOUBLE(svp, d);
            break;
        }
        else if (svp->type == T_CHAR_LVALUE)
        {
            --(*svp->u.charp);
            put_number(sp,  (unsigned char)(*svp->u.charp) );
            break;
        }
        else if (svp->type == T_LVALUE
              || svp->type == T_PROTECTED_LVALUE)
        {
            inter_sp = sp;
            add_number_to_lvalue(svp, -1, NULL, sp);
            break;
        }

        ERRORF(("Bad arg to --: got '%s', expected numeric type.\n"
               , typename(svp->type)
               ));
        break;
    }

    CASE(F_LAND);                   /* --- land <offset>       --- */
    {
        /* If sp[0] is the number 0, leave it on the stack (as result)
         * and branch by <offset>.
         * Otherwise, pop the value and just continue.
         */

        if (sp->type == T_NUMBER)
        {
            if (sp->u.number == 0)
            {
                uint offset = LOAD_UINT8(pc);
                pc += offset;
                break;
            }
            /* No need to explicitely free_svalue(), it's just a number */
        }
        else
        {
            free_svalue(sp);
        }
        sp--;
        pc++;
        break;
    }

    CASE(F_LOR);                    /* --- lor <offset>        --- */
    {
        /* If sp[0] is not the number 0, leave it on the stack (as result)
         * and branch by <offset>.
         * Otherwise, pop the value and just continue.
         */

        if (sp->type == T_NUMBER && sp->u.number == 0)
            sp--; /* think 'free_svalue(sp--)' here... */
        else
            pc += GET_UINT8(pc);
        pc++;
        break;
    }

    CASE(F_ASSIGN);                 /* --- assign              --- */
    {
        /* Assign the value sp[-1] to the value designated by lvalue sp[0].
         * The assigned value sp[-1] remains on the stack as result
         * (ie. the assign yields a rvalue).
         *
         * Make sure that complex destinations like arrays are not freed
         * before the assignment is complete - see the comments to
         * assign_svalue().
         */

        svalue_t *dest;

        /* Get the designated lvalue */
#ifdef DEBUG
        if (sp->type != T_LVALUE)
            FATALF(("Bad left arg to F_ASSIGN: got '%s', expected 'lvalue'.\n"
                   , typename(sp->type)
                   ));
#endif
        dest = sp->u.lvalue;
        assign_svalue(dest, sp-1);
        sp--;
        break;
    }

    CASE(F_VOID_ASSIGN);            /* --- void_assign         --- */
    {
        /* Assign the value sp[-1] to the value designated by lvalue sp[0],
         * then remove both values from the stack.
         *
         * Make sure that complex destinations like arrays are not freed
         * before the assignment is complete - see the comments to
         * assign_svalue().
         */

#ifdef DEBUG
        if (sp->type != T_LVALUE)
            FATALF(("Bad left arg to F_VOID_ASSIGN: got '%s', expected 'lvalue'.\n"
                   , typename(sp->type)
                   ));
#endif
        transfer_svalue(sp->u.lvalue, sp-1);
        sp -= 2;
        break;
    }

    CASE(F_ADD);                    /* --- add                 --- */
        /* Add sp[0] to sp[-1] (the order is important), pop both
         * summands from the stack and push the result.
         *
         * Possible type combinations:
         *   string      + (string,int,float) -> string
         *   (int,float) + string             -> string
         *   int         + int                -> int
         *   float       + (int,float)        -> float
         *   int         + float              -> float
         *   vector      + vector             -> vector
         *   mapping     + mapping            -> mapping
         */

        switch ( sp[-1].type )
        {

        case T_STRING:
            inter_pc = pc;
            inter_sp = sp;
            switch ( sp->type )
            {
            case T_STRING:
              {
                string_t *left, *right, *res;

                left = (sp-1)->u.str;
                right = sp->u.str;

                DYN_STRING_COST(mstrsize(left) + mstrsize(right))
                res = mstr_add(left, right);
                if (!res)
                    ERRORF(("Out of memory (%zu bytes)\n"
                           , mstrsize(left) + mstrsize(right)
                           ));
                free_string_svalue(sp);
                sp--;
                free_string_svalue(sp);
                put_string(sp, res);
                break;
              }

            case T_NUMBER:
              {
                string_t *left, *res;
                char buff[80];
                size_t len;

                left = (sp-1)->u.str;
                buff[sizeof(buff)-1] = '\0';
                sprintf(buff, "%"PRIdPINT, sp->u.number);
                if (buff[sizeof(buff)-1] != '\0')
                    FATAL("Buffer overflow in F_ADD: int number too big.\n");
                len = mstrsize(left)+strlen(buff);
                DYN_STRING_COST(len)
                res = mstr_add_txt(left, buff, strlen(buff));
                if (!res)
                    ERRORF(("Out of memory (%zu bytes)\n", len ));
                pop_n_elems(2);
                push_string(sp, res);
                break;
              }

            case T_FLOAT:
              {
                char buff[160];
                string_t *left, *res;
                size_t len;

                left = (sp-1)->u.str;
                buff[sizeof(buff)-1] = '\0';
                sprintf(buff, "%g", READ_DOUBLE( sp ) );
                if (buff[sizeof(buff)-1] != '\0')
                    FATAL("Buffer overflow in F_ADD: float number too big.\n");
                len = mstrsize(left)+strlen(buff);
                DYN_STRING_COST(len)
                res = mstr_add_txt(left, buff, strlen(buff));
                if (!res)
                    ERRORF(("Out of memory (%zu bytes)\n", len));
                sp--;
                free_string_svalue(sp);
                put_string(sp, res);
                break;
              }

            default:
                OP_ARG_ERROR(2, TF_STRING|TF_FLOAT|TF_NUMBER, sp->type);
                /* NOTREACHED */
            }
            break;
            /* End of case T_STRING */

          case T_NUMBER:
            switch ( sp->type )
            {
            case T_STRING:
              {
                char buff[80];
                string_t *right, *res;
                size_t len;

                right = sp->u.str;
                buff[sizeof(buff)-1] = '\0';
                sprintf(buff, "%"PRIdPINT, (sp-1)->u.number);
                if (buff[sizeof(buff)-1] != '\0')
                    FATAL("Buffer overflow in F_ADD: int number too big.\n");
                len = mstrsize(right)+strlen(buff);
                DYN_STRING_COST(len)
                res = mstr_add_to_txt(buff, strlen(buff), right);
                if (!res)
                    ERRORF(("Out of memory (%zu bytes)\n", len));
                free_string_svalue(sp);
                sp--;
                /* Overwrite the number at sp */
                put_string(sp, res);
                break;
              }

            case T_NUMBER:
              {
                p_int i;
                p_int right = sp->u.number;
                p_int left = (sp-1)->u.number;

                if ((left >= 0 && right >= 0 && PINT_MAX - left < right)
                 || (left < 0 && right < 0 && PINT_MIN - left > right)
                   )
                {
                    ERRORF(("Numeric overflow: %"PRIdPINT" + %"PRIdPINT"\n"
                           , left, right));
                    /* NOTREACHED */
                    break;
                }
                i = left + right;
                sp--;
                sp->u.number = i;
                break;
              }

            case T_FLOAT:
              {
                STORE_DOUBLE_USED
                double sum;

                sum = (double)((sp-1)->u.number) + READ_DOUBLE(sp);
                if (sum < (-DBL_MAX) || sum > DBL_MAX)
                    ERRORF(("Numeric overflow: %"PRIdPINT" + %g\n"
                           , (sp-1)->u.number, READ_DOUBLE(sp)));
                STORE_DOUBLE(sp-1, sum);
                sp--;
                sp->type = T_FLOAT;
                break;
              }

            default:
                OP_ARG_ERROR(2, TF_STRING|TF_FLOAT|TF_NUMBER, sp->type);
                /* NOTREACHED */
            }
            break;
            /* End of case T_NUMBER */

        case T_FLOAT:
          {
            STORE_DOUBLE_USED
            double sum;

            if (sp->type == T_FLOAT)
            {
                sum = READ_DOUBLE(sp-1) + READ_DOUBLE(sp);
                if (sum < (-DBL_MAX) || sum > DBL_MAX)
                    ERRORF(("Numeric overflow: %g + %g\n"
                           , READ_DOUBLE(sp-1), READ_DOUBLE(sp)));
                STORE_DOUBLE(sp-1, sum);
                sp--;
                break;
            }
            if (sp->type == T_NUMBER)
            {
                sum = READ_DOUBLE(sp-1) + (double)(sp->u.number);
                if (sum < (-DBL_MAX) || sum > DBL_MAX)
                    ERRORF(("Numeric overflow: %g + %"PRIdPINT"\n"
                           , READ_DOUBLE(sp-1), sp->u.number));
                STORE_DOUBLE(sp-1, sum);
                sp--;
                break;
            }
            if (sp->type == T_STRING)
            {
                char buff[160];
                string_t *right, *res;
                size_t len;

                right = sp->u.str;
                buff[sizeof(buff)-1] = '\0';
                sprintf(buff, "%g", READ_DOUBLE(sp-1) );
                if (buff[sizeof(buff)-1] != '\0')
                    FATAL("Buffer overflow in F_ADD: float number too big.\n");
                len = mstrsize(right)+strlen(buff);
                DYN_STRING_COST(len)
                res = mstr_add_to_txt(buff, strlen(buff), right);
                if (!res)
                    ERRORF(("Out of memory (%zu bytes)\n", len));
                free_string_svalue(sp);
                sp--;
                /* Overwrite the number at sp */
                put_string(sp, res);
                break;
            }
            OP_ARG_ERROR(2, TF_STRING|TF_FLOAT|TF_NUMBER, sp->type);
            /* NOTREACHED */
          }
          /* End of case T_FLOAT */

        case T_POINTER:
          {
            TYPE_TEST_RIGHT(sp, T_POINTER);
            inter_sp = sp;
            inter_pc = pc;
            DYN_ARRAY_COST(VEC_SIZE(sp->u.vec)+VEC_SIZE(sp[-1].u.vec));
            inter_add_array(sp->u.vec, &(sp-1)->u.vec);
            sp--;
            break;
          }

        case T_MAPPING:
          {
            mapping_t *m;

            TYPE_TEST_RIGHT(sp, T_MAPPING);
            check_map_for_destr((sp-1)->u.map);
            check_map_for_destr(sp->u.map);
              /* required for add_mapping() */
            inter_pc = pc;
            inter_sp = sp;
            m = add_mapping((sp-1)->u.map,sp->u.map);
            if (!m) {
                ERROR("Out of memory.\n");
            }
            pop_n_elems(2);
            push_mapping(sp, m);
            if ((max_mapping_size && MAP_TOTAL_SIZE(m) > (p_int)max_mapping_size)
             || (max_mapping_keys && MAP_SIZE(m) > (p_int)max_mapping_keys)
               )
            {
                check_map_for_destr(m);
                if (max_mapping_size && MAP_TOTAL_SIZE(m) > (p_int)max_mapping_size)
                    ERRORF(("Illegal mapping size: %"PRIdPINT
                            " elements (%"PRIdPINT" x %"PRIdPINT")\n"
                           , MAP_TOTAL_SIZE(m), MAP_SIZE(m), m->num_values));

                if (max_mapping_keys && MAP_SIZE(m) > (p_int)max_mapping_keys)
                    ERRORF(("Illegal mapping size: %"PRIdPINT" entries\n",
                            MAP_SIZE(m)));
            }
            break;
          }

        default:
            OP_ARG_ERROR(1, TF_POINTER|TF_MAPPING|TF_STRING|TF_FLOAT|TF_NUMBER
                          , sp[-1].type);
            /* NOTREACHED */
        }

        break;

    CASE(F_SUBTRACT);               /* --- subtract            --- */
    {
        /* Subtract sp[0] from sp[-1] (the order is important), pop both
         * arguments from the stack and push the result.
         *
         * Possible type combinations:
         *   int         - int                -> int
         *   float       - (int,float)        -> float
         *   int         - float              -> float
         *   string      - string             -> string
         *   vector      - vector             -> vector
         *   mapping     - mapping            -> mapping
         */

        p_int i;

        if ((sp-1)->type == T_NUMBER)
        {
            if (sp->type == T_NUMBER)
            {
                p_int left = (sp-1)->u.number;
                p_int right = sp->u.number;

                if ((left >= 0 && right < 0 && PINT_MAX + right < left)
                 || (left < 0 && right >= 0 && PINT_MIN + right > left)
                   )
                {
                    ERRORF(("Numeric overflow: %"PRIdPINT" - %"PRIdPINT"\n"
                           , left, right));
                    /* NOTREACHED */
                    break;
                }

                i = left - right;
                sp--;
                sp->u.number = i;
                break;
            }
            if (sp->type == T_FLOAT)
            {
                STORE_DOUBLE_USED
                double diff;

                diff = (double)((sp-1)->u.number) - READ_DOUBLE(sp);
                if (diff < (-DBL_MAX) || diff > DBL_MAX)
                    ERRORF(("Numeric overflow: %"PRIdPINT" - %g\n"
                           , (sp-1)->u.number, READ_DOUBLE(sp)));
                sp--;
                STORE_DOUBLE(sp, diff);
                sp->type = T_FLOAT;
                break;
            }
            OP_ARG_ERROR(2, TF_FLOAT|TF_NUMBER, sp->type);
            /* NOTREACHED */
        }
        else if ((sp-1)->type == T_FLOAT)
        {
            STORE_DOUBLE_USED
            double diff;

            if (sp->type == T_FLOAT)
            {
                diff = READ_DOUBLE(sp-1) - READ_DOUBLE(sp);
                if (diff < (-DBL_MAX) || diff > DBL_MAX)
                    ERRORF(("Numeric overflow: %g - %g\n"
                           , READ_DOUBLE(sp-1), READ_DOUBLE(sp)));
                sp--;
                STORE_DOUBLE(sp, diff);
                break;
            }
            if (sp->type == T_NUMBER)
            {
                diff = READ_DOUBLE(sp-1) - (double)(sp->u.number);
                if (diff < (-DBL_MAX) || diff > DBL_MAX)
                    ERRORF(("Numeric overflow: %g - %"PRIdPINT"\n"
                           , READ_DOUBLE(sp-1), sp->u.number));
                sp--;
                STORE_DOUBLE(sp, diff);
                break;
            }
            OP_ARG_ERROR(2, TF_FLOAT|TF_NUMBER, sp->type);
            /* NOTREACHED */
        }
        else if ((sp-1)->type == T_POINTER)
        {
            vector_t *v;

            TYPE_TEST_RIGHT(sp, T_POINTER);
            v = sp->u.vec;
            if (v->ref > 1)
            {
                deref_array(v);
                v = slice_array(v, 0, (mp_int)VEC_SIZE(v) - 1 );
            }
            sp--;
            /* subtract_array already takes care of destructed objects */
            sp->u.vec = subtract_array(sp->u.vec, v);
            break;
        }
        else if ((sp-1)->type == T_MAPPING)
        {
            mapping_t *m;

            TYPE_TEST_RIGHT(sp, T_MAPPING);
            m = subtract_mapping(sp[-1].u.map, sp->u.map);
            free_mapping(sp->u.map);
            sp--;
            free_mapping(sp->u.map);
            sp->u.map = m;
            break;
        }
        else if ((sp-1)->type == T_STRING)
        {
            string_t * result;

            TYPE_TEST_RIGHT(sp, T_STRING);
            inter_sp = sp;
            result = intersect_strings((sp-1)->u.str, sp->u.str, MY_TRUE);
            free_string_svalue(sp);
            sp--;
            free_string_svalue(sp);
            put_string(sp, result);
            break;
        }

        OP_ARG_ERROR(1, TF_POINTER|TF_MAPPING|TF_STRING|TF_FLOAT|TF_NUMBER
                      , sp[-1].type);
        /* NOTREACHED */
    }

    CASE(F_MULTIPLY);               /* --- multiply            --- */
    {
        /* Multiply sp[-1] by sp[0] pop both arguments from the stack
         * and push the result.
         * TODO: Could be extended to cover mappings.
         * TODO:: array/string multiplied by element === implode.
         *
         * Possible type combinations:
         *   int         * int                -> int
         *   float       * (int,float)        -> float
         *   int         * float              -> float
         *   string      * int                -> string
         *   int         * string             -> string
         *   array       * int                -> array
         *   int         * array              -> array
         */

        p_int i;

        switch ( sp[-1].type )
        {
        case T_NUMBER:
            if (sp->type == T_NUMBER)
            {
                p_int left = (sp-1)->u.number;
                p_int right = sp->u.number;

                if (left > 0 && right > 0)
                {
                    if ((left != 0 && PINT_MAX / left < right)
                     || (right != 0 && PINT_MAX / right < left)
                       )
                    {
                        ERRORF(("Numeric overflow: %"PRIdPINT" * %"PRIdPINT"\n"
                               , left, right));
                        /* NOTREACHED */
                        break;
                    }
                }
                else if (left < 0 && right < 0)
                {
                    if ((left != 0 && PINT_MAX / left > right)
                     || (right != 0 && PINT_MAX / right > left)
                       )
                    {
                        ERRORF(("Numeric overflow: %"PRIdPINT
                                " * %"PRIdPINT"\n"
                               , left, right));
                        /* NOTREACHED */
                        break;
                    }
                }
                else if (left != 0 && right != 0)
                {
                    if ((left > 0 && PINT_MIN / left > right)
                     || (right > 0 && PINT_MIN / right > left)
                       )
                    {
                        ERRORF(("Numeric overflow: %"PRIdPINT
                                " * %"PRIdPINT"\n"
                               , left, right));
                        /* NOTREACHED */
                        break;
                    }
                }
                i = left * right;
                sp--;
                sp->u.number = i;
                break;
            }
            if (sp->type == T_FLOAT)
            {
                STORE_DOUBLE_USED
                double product;

                product = (sp-1)->u.number * READ_DOUBLE(sp);
                if (product < (-DBL_MAX) || product > DBL_MAX)
                    ERRORF(("Numeric overflow: %"PRIdPINT" * %g\n"
                           , (sp-1)->u.number, READ_DOUBLE(sp)));
                sp--;
                STORE_DOUBLE(sp, product);
                sp->type = T_FLOAT;
                break;
            }
            if (sp->type == T_STRING)
            {
                string_t * result;
                size_t slen;

                if (sp[-1].u.number < 0)
                    ERROR("Bad right arg to *: negative number.\n");

                slen = mstrsize(sp->u.str);
                if (slen > (size_t)PINT_MAX
                 || (   slen != 0
                     && PINT_MAX / (p_int)slen < sp[-1].u.number)
                 || (   sp[-1].u.number != 0
                     && PINT_MAX / sp[-1].u.number < (p_int)slen)
                   )
                    ERRORF(("Result string too long (%zu * %"PRIdPINT").\n"
                           , slen, sp[-1].u.number
                           ));

                result = mstr_repeat(sp->u.str, (size_t)sp[-1].u.number);
                if (!result)
                    ERRORF(("Out of memory (%"PRIdPINT" bytes).\n"
                           , (p_int)mstrsize(sp->u.str) * sp[-1].u.number));

                DYN_STRING_COST(mstrsize(result))
                free_svalue(sp);
                sp--;
                /* No free_svalue(sp): it's just a number */
                put_string(sp, result);
                break;
            }
            if (sp->type == T_POINTER)
            {
                vector_t *result;
                mp_int reslen;
                size_t len;

                if (sp[-1].u.number < 0)
                    ERROR("Bad right arg to *: negative number.\n");

                inter_sp = sp;
                inter_pc = pc;
                len = VEC_SIZE(sp->u.vec);
                reslen = sp[-1].u.number * (mp_int)len;
                result = allocate_uninit_array(reslen);
                DYN_ARRAY_COST(reslen);

                if (sp[-1].u.number > 0 && len)
                {
                    size_t left;
                    svalue_t *from, *to;

                    /* Seed result[] with one copy of the array.
                     */
                    for ( from = sp->u.vec->item, to = result->item, left = len
                        ; left
                        ; from++, to++, left--)
                    {
                        assign_svalue_no_free(to, from);
                    } /* for() seed */

                    /* Now fill the remainder of the vector with
                     * the values already copied in there.
                     */
                    for (from = result->item, left = reslen - len
                        ; left
                        ; to++, from++, left--
                        )
                        assign_svalue_no_free(to, from);
                } /* if (len) */

                free_svalue(sp);
                sp--;
                /* No free_svalue(sp): it's just a number */
                put_array(sp, result);
                break;
            }
            OP_ARG_ERROR(2, TF_POINTER|TF_STRING|TF_FLOAT|TF_NUMBER
                          , sp->type);
            /* NOTREACHED */
        case T_FLOAT:
          {
            STORE_DOUBLE_USED
            double product;

            if (sp->type == T_FLOAT)
            {
                product = READ_DOUBLE(sp-1) * READ_DOUBLE(sp);
                if (product < (-DBL_MAX) || product > DBL_MAX)
                    ERRORF(("Numeric overflow: %g * %g\n"
                           , READ_DOUBLE(sp-1), READ_DOUBLE(sp)));
                STORE_DOUBLE(sp-1, product);
                sp--;
                break;
            }
            if (sp->type == T_NUMBER)
            {
                product = READ_DOUBLE(sp-1) * sp->u.number;
                if (product < (-DBL_MAX) || product > DBL_MAX)
                    ERRORF(("Numeric overflow: %g * %"PRIdPINT"\n"
                           , READ_DOUBLE(sp-1), sp->u.number));
                STORE_DOUBLE(sp-1, product);
                sp--;
                break;
            }
            OP_ARG_ERROR(2, TF_FLOAT|TF_NUMBER, sp->type);
            /* NOTREACHED */
          }
        case T_STRING:
          {
            if (sp->type == T_NUMBER)
            {
                string_t * result;
                size_t slen;

                if (sp->u.number < 0)
                    ERROR("Bad left arg to *: negative number.\n");

                slen = mstrsize(sp[-1].u.str);
                if (slen > (size_t)PINT_MAX
                 || (   slen != 0
                     && PINT_MAX / (p_int)slen < sp->u.number)
                 || (   sp->u.number != 0
                     && PINT_MAX / sp->u.number < (p_int)slen)
                   )
                    ERRORF(("Result string too long (%"PRIdPINT" * %zu).\n"
                           , sp->u.number, slen));

                result = mstr_repeat(sp[-1].u.str, (size_t)sp->u.number);
                if (!result)
                    ERRORF(("Out of memory (%"PRIdMPINT" bytes).\n"
                           , (mp_int)mstrsize(sp[-1].u.str) * sp->u.number));

                DYN_STRING_COST(mstrsize(result))

                /* No free_svalue(sp): it's just a number */
                sp--;
                free_string_svalue(sp);
                put_string(sp, result);
                break;
            }
            BAD_OP_ARG(2, T_NUMBER, sp->type);
            /* NOTREACHED */
          }
        case T_POINTER:
          {
            if (sp->type == T_NUMBER)
            {
                vector_t *result;
                mp_int reslen;
                size_t len;

                if (sp->u.number < 0)
                    ERROR("Bad left arg to *: negative number.\n");

                inter_sp = sp;
                inter_pc = pc;
                len = VEC_SIZE(sp[-1].u.vec);
                reslen = sp->u.number * (mp_int)len;
                result = allocate_uninit_array(reslen);

                if (sp->u.number > 0 && len)
                {
                    size_t left;
                    svalue_t *from, *to;

                    /* Seed result[] with one copy of the array.
                     */
                    for ( from = sp[-1].u.vec->item, to = result->item, left = len
                        ; left
                        ; from++, to++, left--)
                    {
                        assign_svalue_no_free(to, from);
                    } /* for() seed */

                    /* Now fill the remainder of the vector with
                     * the values already copied in there.
                     */
                    for (from = result->item, left = reslen - len
                        ; left
                        ; to++, from++, left--
                        )
                        assign_svalue_no_free(to, from);
                } /* if (len) */

                /* No free_svalue(sp): it's just a number */
                sp--;
                free_svalue(sp);
                put_array(sp, result);
                break;
              }
            BAD_OP_ARG(2, T_NUMBER, sp->type);
            /* NOTREACHED */
          }
        default:
            OP_ARG_ERROR(1, TF_POINTER|TF_STRING|TF_FLOAT|TF_NUMBER
                          , sp[-1].type);
            /* NOTREACHED */
        }
        break;
    }

    CASE(F_DIVIDE);                 /* --- divide              --- */
    {
        /* Divide sp[-1] by sp[0] pop both arguments from the stack
         * and push the result.
         * TODO: Could be extended to cover arrays and mappings.
         * TODO:: array/string divided by element === explode.
         *
         * Possible type combinations:
         *   int         / int                -> int
         *   float       / (int,float)        -> float
         *   int         / float              -> float
         */

        p_int i;

        if ((sp-1)->type == T_NUMBER)
        {
            if (sp->type == T_NUMBER) {
                if (sp->u.number == 0)
                    ERROR("Division by zero\n");
                if ((sp-1)->u.number == PINT_MIN && sp->u.number == -1)
                    ERRORF(("Numeric overflow: %"PRIdPINT" / -1\n"
                           , (sp-1)->u.number
                           ));
                i = (sp-1)->u.number / sp->u.number;
                sp--;
                sp->u.number = i;
                break;
            }
            if (sp->type == T_FLOAT)
            {
                double dtmp;
                STORE_DOUBLE_USED

                dtmp = READ_DOUBLE( sp );
                if (dtmp == 0.)
                    ERROR("Division by zero\n");
                sp--;
                dtmp = (double)sp->u.number / dtmp;
                if (dtmp < (-DBL_MAX) || dtmp > DBL_MAX)
                    ERRORF(("Numeric overflow: %"PRIdPINT" / %g\n"
                           , (sp)->u.number, READ_DOUBLE(sp+1)));
                STORE_DOUBLE(sp, dtmp);
                sp->type = T_FLOAT;
                break;
            }
            OP_ARG_ERROR(2, TF_FLOAT|TF_NUMBER, sp->type);
            /* NOTREACHED */
        }
        else if ((sp-1)->type == T_FLOAT)
        {
            double dtmp;
            STORE_DOUBLE_USED

            if (sp->type == T_FLOAT)
            {
                dtmp = READ_DOUBLE( sp );
                if (dtmp == 0.) {
                    ERROR("Division by zero\n");
                    return MY_FALSE;
                }
                sp--;
                dtmp = READ_DOUBLE(sp) / dtmp;
                if (dtmp < (-DBL_MAX) || dtmp > DBL_MAX)
                    ERRORF(("Numeric overflow: %g / %g\n"
                           , READ_DOUBLE(sp), READ_DOUBLE(sp+1)));
                STORE_DOUBLE(sp, dtmp);
                break;
            }
            if (sp->type == T_NUMBER)
            {
                if (sp->u.number == 0) {
                    ERROR("Division by zero\n");
                    return MY_FALSE;
                }
                dtmp = (double)sp->u.number;
                sp--;
                dtmp = READ_DOUBLE(sp) / dtmp;
                if (dtmp < (-DBL_MAX) || dtmp > DBL_MAX)
                    ERRORF(("Numeric overflow: %g / %"PRIdPINT"\n"
                           , READ_DOUBLE(sp), (sp+1)->u.number));
                STORE_DOUBLE(sp, dtmp);
                break;
            }
            OP_ARG_ERROR(2, TF_FLOAT|TF_NUMBER, sp->type);
            /* NOTREACHED */
        }
        OP_ARG_ERROR(1, TF_FLOAT|TF_NUMBER, sp[-1].type);
        /* NOTREACHED */
        break;
    }

    CASE(F_MOD);                    /* --- mod                 --- */
    {
        /* Compute sp[-1] modulus sp[0] pop both arguments from the stack
         * and push the result.
         * TODO: Could be extended to cover floats(!), arrays and mappings.
         * TODO: Define properly and add the rem operation.
         *
         * Possible type combinations:
         *   int         % int                -> int
         */

        int i;

        TYPE_TEST_LEFT((sp-1), T_NUMBER);
        TYPE_TEST_RIGHT(sp, T_NUMBER);
        if (sp->u.number == 0)
        {
            ERROR("Modulus by zero.\n");
            break;
        }
        else if (sp->u.number == 1
              || sp->u.number == -1
                )
            i = 0;
              /* gcc 2.91 on Linux/x86 generates buggy code
               * for MIN_INT % -1. Might as well catch it all.
               */
        else
            i = (sp-1)->u.number % sp->u.number;
        sp--;
        sp->u.number = i;
        break;
    }

    CASE(F_GT);                     /* --- gt                  --- */
    {
        /* Test if sp[-1] > sp[0]. If yes, push 1 onto the stack,
         * else 0 (of course after popping both arguments).
         *
         * Comparable types are int, string and float, each only
         * to its own type.
         */

        int i;

        if ((sp-1)->type == T_STRING && sp->type == T_STRING)
        {
            i = mstrcmp((sp-1)->u.str, sp->u.str) > 0;
            free_string_svalue(sp);
            sp--;
            free_string_svalue(sp);
            put_number(sp, i);
            break;
        }

        if ((sp-1)->type == T_NUMBER && sp->type == T_NUMBER)
        {
            i = (sp-1)->u.number > sp->u.number;
            sp--;
            sp->u.number = i;
            break;
        }

        if ((sp-1)->type == T_FLOAT && sp->type == T_FLOAT)
        {
            i = READ_DOUBLE( sp-1 ) > READ_DOUBLE( sp );
            sp--;
            put_number(sp, i);
            break;
        }

        if ((sp-1)->type == T_NUMBER && sp->type == T_FLOAT)
        {
            i = (double)((sp-1)->u.number) > READ_DOUBLE( sp );
            sp--;
            put_number(sp, i);
            break;
        }

        if ((sp-1)->type == T_FLOAT && sp->type == T_NUMBER)
        {
            i = READ_DOUBLE( sp-1 ) > (double)(sp->u.number);
            sp--;
            put_number(sp, i);
            break;
        }

        TYPE_TEST_EXP_LEFT((sp-1), TF_NUMBER|TF_STRING|TF_FLOAT);
        TYPE_TEST_EXP_RIGHT(sp, TF_NUMBER|TF_STRING|TF_FLOAT);
        ERRORF(("Arguments to > don't match: %s vs %s\n"
               , typename(sp[-1].type), typename(sp->type)
               ));
    }

    CASE(F_GE);                     /* --- ge                  --- */
    {
        /* Test if sp[-1] >= sp[0]. If yes, push 1 onto the stack,
         * else 0 (of course after popping both arguments).
         *
         * Comparable types are int, string and float, each only
         * to its own type.
         */

        int i;

        if ((sp-1)->type == T_STRING && sp->type == T_STRING)
        {
            i = mstrcmp((sp-1)->u.str, sp->u.str) >= 0;
            free_string_svalue(sp);
            sp--;
            free_string_svalue(sp);
            put_number(sp, i);
            break;
        }

        if ((sp-1)->type == T_NUMBER && sp->type == T_NUMBER)
        {
            i = (sp-1)->u.number >= sp->u.number;
            sp--;
            sp->u.number = i;
            break;
        }

        if ((sp-1)->type == T_FLOAT && sp->type == T_FLOAT)
        {
            i = READ_DOUBLE( sp-1 ) >= READ_DOUBLE( sp );
            sp--;
            put_number(sp, i);
            break;
        }

        if ((sp-1)->type == T_NUMBER && sp->type == T_FLOAT)
        {
            i = (double)((sp-1)->u.number) >= READ_DOUBLE( sp );
            sp--;
            put_number(sp, i);
            break;
        }

        if ((sp-1)->type == T_FLOAT && sp->type == T_NUMBER)
        {
            i = READ_DOUBLE( sp-1 ) >= (double)(sp->u.number);
            sp--;
            put_number(sp, i);
            break;
        }

        TYPE_TEST_EXP_LEFT((sp-1), TF_NUMBER|TF_STRING|TF_FLOAT);
        TYPE_TEST_EXP_RIGHT(sp, TF_NUMBER|TF_STRING|TF_FLOAT);
        ERRORF(("Arguments to >= don't match: %s vs %s\n"
               , typename(sp[-1].type), typename(sp->type)
               ));
    }

    CASE(F_LT);                     /* --- lt                  --- */
    {
        /* Test if sp[-1] < sp[0]. If yes, push 1 onto the stack,
         * else 0 (of course after popping both arguments).
         *
         * Comparable types are int, string and float, each only
         * to its own type.
         */

        int i;

        if ((sp-1)->type == T_STRING && sp->type == T_STRING)
        {
            i = mstrcmp((sp-1)->u.str, sp->u.str) < 0;
            free_string_svalue(sp);
            sp--;
            free_string_svalue(sp);
            put_number(sp, i);
            break;
        }

        if ((sp-1)->type == T_NUMBER && sp->type == T_NUMBER)
        {
            i = (sp-1)->u.number < sp->u.number;
            sp--;
            sp->u.number = i;
            break;
        }

        if ((sp-1)->type == T_FLOAT && sp->type == T_FLOAT)
        {
            i = READ_DOUBLE( sp-1 ) < READ_DOUBLE( sp );
            sp--;
            put_number(sp, i);
            break;
        }

        if ((sp-1)->type == T_NUMBER && sp->type == T_FLOAT)
        {
            i = (double)((sp-1)->u.number) < READ_DOUBLE( sp );
            sp--;
            put_number(sp, i);
            break;
        }

        if ((sp-1)->type == T_FLOAT && sp->type == T_NUMBER)
        {
            i = READ_DOUBLE( sp-1 ) < (double)(sp->u.number);
            sp--;
            put_number(sp, i);
            break;
        }

        TYPE_TEST_EXP_LEFT((sp-1), TF_NUMBER|TF_STRING|TF_FLOAT);
        TYPE_TEST_EXP_RIGHT(sp, TF_NUMBER|TF_STRING|TF_FLOAT);
        ERRORF(("Arguments to < don't match: %s vs %s\n"
               , typename(sp[-1].type), typename(sp->type)
               ));
    }

    CASE(F_LE);                     /* --- le                  --- */
    {
        /* Test if sp[-1] <= sp[0]. If yes, push 1 onto the stack,
         * else 0 (of course after popping both arguments).
         *
         * Comparable types are int, string and float, each only
         * to its own type.
         */

        int i;

        if ((sp-1)->type == T_STRING && sp->type == T_STRING)
        {
            i = mstrcmp((sp-1)->u.str, sp->u.str) <= 0;
            free_string_svalue(sp);
            sp--;
            free_string_svalue(sp);
            put_number(sp, i);
            break;
        }

        if ((sp-1)->type == T_NUMBER && sp->type == T_NUMBER)
        {
            i = (sp-1)->u.number <= sp->u.number;
            sp--;
            sp->u.number = i;
            break;
        }

        if ((sp-1)->type == T_FLOAT && sp->type == T_FLOAT)
        {
            i = READ_DOUBLE( sp-1 ) <= READ_DOUBLE( sp );
            sp--;
            put_number(sp, i);
            break;
        }

        if ((sp-1)->type == T_NUMBER && sp->type == T_FLOAT)
        {
            i = (double)((sp-1)->u.number) <= READ_DOUBLE( sp );
            sp--;
            put_number(sp, i);
            break;
        }

        if ((sp-1)->type == T_FLOAT && sp->type == T_NUMBER)
        {
            i = READ_DOUBLE( sp-1 ) <= (double)(sp->u.number);
            sp--;
            put_number(sp, i);
            break;
        }

        TYPE_TEST_EXP_LEFT((sp-1), TF_NUMBER|TF_STRING|TF_FLOAT);
        TYPE_TEST_EXP_RIGHT(sp, TF_NUMBER|TF_STRING|TF_FLOAT);
        ERRORF(("Arguments to <= don't match: %s vs %s\n"
               , typename(sp[-1].type), typename(sp->type)
               ));
    }

    CASE(F_EQ);                     /* --- eq                  --- */
    {
        /* Test if sp[-1] == sp[0]. If yes, push 1 onto the stack,
         * else 0 (of course after popping both arguments).
         *
         * Comparable types are all types, each to its own. Comparisons
         * between distinct types (except between int and float) always
         * yield 'unequal'.
         * Vectors and mappings are compared by ref only.
         */

        int i = 0;

        if ((sp-1)->type == T_NUMBER && sp->type == T_FLOAT)
        {
            i = (double)((sp-1)->u.number) == READ_DOUBLE( sp );
        }
        else if ((sp-1)->type == T_FLOAT && sp->type == T_NUMBER)
        {
            i = READ_DOUBLE( sp-1 ) == (double)(sp->u.number);
        }
        else if ((sp-1)->type != sp->type)
        {
            i = 0;
        }
        else /* type are equal */
        {
            switch(sp->type)
            {
            case T_NUMBER:
                i = (sp-1)->u.number == sp->u.number;
                break;
            case T_POINTER:
                i = (sp-1)->u.vec == sp->u.vec;
                break;
#ifdef USE_STRUCTS
            case T_STRUCT:
                i = (sp-1)->u.strct == sp->u.strct;
                if (!i && struct_size((sp-1)->u.strct) == 0
                       && struct_size(sp->u.strct) == 0
                   )
                {
                    i = 1;
                }
                break;
#endif
            case T_STRING:
                i = mstreq((sp-1)->u.str, sp->u.str);
                break;
            case T_OBJECT:
                i = (sp-1)->u.ob == sp->u.ob;
                break;
            case T_FLOAT:
                i = READ_DOUBLE( sp-1 ) == READ_DOUBLE( sp );
                break;

            case T_CLOSURE:
                i = closure_eq(sp-1, sp);
                break;

            case T_SYMBOL:
            case T_QUOTED_ARRAY:
                i = (sp-1)->u.generic  == sp->u.generic &&
                    (sp-1)->x.generic == sp->x.generic;
                break;
            case T_MAPPING:
                i = (sp-1)->u.map == sp->u.map;
                break;
            default:
                if (sp->type == T_LVALUE)
                    errorf("Reference passed to ==\n");
                FATALF(("Illegal type '%s' to ==\n",typename(sp->type)));
                /* NOTREACHED */
                return MY_FALSE;
            }
        }

        pop_stack();
        free_svalue(sp);
        put_number(sp, i);
        break;
    }

    CASE(F_NE);                     /* --- ne                  --- */
    {
        /* Test if sp[-1] != sp[0]. If yes, push 1 onto the stack,
         * else 0 (of course after popping both arguments).
         *
         * Comparable types are all types, each to its own. Comparisons
         * between distinct types (except between int and float) always
         * yield 'unequal'.
         * Vectors and mappings are compared by ref only.
         */

        int i = 0;

        if ((sp-1)->type == T_NUMBER && sp->type == T_FLOAT)
        {
            i = (double)((sp-1)->u.number) != READ_DOUBLE( sp );
        }
        else if ((sp-1)->type == T_FLOAT && sp->type == T_NUMBER)
        {
            i = READ_DOUBLE( sp-1 ) != (double)(sp->u.number);
        }
        else if ((sp-1)->type != sp->type)
        {
            i = 1;
        }
        else /* type are equal */
        {
            switch(sp->type)
            {
            case T_NUMBER:
                i = (sp-1)->u.number != sp->u.number;
                break;
            case T_STRING:
                i = !mstreq((sp-1)->u.str, sp->u.str);
                break;
            case T_POINTER:
                i = (sp-1)->u.vec != sp->u.vec;
                break;
#ifdef USE_STRUCTS
            case T_STRUCT:
                i = (sp-1)->u.strct != sp->u.strct;
                break;
#endif
            case T_OBJECT:
                i = (sp-1)->u.ob != sp->u.ob;
                break;
            case T_FLOAT:
                i = READ_DOUBLE( sp-1 ) != READ_DOUBLE( sp );
                break;

            case T_CLOSURE:
                i = !closure_eq(sp-1, sp);
                break;

            case T_SYMBOL:
            case T_QUOTED_ARRAY:
                i = (sp-1)->u.generic  != sp->u.generic ||
                    (sp-1)->x.generic != sp->x.generic;
                break;
            case T_MAPPING:
                i = (sp-1)->u.map != sp->u.map;
                break;
            default:
                if (sp->type == T_LVALUE)
                    errorf("Reference passed to !=\n");
                FATALF(("Illegal type '%s' to !=\n",typename(sp->type)));
                /* NOTREACHED */
                return MY_FALSE;
            }
        }

        pop_stack();
        free_svalue(sp);
        put_number(sp, i);
        break;
    }

    CASE(F_COMPL);                  /* --- compl               --- */
        /* Compute the binary complement of number sp[0] and leave
         * that on the stack.
         */
        TYPE_TEST1(sp, T_NUMBER);
        sp->u.number = ~ sp->u.number;
        break;

    CASE(F_AND);                    /* --- and                 --- */
    {
        /* Compute the intersection of sp[-1] and sp[0] and leave
         * the result on the stack.
         *
         * Possible type combinations:
         *   int    & int    -> int
         *   string & string -> string
         *   vector & vector -> vector
         *   vector & mapping  -> vector
         *   mapping & vector  -> mapping
         *   mapping & mapping -> mapping
         *
         */

        int i;

        if (sp->type == T_POINTER && (sp-1)->type == T_POINTER)
        {
            inter_sp = sp - 2;
            (sp-1)->u.vec = intersect_array((sp-1)->u.vec, sp->u.vec);
            sp--;
            break;
        }

        if (sp[-1].type == T_POINTER
         && sp->type == T_MAPPING)
        {
            inter_sp = sp - 2;
            (sp-1)->u.vec = map_intersect_array(sp[-1].u.vec, sp->u.map);
            sp--;
            break;
        }

        if (sp->type == T_STRING && (sp-1)->type == T_STRING)
        {
            string_t * result;

            inter_sp = sp;
            result = intersect_strings(sp[-1].u.str, sp->u.str, MY_FALSE);
            free_string_svalue(sp-1);
            free_string_svalue(sp);
            put_string(sp-1, result);
            sp--;
            break;
        }

        if (sp->type == T_NUMBER && (sp-1)->type == T_NUMBER)
        {
            i = (sp-1)->u.number & sp->u.number;
            sp--;
            sp->u.number = i;
            break;
        }

        if (sp[-1].type == T_MAPPING
         && (sp->type == T_POINTER || sp->type == T_MAPPING))
        {
            inter_sp = sp - 2;
            (sp-1)->u.map = map_intersect(sp[-1].u.map, sp);
            sp--;
            break;
        }

        TYPE_TEST_EXP_LEFT((sp-1), TF_NUMBER|TF_STRING|TF_POINTER|TF_MAPPING);
        TYPE_TEST_EXP_RIGHT(sp, TF_NUMBER|TF_STRING|TF_POINTER|TF_MAPPING);
        ERRORF(("Arguments to & don't match: %s vs %s\n"
               , typename(sp[-1].type), typename(sp->type)
               ));

    }

    CASE(F_OR);                     /* --- or                  --- */
    {
        /* Compute the binary-or of sp[-1] and sp[0] and leave
         * the result on the stack.
         *
         * Possible type combinations:
         *   int    | int    -> int
         *   array  | array  -> array
         *
         * TODO: Extend this to mappings.
         */

        int i;

        TYPE_TEST_EXP_LEFT((sp-1), TF_NUMBER|TF_POINTER);
        if ((sp-1)->type == T_NUMBER)
        {
            TYPE_TEST_RIGHT(sp, T_NUMBER);
            i = (sp-1)->u.number | sp->u.number;
            sp--;
            sp->u.number = i;
        }
        else if ((sp-1)->type == T_POINTER)
        {
            TYPE_TEST_RIGHT(sp, T_POINTER);
            inter_sp = sp;
            inter_pc = pc;
            sp--;
            sp->u.vec = join_array(sp->u.vec, (sp+1)->u.vec);
        }

        break;
    }

    CASE(F_XOR);                    /* --- xor                 --- */
    {
        /* Compute the binary-xor of sp[-1] and sp[0] and leave
         * the result on the stack.
         *
         * Possible type combinations:
         *   int ^ int    -> int
         *   array ^ array  -> array
         *
         * TODO: Extend this to mappings.
         */

        int i;

        TYPE_TEST_EXP_LEFT((sp-1), TF_NUMBER|TF_POINTER);
        if ((sp-1)->type == T_NUMBER)
        {
            TYPE_TEST_RIGHT(sp, T_NUMBER);
            i = (sp-1)->u.number ^ sp->u.number;
            sp--;
            sp->u.number = i;
        }
        else if ((sp-1)->type == T_POINTER)
        {
            TYPE_TEST_RIGHT(sp, T_POINTER);
            sp--;
            sp->u.vec = symmetric_diff_array(sp->u.vec, (sp+1)->u.vec);
        }

        break;
    }

    CASE(F_LSH);                    /* --- lsh                 --- */
    {
        /* Shift number sp[-1] left by sp[0] bits and leave
         * the result on the stack.
         *
         * Possible type combinations:
         *   int << int    -> int
         *
         * TODO: Extend this to vectors and mappings.
         * TODO: Implement an arithmetic shift.
         */

        int i;

        TYPE_TEST_LEFT((sp-1), T_NUMBER);
        TYPE_TEST_RIGHT(sp, T_NUMBER);

        i = sp->u.number;
        sp--;
        sp->u.number = (uint)i > MAX_SHIFT ? 0 : sp->u.number << i;
        break;
    }

    CASE(F_RSH);                    /* --- rsh                 --- */
    {
        /* Arithmetically shift number sp[-1] right by sp[0] bits and leave
         * the result on the stack.
         *
         * Possible type combinations:
         *   int >> int    -> int
         *
         * TODO: Extend this to vectors and mappings.
         */

        int i;

        TYPE_TEST_LEFT((sp-1), T_NUMBER);
        TYPE_TEST_RIGHT(sp, T_NUMBER);

        i = sp->u.number;
        sp--;
        if ((uint)i <= MAX_SHIFT)
            sp->u.number >>= i;
        else if (sp->u.number >= 0)
            sp->u.number = 0;
        else
            sp->u.number = -1;
        break;
    }

    CASE(F_RSHL);                   /* --- rshl                --- */
    {
        /* Logically shift number sp[-1] right by sp[0] bits and leave
         * the result on the stack.
         *
         * Possible type combinations:
         *   int >>> int    -> int
         *
         * TODO: Extend this to vectors and mappings.
         */

        int i;

        TYPE_TEST_LEFT((sp-1), T_NUMBER);
        TYPE_TEST_RIGHT(sp, T_NUMBER);

        i = sp->u.number;
        sp--;
        if ((uint)i > MAX_SHIFT)
            sp->u.number = 0;
        else
            sp->u.number = (p_uint)sp->u.number >> i;
        break;
    }

    CASE(F_NOT);                    /* --- not                 --- */
        /* Compute the logical negation of sp[0] and put it onto the stack.
         * Every value != 0 is replaced by 0, just number 0 is replaced by 1.
         */

        if (sp->type == T_NUMBER)
        {
            if (sp->u.number == 0)
            {
                sp->u.number = 1;
                break;
            }
        } else
            free_svalue(sp);
        put_number(sp, 0);
        break;

    CASE(F_NX_RANGE);               /* --- nx_range            --- */
    CASE(F_RX_RANGE);               /* --- rx_range            --- */
    CASE(F_AX_RANGE);               /* --- ax_range            --- */
        /* Push '1' onto the stack to make up for the missing
         * upper range bound, then fall through to the normal
         * range handling.
         */
        sp++;
        put_number(sp, 1);
        /* FALLTHROUGH */

    CASE(F_RANGE);                  /* --- range               --- */
    CASE(F_NR_RANGE);               /* --- nr_range            --- */
    CASE(F_RN_RANGE);               /* --- rn_range            --- */
    CASE(F_RR_RANGE);               /* --- rr_range            --- */
    CASE(F_NA_RANGE);               /* --- na_range            --- */
    CASE(F_AN_RANGE);               /* --- an_range            --- */
    CASE(F_RA_RANGE);               /* --- ra_range            --- */
    CASE(F_AR_RANGE);               /* --- ar_range            --- */
    CASE(F_AA_RANGE);               /* --- aa_range            --- */
      {
        /* Compute the range sp[-1]..sp[0] from string/array sp[-2]
         * and leave it on the stack.
         * This code also handles the NX/RX/AX_RANGE, pretending that
         * they are NR/RR/AR_RANGEs.
         */

        if (sp[-1].type != T_NUMBER)
            ERRORF(("Bad type '%s' of start interval to [..] range.\n"
                   , typename(sp[-1].type)
                   ));
        if (sp[0].type != T_NUMBER)
            ERRORF(("Bad type '%s' of end interval to [..] range.\n"
                   , typename(sp[0].type)
                   ));

        if (sp[-2].type == T_POINTER)
        {
            /* Slice a range from an array */

            vector_t *v;
            p_int size, i1, i2;

            size = VEC_SIZE(sp[-2].u.vec);

            if (instruction == F_RANGE
             || instruction == F_NR_RANGE
             || instruction == F_NA_RANGE
             || instruction == F_NX_RANGE)
                i1 = sp[-1].u.number;
            else
            if (instruction == F_AN_RANGE
             || instruction == F_AR_RANGE
             || instruction == F_AA_RANGE
             || instruction == F_AX_RANGE)
            {
                if (sp[-1].u.number < 0)
                    i1 = size + sp[-1].u.number;
                else
                    i1 = sp[-1].u.number;
            }
            else
                i1 = size - sp[-1].u.number;

            if (instruction == F_RANGE
             || instruction == F_RN_RANGE
             || instruction == F_AN_RANGE)
                i2 = sp[0].u.number;
            else
            if (instruction == F_NA_RANGE
             || instruction == F_RA_RANGE
             || instruction == F_AA_RANGE)
            {
                if (sp[0].u.number < 0)
                    i2 = size + sp[0].u.number;
                else
                    i2 = sp[0].u.number;
            }
            else
                i2 = size - sp[0].u.number;

            if (runtime_array_range_check)
            {
                if (i1 < 0 || i1 >= size)
                {
                    if (i2 < 0 || i2 >= size)
                        WARNF(("Warning: Out-of-bounds range limits: [%"
                               PRIdPINT"..%"PRIdPINT"], size %"PRIdPINT".\n"
                              , i1, i2, size));
                    else
                        WARNF(("Warning: Out-of-bounds lower range limits: %"
                               PRIdPINT", size %"PRIdPINT".\n"
                              , i1, size));
                }
                else if (i2 < 0 || i2 >= size)
                {
                    WARNF(("Warning: Out-of-bounds upper range limits: %"
                           PRIdPINT", size %"PRIdPINT".\n"
                          , i2, size));
                }
                else if (i1 > i2)
                {
                    WARNF(("Warning: Ranges of negative size: %"PRIdPINT
                           "..%"PRIdPINT".\n"
                          , i1, i2));
                }
            }

            if (i2 >= size)
            {
                i2 = size - 1;
            }

            pop_stack();
            pop_stack();

            v = slice_array(sp->u.vec, i1, i2);

            free_array(sp->u.vec);
            if (v)
            {
                sp->u.vec = v;
            }
            else
            {
                put_number(sp, 0);
            }
        }
        else if (sp[-2].type == T_STRING)
        {
            /* Slice a range from string */

            p_int len, from, to;
            string_t *res;

            len = mstrsize(sp[-2].u.str);
            if (instruction == F_RANGE
             || instruction == F_NR_RANGE
             || instruction == F_NX_RANGE
             || instruction == F_NA_RANGE)
                from = sp[-1].u.number;
            else
            if (instruction == F_AN_RANGE
             || instruction == F_AR_RANGE
             || instruction == F_AX_RANGE
             || instruction == F_AA_RANGE)
            {
                if (sp[-1].u.number < 0)
                    from = len + sp[-1].u.number;
                else
                    from = sp[-1].u.number;
            }
            else
                from = len - sp[-1].u.number;
            if (from < 0)
            {
                from = 0;
            }

            if (instruction == F_RANGE
             || instruction == F_RN_RANGE
             || instruction == F_AN_RANGE)
                to = sp[0].u.number;
            else
            if (instruction == F_NA_RANGE
             || instruction == F_RA_RANGE
             || instruction == F_AA_RANGE)
            {
                if (sp[0].u.number < 0)
                    to = len + sp[0].u.number;
                else
                    to = sp[0].u.number;
            }
            else
                to = len - sp[0].u.number;
            if (to >= len)
                to = len-1;

            if (to < from)
            {
                pop_n_elems(3);
                push_ref_string(sp, STR_EMPTY);
                break;
            }

            if (to == len-1)
            {
                res = mstr_extract(sp[-2].u.str, from, -1);
            }
            else
            {
                res = mstr_extract(sp[-2].u.str, from, to);
            }

            if (res == NULL)
            {
                ERRORF(("Out of memory (%"PRIdPINT" bytes).\n", to-from+1));
            }
            pop_n_elems(3);
            push_string(sp, res);
        }
        else
        {
            ERRORF(("Bad argument to [..] operand: got %s, "
                    "expected string/array.\n", typename(sp[-2].type)
                    ));
        }
        break;
      }

    CASE(F_ADD_EQ);                 /* --- add_eq              --- */
    CASE(F_VOID_ADD_EQ);            /* --- void_add_eq         --- */
    {
        /* Add sp[-1] to the value designated by lvalue sp[0] (the order
         * is important) and assign the result to sp[0].
         * For F_ADD_EQ, the result is also left on the stack.
         *
         * Possible type combinations:
         *   string       + (string,int,float) -> string
         *   int          + string             -> string
         *   int          + int                -> int
         *   int          + float              -> float
         *   float        + (float,int)        -> float
         *   vector       + vector             -> vector
         *   mapping      + mapping            -> mapping
         * TODO: This type mapping should be documented in 2-dim-arrays,
         * TODO:: one each for F_ADD_EQ, F_MULT_EQ, etc. This would
         * TODO:: also make the checks in the compiler simpler.
         */

        short type2;         /* type and value of sp[-1] */
        union u u2;
        svalue_t *argp; /* the actual value of sp[0] */

        type2 = sp[-1].type;
        u2 = sp[-1].u;

#ifdef DEBUG
        TYPE_TEST_LEFT(sp, T_LVALUE);
#endif

        /* Set argp to the actual value designated by sp[0] */
        for ( argp = sp->u.lvalue
            ; T_LVALUE == argp->type || T_PROTECTED_LVALUE == argp->type
            ; argp = argp->u.lvalue)
            NOOP;

        /* Now do it */
        switch(argp->type)
        {

        case T_STRING:  /* Adding to a string */
          {
            string_t *new_string;

            /* Perform the addition, creating new_string */
            if (type2 == T_STRING)
            {
                string_t *left, *right;
                size_t len;

                left = argp->u.str;
                right = (sp-1)->u.str;

                len = mstrsize(left) + mstrsize(right);
                DYN_STRING_COST(len)
                new_string = mstr_add(left, right);
                if (!new_string)
                    ERRORF(("Out of memory (%zu bytes)\n", len));
                free_string_svalue(sp-1);
                sp -= 2;
            }
            else if (type2 == T_NUMBER)
            {
                char buff[80];
                size_t len;

                buff[sizeof(buff)-1] = '\0';
                sprintf(buff, "%ld", (long)u2.number);
                if (buff[sizeof(buff)-1] != '\0')
                    FATAL("Buffer overflow in F_ADD_EQ: int number too big.\n");
                len = mstrsize(argp->u.str)+strlen(buff);
                DYN_STRING_COST(len)
                new_string = mstr_add_txt(argp->u.str, buff, strlen(buff));
                if (!new_string)
                    ERRORF(("Out of memory (%lu bytes)\n"
                           , (unsigned long) len
                           ));
                sp -= 2;
            }
            else if (type2 == T_FLOAT)
            {
                char buff[160];
                size_t len;

                buff[sizeof(buff)-1] = '\0';
                sprintf(buff, "%g", READ_DOUBLE(sp-1) );
                if (buff[sizeof(buff)-1] != '\0')
                    FATAL("Buffer overflow in F_ADD_EQ: float number too big.\n");
                len = mstrsize(argp->u.str) + strlen(buff);
                DYN_STRING_COST(len)
                new_string = mstr_add_txt(argp->u.str, buff, strlen(buff));
                if (!new_string)
                    ERRORF(("Out of memory (%zu bytes).\n", len));
                sp -= 2;
            }
            else
            {
                OP_ARG_ERROR(2, TF_STRING|TF_FLOAT|TF_NUMBER, type2);
                /* NOTREACHED */
            }

            /* Replace *argp by the new string */
            free_string_svalue(argp);
            put_string(argp, new_string);
            break;
          }

        case T_NUMBER:  /* Add to a number */
            if (type2 == T_NUMBER)
            {
                p_int left = argp->u.number;
                p_int right = u2.number;

                if ((left >= 0 && right >= 0 && PINT_MAX - left < right)
                 || (left < 0 && right < 0 && PINT_MIN - left > right)
                   )
                {
                    ERRORF(("Numeric overflow: %"PRIdPINT" += %"PRIdPINT"\n"
                           , left, right));
                    /* NOTREACHED */
                    break;
                }

                if (instruction == F_VOID_ADD_EQ)
                {
                    argp->u.number += u2.number;
                    sp -= 2;
                    goto again;
                }
                (--sp)->u.number = argp->u.number += u2.number;
                goto again;
            }
            else if (type2 == T_FLOAT)
            {
                STORE_DOUBLE_USED
                double sum;

                sum = (double)(argp->u.number) + READ_DOUBLE(sp-1);
                if (sum < (-DBL_MAX) || sum > DBL_MAX)
                    ERRORF(("Numeric overflow: %"PRIdPINT" + %g\n"
                           , argp->u.number, READ_DOUBLE(sp-1)));
                argp->type = T_FLOAT;
                STORE_DOUBLE(argp, sum);
                if (instruction == F_VOID_ADD_EQ)
                {
                    sp -= 2;
                    goto again;
                }

                --sp;
                sp->type = T_FLOAT;
                STORE_DOUBLE(sp, sum);
                goto again;
            }
            else if (type2 == T_STRING)
            {
                char buff[80];
                string_t *right, *res;
                size_t len;

                right = (sp-1)->u.str;
                buff[sizeof(buff)-1] = '\0';
                sprintf(buff, "%"PRIdPINT, argp->u.number);
                if (buff[sizeof(buff)-1] != '\0')
                    FATAL("Buffer overflow in F_ADD_EQ: int number too big.\n");
                len = mstrsize(right)+strlen(buff);
                DYN_STRING_COST(len)
                res = mstr_add_to_txt(buff, strlen(buff), right);
                if (!res)
                    ERRORF(("Out of memory (%zu bytes)\n", len));
                free_string_svalue(sp-1);

                /* Overwrite the number in argp */
                put_string(argp, res);

                if (instruction == F_VOID_ADD_EQ)
                {
                    sp -= 2;
                    goto again;
                }

                --sp;
                put_ref_string(sp, res);

                goto again;
            }
            else
            {
                OP_ARG_ERROR(2, TF_NUMBER, type2);
                /* NOTREACHED */
            }
            break;

        case T_CHAR_LVALUE:  /* Add to a character in a string */
            if (type2 == T_NUMBER)
            {
                p_int left = (unsigned char)*argp->u.charp;
                p_int right = u2.number;

                if ((left >= 0 && right >= 0 && PINT_MAX - left < right)
                 || (left < 0 && right < 0 && PINT_MIN - left > right)
                   )
                {
                    ERRORF(("Numeric overflow: %"PRIdPINT" += %"PRIdPINT"\n"
                           , left, right));
                    /* NOTREACHED */
                    break;
                }

                if (instruction == F_VOID_ADD_EQ)
                {
                    *argp->u.charp += u2.number;
                    sp -= 2;
                    goto again;
                }
                (--sp)->u.number = (unsigned char)(*argp->u.charp += u2.number);
                goto again;
            }
            else
            {
                OP_ARG_ERROR(2, TF_NUMBER, type2);
                /* NOTREACHED */
            }
            break;

        case T_MAPPING:  /* Add to a mapping */
            if (type2 != T_MAPPING)
            {
                OP_ARG_ERROR(2, TF_MAPPING, type2);
                /* NOTREACHED */
            }
            else
            {
                check_map_for_destr(u2.map);
                add_to_mapping(argp->u.map, u2.map);
                sp -= 2;
                free_mapping(u2.map);
                if ((max_mapping_size && MAP_TOTAL_SIZE(argp->u.map) > (p_int)max_mapping_size)
                 || (max_mapping_keys && MAP_SIZE(argp->u.map) > (p_int)max_mapping_keys)
                  )
                {
                    check_map_for_destr(argp->u.map);
                    if (max_mapping_size && MAP_TOTAL_SIZE(argp->u.map) > (p_int)max_mapping_size)
                        ERRORF(("Illegal mapping size: %"PRIdMPINT" elements "
                                "(%"PRIdPINT" x %"PRIdPINT")\n"
                               , (mp_int)MAP_TOTAL_SIZE(argp->u.map)
                               , MAP_SIZE(argp->u.map)
                               , argp->u.map->num_values));
                    if (max_mapping_keys && MAP_SIZE(argp->u.map) > (p_int)max_mapping_keys)
                        ERRORF(("Illegal mapping size: %"PRIdPINT" entries\n"
                               , MAP_SIZE(argp->u.map)
                              ));
                }
            }
            break;

        case T_POINTER:  /* Add to an array */
            if (type2 != T_POINTER)
            {
                OP_ARG_ERROR(2, TF_POINTER, type2);
                /* NOTREACHED */
            }
            else
            {
                vector_t *v;

                inter_sp = sp;
                inter_pc = pc;
                DYN_ARRAY_COST(VEC_SIZE(u2.vec)+VEC_SIZE(argp->u.vec));
                v = inter_add_array(u2.vec, &argp->u.vec);
                if (instruction == F_VOID_ADD_EQ)
                {
                    sp -= 2;
                    goto again;
                }
                sp--;
                sp->u.vec = ref_array(v);
                goto again;
                }
            break;

        case T_FLOAT:  /* Add to a float */
            if (type2 == T_FLOAT)
            {
                STORE_DOUBLE_USED
                double d;

                   /* don't use the address of u2, this would prevent putting
                    * it in a register
                    */
                d = READ_DOUBLE(argp) + READ_DOUBLE(sp-1);
                if (d < (-DBL_MAX) || d > DBL_MAX)
                    ERRORF(("Numeric overflow: %g + %g\n"
                           , READ_DOUBLE(argp), READ_DOUBLE(sp-1)));
                STORE_DOUBLE(argp, d);
                sp -= 2;
            }
            else if (type2 == T_NUMBER)
            {
                STORE_DOUBLE_USED
                double d;

                d = READ_DOUBLE(argp) + (double)sp[-1].u.number;
                if (d < (-DBL_MAX) || d > DBL_MAX)
                    ERRORF(("Numeric overflow: %g + %"PRIdPINT"\n"
                           , READ_DOUBLE(argp), (sp-1)->u.number));
                STORE_DOUBLE(argp, d);
                sp -= 2;
            }
            else
            {
                OP_ARG_ERROR(2, TF_FLOAT|TF_NUMBER, type2);
                /* NOTREACHED */
            }
            break;

        default:
            OP_ARG_ERROR(1, TF_STRING|TF_FLOAT|TF_MAPPING|TF_POINTER|TF_NUMBER
                        , argp->type);
            /* NOTREACHED */
        } /* end of switch */

        /* If the instruction is F_ADD_EQ, leave the result on the stack */
        if (instruction != F_VOID_ADD_EQ)
        {
            sp++;
            assign_svalue_no_free(sp, argp);
        }
        break;
    }

    CASE(F_SUB_EQ);                 /* --- sub_eq              --- */
    {
        /* Subtract sp[-1] from the value designated by lvalue sp[0] (the
         * order is important), assign the result to sp[0] and also leave
         * it on the stack.
         *
         * Possible type combinations:
         *   int         - int                -> int
         *   float       - (float,int)        -> float
         *   int         - float              -> float
         *   string      - string             -> string
         *   vector      - vector             -> vector
         *   mapping     - mapping            -> mapping
         */

        short type2;         /* type and value of sp[-1] */
        union u u2;
        svalue_t *argp; /* the actual value of sp[0] */

        type2 = sp[-1].type;
        u2 = sp[-1].u;

#ifdef DEBUG
        TYPE_TEST_LEFT(sp, T_LVALUE);
#endif

        /* Set argp to the actual value designated by sp[0] */
        for ( argp = sp->u.lvalue
            ; T_LVALUE == argp->type || T_PROTECTED_LVALUE == argp->type
            ; argp = argp->u.lvalue)
            NOOP;

        /* Now do it */
        switch (argp->type)
        {
        case T_NUMBER:  /* Subtract from a number */
            if (type2 == T_NUMBER)
            {
                p_int left = argp->u.number;
                p_int right = u2.number;

                if ((left >= 0 && right < 0 && PINT_MAX + right < left)
                 || (left < 0 && right >= 0 && PINT_MIN + right > left)
                   )
                {
                    ERRORF(("Numeric overflow: %"PRIdPINT" -= %"PRIdPINT"\n"
                           , left, right));
                    /* NOTREACHED */
                    break;
                }
                sp--;
                sp->u.number = argp->u.number -= u2.number;
                break;
            }

            if (type2 == T_FLOAT)
            {
                STORE_DOUBLE_USED
                double diff;

                sp--;
                diff = (double)(argp->u.number) - READ_DOUBLE(sp);
                if (diff < (-DBL_MAX) || diff > DBL_MAX)
                    ERRORF(("Numeric overflow: %"PRIdPINT" - %g\n"
                           , argp->u.number, READ_DOUBLE(sp)));
                STORE_DOUBLE(sp, diff);
                sp->type = T_FLOAT;
                assign_svalue_no_free(argp, sp);
                break;
            }

            /* type2 of the wrong type */
            OP_ARG_ERROR(2, TF_NUMBER|TF_FLOAT, type2);
            /* NOTREACHED */
            break;

        case T_CHAR_LVALUE:  /* Subtract from a char in a string */
            if (type2 != T_NUMBER)
            {
                OP_ARG_ERROR(2, TF_NUMBER, type2);
                /* NOTREACHED */
            }

            {
                p_int left = (unsigned char)*argp->u.charp;
                p_int right = u2.number;

                if ((left >= 0 && right < 0 && PINT_MAX + right < left)
                 || (left < 0 && right >= 0 && PINT_MIN + right > left)
                   )
                {
                    ERRORF(("Numeric overflow: %"PRIdPINT" -= %"PRIdPINT"\n"
                           , left, right));
                    /* NOTREACHED */
                    break;
                }
            }

            sp--;
            sp->u.number = (unsigned char)(*argp->u.charp -= u2.number);
            break;

        case T_STRING:   /* Subtract from a string */
        {
            string_t * result;

            if (type2 != T_STRING)
            {
                OP_ARG_ERROR(2, TF_STRING, type2);
                /* NOTREACHED */
            }

            inter_sp = sp;
            result = intersect_strings(argp->u.str, (sp-1)->u.str, MY_TRUE);
            free_string_svalue(argp);
            put_string(argp, result);
            free_svalue(sp);
            sp--;
            free_string_svalue(sp);
            put_ref_string(sp, result);
            break;
        }

        case T_POINTER:  /* Subtract from an array */
          {
            vector_t *v, *v_old;

            if (type2 != T_POINTER)
            {
                OP_ARG_ERROR(2, TF_POINTER, type2);
                /* NOTREACHED */
            }

            v = u2.vec;

            /* Duplicate the minuend array if necessary, as
             * the subtraction will change and free it
             */
            if (v->ref > 1)
            {
                deref_array(v);
                v = slice_array(v, 0, (mp_int)VEC_SIZE(v)-1 );
            }
            sp--;
            v_old = argp->u.vec;
            v = subtract_array(v_old, v);
            argp->u.vec = v;
            put_ref_array(sp, v);
            break;
          }

        case T_FLOAT:  /* Subtract from a float */
            if (type2 == T_FLOAT)
            {
                STORE_DOUBLE_USED
                double d;

                /* don't use the address of u2, this would prevent putting it
                 * in a register
                 */
                sp--;
                d = READ_DOUBLE(argp) - READ_DOUBLE(sp);
                if (d < (-DBL_MAX) || d > DBL_MAX)
                    ERRORF(("Numeric overflow: %g + %g\n"
                           , READ_DOUBLE(argp), READ_DOUBLE(sp)));
                STORE_DOUBLE(argp, d);
                *sp = *argp;
            }
            else if (type2 == T_NUMBER)
            {
                STORE_DOUBLE_USED
                double d;

                sp--;
                d = READ_DOUBLE(argp) - (double)sp->u.number;
                if (d < (-DBL_MAX) || d > DBL_MAX)
                    ERRORF(("Numeric overflow: %g + %"PRIdPINT"\n"
                           , READ_DOUBLE(argp), sp->u.number));
                STORE_DOUBLE(argp, d);
                *sp = *argp;
            }
            else
            {
                OP_ARG_ERROR(2, TF_FLOAT|TF_NUMBER, type2);
                /* NOTREACHED */
            }
            break;

        case T_MAPPING:  /* Subtract from a mapping */
            if (type2 == T_MAPPING)
            {
                mapping_t *m;

                sp--;
                m = sp->u.map;
                check_map_for_destr(m);

                /* Test for the special case 'm - m' */
                if (m == argp->u.map)
                {
                    /* m->ref is > 1, because the content of the lvalue is
                     * associated with a ref
                     */
                    deref_mapping(m);
                    m = copy_mapping(m);
                }

                walk_mapping(m, sub_from_mapping_filter, argp->u.map);
                free_mapping(m);
                sp->u.map = ref_mapping(argp->u.map);
            }
            else if (type2 == T_MAPPING && sp[-1].u.map->num_values)
            {
                ERROR("Bad right arg to -=: mapping has values.\n");
                /* NOTREACHED */
            }
            else
            {
                OP_ARG_ERROR(2, TF_MAPPING, type2);
                /* NOTREACHED */
            }
            break;

        default:
            OP_ARG_ERROR(1, TF_STRING|TF_FLOAT|TF_MAPPING|TF_POINTER|TF_NUMBER
                        , argp->type);
            /* NOTREACHED */
        } /* end of switch */
        break;
    }

    CASE(F_MULT_EQ);                /* --- mult_eq             --- */
    {
        /* Multiply sp[-1] to the value designated by lvalue sp[0],
         * assign the result to sp[0] and also leave it on the stack.
         *
         * Possible type combinations:
         *   int         * int                -> int
         *   float       * (float,int)        -> float
         *   int         * float              -> float
         *   string      * int                -> string
         *   array       * int                -> array
         *
         * TODO: Extend this to mappings.
         */

        svalue_t *argp;

#ifdef DEBUG
        TYPE_TEST_LEFT(sp, T_LVALUE);
#endif

        /* Set argp to the actual value designated by sp[0] */
        for ( argp = sp->u.lvalue
            ; T_LVALUE == argp->type || T_PROTECTED_LVALUE == argp->type
            ; argp = argp->u.lvalue)
            NOOP;

        /* Now do it */
        if (argp->type == T_NUMBER)
        {
            sp--;
            if (sp->type == T_NUMBER)
            {
                p_int left = argp->u.number;
                p_int right = sp->u.number;

                if (left > 0 && right > 0)
                {
                    if ((left != 0 && PINT_MAX / left < right)
                     || (right != 0 && PINT_MAX / right < left)
                       )
                    {
                        ERRORF(("Numeric overflow: %"PRIdPINT" *= %"
                                PRIdPINT"\n"
                               , left, right));
                        /* NOTREACHED */
                        break;
                    }
                }
                else if (left < 0 && right < 0)
                {
                    if ((left != 0 && PINT_MAX / left > right)
                     || (right != 0 && PINT_MAX / right > left)
                       )
                    {
                        ERRORF(("Numeric overflow: %"PRIdPINT" *= %"
                                PRIdPINT"\n"
                               , left, right));
                        /* NOTREACHED */
                        break;
                    }
                }
                else if (left != 0 && right != 0)
                {
                    if ((left > 0 && PINT_MIN / left > right)
                     || (right > 0 && PINT_MIN / right > left)
                       )
                    {
                        ERRORF(("Numeric overflow: %"PRIdPINT" *= %"
                                PRIdPINT"\n"
                               , left, right));
                        /* NOTREACHED */
                        break;
                    }
                }
                sp->u.number = argp->u.number *= sp->u.number;
                break;
            } /* type2 == T_NUMBER */

            if (sp->type == T_FLOAT)
            {
                STORE_DOUBLE_USED
                double product;

                product = argp->u.number * READ_DOUBLE(sp);
                if (product < (-DBL_MAX) || product > DBL_MAX)
                    ERRORF(("Numeric overflow: %"PRIdPINT" * %g\n"
                           , argp->u.number, READ_DOUBLE(sp)));
                STORE_DOUBLE(sp, product);
                sp->type = T_FLOAT;
                assign_svalue_no_free(argp, sp);
                break;
            }

            /* Unsupported type2 */
            OP_ARG_ERROR(2, TF_NUMBER|TF_FLOAT, sp->type);
            /* NOTREACHED */
        }

        if (argp->type == T_CHAR_LVALUE)
        {
            sp--;
            if (sp->type != T_NUMBER)
            {
                OP_ARG_ERROR(2, TF_NUMBER, sp->type);
                /* NOTREACHED */
            }
            {
                p_int left = (unsigned char)*argp->u.charp;
                p_int right = sp->u.number;

                if (left > 0 && right > 0)
                {
                    if ((left != 0 && PINT_MAX / left < right)
                     || (right != 0 && PINT_MAX / right < left)
                       )
                    {
                        ERRORF(("Numeric overflow: %"PRIdPINT" *= %"
                                PRIdPINT"\n", left, right));
                        /* NOTREACHED */
                        break;
                    }
                }
                else if (left < 0 && right < 0)
                {
                    if ((left != 0 && PINT_MAX / left > right)
                     || (right != 0 && PINT_MAX / right > left)
                       )
                    {
                        ERRORF(("Numeric overflow: %"PRIdPINT" *= %"
                                PRIdPINT"\n", left, right));
                        /* NOTREACHED */
                        break;
                    }
                }
                else if (left != 0 && right != 0)
                {
                    if ((left > 0 && PINT_MIN / left > right)
                     || (right > 0 && PINT_MIN / right > left)
                       )
                    {
                        ERRORF(("Numeric overflow: %"PRIdPINT" *= %"
                                PRIdPINT"\n", left, right));
                        /* NOTREACHED */
                        break;
                    }
                }
            }
            sp->u.number = (unsigned char)(*argp->u.charp *= sp->u.number);
            break;
        }

        if (argp->type == T_FLOAT)
        {
            STORE_DOUBLE_USED
            double d;

            sp--;
            if (sp->type == T_FLOAT)
            {
                d = READ_DOUBLE(argp) * READ_DOUBLE(sp);
                if (d < (-DBL_MAX) || d > DBL_MAX)
                    ERRORF(("Numeric overflow: %g * %g\n"
                           , READ_DOUBLE(argp), READ_DOUBLE(sp)));
                STORE_DOUBLE(argp, d);
                *sp = *argp;
            }
            else if (sp->type == T_NUMBER)
            {
                d = READ_DOUBLE(argp) * (double)sp->u.number;
                if (d < (-DBL_MAX) || d > DBL_MAX)
                    ERRORF(("Numeric overflow: %g * %"PRIdPINT"\n"
                           , READ_DOUBLE(argp), sp->u.number));
                STORE_DOUBLE(argp, d);
                *sp = *argp;
            }
            else
            {
                OP_ARG_ERROR(2, TF_NUMBER|TF_FLOAT, sp->type);
                /* NOTREACHED */
            }
            break;
        }

        if (argp->type == T_STRING)
        {
            string_t * result;
            size_t reslen;
            size_t len;

            sp--;
            if (sp->type != T_NUMBER)
            {
                OP_ARG_ERROR(2, TF_NUMBER, sp->type);
                /* NOTREACHED */
            }
            if (sp->u.number < 0)
            {
                ERROR("Bad right arg to *=: negative number\n");
                /* NOTREACHED */
            }

            len = mstrsize(argp->u.str);

            if (len > (size_t)PINT_MAX
             || (   len != 0
                 && PINT_MAX / (p_int)len < sp->u.number)
             || (   sp->u.number != 0
                 && PINT_MAX / sp->u.number < (p_int)len)
               )
                ERRORF(("Result string too long (%"PRIdPINT" * %zu).\n"
                       , sp->u.number, len
                       ));

            reslen = (size_t)sp->u.number * len;
            result = mstr_repeat(argp->u.str, (size_t)sp->u.number);
            if (!result)
                ERRORF(("Out of memory (%zu bytes).\n", reslen));

            DYN_STRING_COST(reslen)

            free_string_svalue(argp);
            put_string(argp, result);
            assign_svalue_no_free(sp, argp);
            break;
        }

        if (argp->type == T_POINTER)
        {
            vector_t *result;
            mp_int reslen;
            p_uint len;

            sp--;
            if (sp->type != T_NUMBER)
            {
                OP_ARG_ERROR(2, TF_NUMBER, sp->type);
                /* NOTREACHED */
            }
            if (sp->u.number < 0)
            {
                ERROR("Bad right arg to *=: negative number\n");
                /* NOTREACHED */
            }

            inter_sp = sp;
            inter_pc = pc;
            len = VEC_SIZE(argp->u.vec);
            reslen = sp->u.number * (mp_int)len;
            result = allocate_uninit_array(reslen);
            DYN_ARRAY_COST(reslen);

            if (sp->u.number > 0 && len)
            {
                p_uint left;
                svalue_t *from, *to;

                /* Seed result[] with one copy of the array.
                 */
                for ( from = argp->u.vec->item, to = result->item, left = len
                    ; left
                    ; from++, to++, left--)
                {
                    assign_svalue_no_free(to, from);
                } /* for() seed */

                /* Now fill the remainder of the vector with
                 * the values already copied in there.
                 */
                for (from = result->item, left = reslen - len
                    ; left
                    ; to++, from++, left--
                    )
                    assign_svalue_no_free(to, from);
            } /* if (len) */

            free_svalue(argp);
            put_array(argp, result);
            assign_svalue_no_free(sp, argp);
            break;
        }

        OP_ARG_ERROR(1, TF_STRING|TF_FLOAT|TF_POINTER|TF_NUMBER
                    , argp->type);
        /* NOTREACHED */
        break;
    }

    CASE(F_DIV_EQ);                 /* --- div_eq              --- */
    {
        /* Divide the value designated by lvalue sp[0] by sp[-1],
         * assign the result to sp[0] and also leave it on the stack.
         *
         * Possible type combinations:
         *   int         / int                -> int
         *   float       / (float,int)        -> float
         *   int         - float              -> float
         *
         * TODO: Extend this to arrays and mappings.
         */

        svalue_t *argp;

#ifdef DEBUG
        TYPE_TEST_LEFT(sp, T_LVALUE);
#endif

        /* Set argp to the actual value designated by sp[0] */
        for ( argp = sp->u.lvalue
            ; T_LVALUE == argp->type || T_PROTECTED_LVALUE == argp->type
            ; argp = argp->u.lvalue)
            NOOP;

        /* Now do it */
        if (argp->type == T_NUMBER)
        {
            sp--;
            if (sp->type == T_NUMBER)
            {
                if (sp->u.number == 0)
                    ERROR("Division by zero\n");
                if (argp->u.number == PINT_MIN && sp->u.number == -1)
                    ERRORF(("Numeric overflow: %"PRIdPINT" / -1\n"
                           , argp->u.number
                           ));
                sp->u.number = argp->u.number /= sp->u.number;
                break;
            }

            if (sp->type == T_FLOAT)
            {
                double dtmp;
                STORE_DOUBLE_USED

                dtmp = READ_DOUBLE( sp );
                if (dtmp == 0.)
                    ERROR("Division by zero\n");
                dtmp = (double)argp->u.number / dtmp;
                if (dtmp < (-DBL_MAX) || dtmp > DBL_MAX)
                    ERRORF(("Numeric overflow: %"PRIdPINT" / %g\n"
                           , argp->u.number, READ_DOUBLE(sp)));
                STORE_DOUBLE(sp, dtmp);
                sp->type = T_FLOAT;
                assign_svalue_no_free(argp, sp);
                break;
            }

            /* Unsupported type2 */
            OP_ARG_ERROR(2, TF_NUMBER|TF_FLOAT, sp->type);
            /* NOTREACHED */
        }

        if (argp->type == T_CHAR_LVALUE)
        {
            sp--;
            if (sp->type != T_NUMBER)
            {
                OP_ARG_ERROR(2, TF_NUMBER, sp->type);
                /* NOTREACHED */
            }
            if (sp->u.number == 0)
                ERROR("Division by zero\n");
            sp->u.number = (unsigned char)(*argp->u.charp /= sp->u.number);
            break;
        }

        if (argp->type == T_FLOAT)
        {
            STORE_DOUBLE_USED
            double d;

            sp--;
            if (sp->type == T_FLOAT)
            {
                d = READ_DOUBLE(sp);
                if (d == 0.0)
                    ERROR("Division by zero\n");
                d = READ_DOUBLE(argp) / d;
                if (d < (-DBL_MAX) || d > DBL_MAX)
                    ERRORF(("Numeric overflow: %g / %g\n"
                           , READ_DOUBLE(argp), READ_DOUBLE(sp)));
                STORE_DOUBLE(argp, d);
                *sp = *argp;
            }
            else if (sp->type == T_NUMBER)
            {
                p_int i;
                i = sp->u.number;
                if (i == 0)
                    ERROR("Division by zero\n");
                d = READ_DOUBLE(argp) / (double)i;
                if (d < (-DBL_MAX) || d > DBL_MAX)
                    ERRORF(("Numeric overflow: %g / %"PRIdPINT"\n"
                           , READ_DOUBLE(argp), sp->u.number));
                STORE_DOUBLE(argp, d);
                *sp = *argp;
            }
            else
            {
                OP_ARG_ERROR(2, TF_NUMBER|TF_FLOAT, sp->type);
                /* NOTREACHED */
            }
            break;
        }
        OP_ARG_ERROR(1, TF_FLOAT|TF_NUMBER, argp->type);
        /* NOTREACHED */
    }

    CASE(F_MOD_EQ);                 /* --- mod_eq              --- */
    {
        /* Compute the modulus of the value designated by lvalue sp[0]
         * divided by sp[-1], assign the result to sp[0] and also
         * leave it on the stack.
         *
         * Possible type combinations:
         *   int         % int                -> int
         *
         * TODO: Extend this to arrays and mappings.
         * TODO: Implement the other remainder function.
         */

        svalue_t *argp;

#ifdef DEBUG
        TYPE_TEST_LEFT(sp, T_LVALUE);
#endif

        /* Set argp to the actual value designated by sp[0] */
        for ( argp = sp->u.lvalue
            ; T_LVALUE == argp->type || T_PROTECTED_LVALUE == argp->type
            ; argp = argp->u.lvalue)
            NOOP;

        /* Now do it */
        if (argp->type == T_NUMBER)
        {
            sp--;
            if (sp->type != T_NUMBER)
            {
                OP_ARG_ERROR(2, TF_NUMBER, sp->type);
                /* NOTREACHED */
            }
            if (sp->u.number == 0)
                ERROR("Division by zero\n");
            sp->u.number = argp->u.number %= sp->u.number;
            break;
        }

        if (argp->type == T_CHAR_LVALUE)
        {
            sp--;
            if (sp->type != T_NUMBER)
            {
                OP_ARG_ERROR(2, TF_NUMBER, sp->type);
                /* NOTREACHED */
            }
            if (sp->u.number == 0)
                ERROR("Division by zero\n");
            sp->u.number = (unsigned char)(*argp->u.charp %= sp->u.number);
            break;
        }

        OP_ARG_ERROR(1, TF_NUMBER, argp->type);
        /* NOTREACHED */
    }

    CASE(F_AND_EQ);                 /* --- and_eq              --- */
    {
        /* Intersect the value designated by lvalue sp[0] with sp[-1],
         * assign the result to sp[0] and also leave it on the stack.
         *
         * Possible type combinations:
         *   int    & int    -> int
         *   string & string -> string
         *   array  & array  -> array
         *   array  & mapping -> array
         *   mapping & array -> mapping
         *   mapping & mapping -> mapping
         */

        svalue_t *argp;

#ifdef DEBUG
        TYPE_TEST_LEFT(sp, T_LVALUE);
#endif

        /* Set argp to the actual value designated by sp[0] */
        for ( argp = sp->u.lvalue
            ; T_LVALUE == argp->type || T_PROTECTED_LVALUE == argp->type
            ; argp = argp->u.lvalue)
            NOOP;

        /* Now do it */
        if (argp->type == T_NUMBER)  /* Intersect a number */
        {
            if (sp[-1].type != T_NUMBER)
            {
                OP_ARG_ERROR(2, TF_NUMBER, sp[-1].type);
                /* NOTREACHED */
            }
            sp--;
            sp->u.number = argp->u.number &= sp->u.number;
            break;
        }

        if (argp->type == T_CHAR_LVALUE)
        {
            sp--;
            if (sp->type != T_NUMBER)
            {
                OP_ARG_ERROR(2, TF_NUMBER, sp->type);
                /* NOTREACHED */
            }
            sp->u.number = (unsigned char)(*argp->u.charp &= sp->u.number);
            break;
        }

        if (argp->type == T_POINTER)
        {
            /* Intersect an array */

            if (sp[-1].type == T_POINTER)
            {
                vector_t *vec1, *vec2;

                inter_sp = sp - 2;
                vec1 = argp->u.vec;
                vec2 = sp[-1].u.vec;
                argp->type = T_NUMBER;
                vec1 = intersect_array(vec1, vec2);
                put_ref_array(argp, vec1);
                sp--;
                sp->u.vec = argp->u.vec;
                free_svalue(sp+1);
            }
            else if (sp[-1].type == T_MAPPING)
            {
                vector_t *vec;
                mapping_t * map;

                inter_sp = sp - 2;
                vec = argp->u.vec;
                map = sp[-1].u.map;
                argp->type = T_NUMBER;
                vec = map_intersect_array(vec, map);
                put_ref_array(argp, vec);
                sp--;
                put_array(sp, argp->u.vec);
                free_svalue(sp+1);
            }
            else
            {
                OP_ARG_ERROR(2, TF_POINTER|TF_MAPPING, sp[-1].type);
                /* NOTREACHED */
            }
            break;
        }

        if (argp->type == T_MAPPING)
        {
            /* Intersect a mapping */

            mapping_t *result;

            if (sp[-1].type != T_POINTER && sp[-1].type != T_MAPPING)
            {
                OP_ARG_ERROR(2, TF_MAPPING|TF_POINTER, sp[-1].type);
                /* NOTREACHED */
            }

            inter_sp = sp;

            result = map_intersect(argp->u.map, sp-1);

            put_mapping(argp, result);

            free_svalue(sp);
            sp--;

            put_ref_mapping(sp, result);
            break;
        }

        if (argp->type == T_STRING)
        {
            string_t * result;

            if (sp[-1].type != T_STRING)
            {
                OP_ARG_ERROR(2, TF_STRING, sp[-1].type);
                /* NOTREACHED */
            }
            inter_sp = sp;
            result = intersect_strings(argp->u.str, (sp-1)->u.str, MY_FALSE);
            free_string_svalue(argp);
            put_string(argp, result);
            free_svalue(sp);
            sp--;
            free_string_svalue(sp);
            put_ref_string(sp, result);
            break;
        }

        OP_ARG_ERROR(1, TF_NUMBER|TF_STRING|TF_POINTER, argp->type);
        /* NOTREACHED */
        break;
    }

    CASE(F_OR_EQ);                  /* --- or_eq               --- */
    {
        /* Binary-Or the value designated by lvalue sp[0] with sp[-1],
         * assign the result to sp[0] and also leave it on the stack.
         *
         * Possible type combinations:
         *   int   | int   -> int
         *   array | array -> array
         */

        svalue_t *argp;

#ifdef DEBUG
        TYPE_TEST_LEFT(sp, T_LVALUE);
#endif

        /* Set argp to the actual value designated by sp[0] */
        for ( argp = sp->u.lvalue
            ; T_LVALUE == argp->type || T_PROTECTED_LVALUE == argp->type
            ; argp = argp->u.lvalue)
            NOOP;

        /* Now do it */
        if (argp->type == T_NUMBER)
        {
            sp--;
            if (sp->type != T_NUMBER)
            {
                OP_ARG_ERROR(2, TF_NUMBER, sp->type);
                /* NOTREACHED */
            }
            sp->u.number = argp->u.number |= sp->u.number;
            break;
        }

        if (argp->type == T_CHAR_LVALUE)
        {
            sp--;
            if (sp->type != T_NUMBER)
            {
                OP_ARG_ERROR(2, TF_NUMBER, sp->type);
                /* NOTREACHED */
            }
            sp->u.number = (unsigned char)(*argp->u.charp |= sp->u.number);
            break;
        }

        if (argp->type == T_POINTER)
        {
            /* Join an array */

            vector_t *vec1, *vec2;

            if (sp[-1].type != T_POINTER)
            {
                OP_ARG_ERROR(2, TF_POINTER, sp[-1].type);
                /* NOTREACHED */
            }
            inter_sp = sp;
            inter_pc = pc;
            vec1 = argp->u.vec;
            vec2 = sp[-1].u.vec;
            vec1 = join_array(vec1, vec2);
              /* The new vec1 may be one of the original vec1 or vec2 */
            put_ref_array(argp, vec1);
            sp--;
            sp->u.vec = argp->u.vec;
            free_svalue(sp+1);
            break;
        }

        OP_ARG_ERROR(1, TF_NUMBER|TF_POINTER, argp->type);
        /* NOTREACHED */
        break;
    }

    CASE(F_XOR_EQ);                 /* --- xor_eq              --- */
    {
        /* Binary-XOr the value designated by lvalue sp[0] with sp[-1],
         * assign the result to sp[0] and also leave it on the stack.
         *
         * Possible type combinations:
         *   int   ^ int   -> int
         *   array ^ array -> array
         *
         * TODO: Extend this to mappings.
         */

        svalue_t *argp;

#ifdef DEBUG
        TYPE_TEST_LEFT(sp, T_LVALUE);
#endif

        /* Set argp to the actual value designated by sp[0] */
        for ( argp = sp->u.lvalue
            ; T_LVALUE == argp->type || T_PROTECTED_LVALUE == argp->type
            ; argp = argp->u.lvalue)
            NOOP;

        /* Now do it */
        if (argp->type == T_NUMBER)
        {
            sp--;
            if (sp->type != T_NUMBER)
            {
                OP_ARG_ERROR(2, TF_NUMBER, sp->type);
                /* NOTREACHED */
            }
            sp->u.number = argp->u.number ^= sp->u.number;
            break;
        }

        if (argp->type == T_CHAR_LVALUE)
        {
            sp--;
            if (sp->type != T_NUMBER)
            {
                OP_ARG_ERROR(2, TF_NUMBER, sp->type);
                /* NOTREACHED */
            }
            sp->u.number = (unsigned char)(*argp->u.charp ^= sp->u.number);
            break;
        }

        if (argp->type == T_POINTER)
        {
            /* Symm-diff an array */

            vector_t *vec1, *vec2;

            if (sp[-1].type != T_POINTER)
            {
                OP_ARG_ERROR(2, TF_POINTER, sp[-1].type);
                /* NOTREACHED */
            }
            inter_sp = sp - 2;
            vec1 = argp->u.vec;
            vec2 = sp[-1].u.vec;
            argp->type = T_NUMBER;
            vec1 = symmetric_diff_array(vec1, vec2);
            put_ref_array(argp, vec1);
            sp--;
            sp->u.vec = argp->u.vec;
            free_svalue(sp+1);
            break;
        }

        OP_ARG_ERROR(1, TF_NUMBER|TF_POINTER, argp->type);
        /* NOTREACHED */
        break;
    }

    CASE(F_LSH_EQ);                 /* --- lsh_eq              --- */
    {
        /* Shift the value designated by lvalue sp[0] left by sp[-1],
         * assign the result to sp[0] and also leave it on the stack.
         *
         * Possible type combinations:
         *   int        << int                -> int
         *
         * TODO: Implement an arithmetic shift.
         */

        int i;
        svalue_t *argp;

#ifdef DEBUG
        TYPE_TEST_LEFT(sp, T_LVALUE);
#endif

        /* Set argp to the actual value designated by sp[0] */
        for ( argp = sp->u.lvalue
            ; T_LVALUE == argp->type || T_PROTECTED_LVALUE == argp->type
            ; argp = argp->u.lvalue)
            NOOP;

        /* Now do it */
        if (argp->type == T_NUMBER)
        {
            sp--;
            if (sp->type != T_NUMBER)
            {
                OP_ARG_ERROR(2, TF_NUMBER, sp->type);
                /* NOTREACHED */
            }
            i = sp->u.number;
            argp->u.number <<= (uint)i > MAX_SHIFT ? (int)MAX_SHIFT : i;
            sp->u.number = argp->u.number;
            break;
        }

        if (argp->type == T_CHAR_LVALUE)
        {
            sp--;
            if (sp->type != T_NUMBER)
            {
                OP_ARG_ERROR(2, TF_NUMBER, sp->type);
                /* NOTREACHED */
            }
            i = sp->u.number;
            *argp->u.charp <<= (uint)i > MAX_SHIFT ? (int)MAX_SHIFT : i;
            sp->u.number = (unsigned char)(*argp->u.charp);
            break;
        }

        OP_ARG_ERROR(1, TF_NUMBER, argp->type);
        /* NOTREACHED */
        break;
    }

    CASE(F_RSH_EQ);                 /* --- rsh_eq              --- */
    {
        /* Arithmetically shift the value designated by lvalue sp[0] right by
         * sp[-1], assign the result to sp[0] and also leave it on the stack.
         *
         * Possible type combinations:
         *   int        << int                -> int
         */

        int i;
        svalue_t *argp;

#ifdef DEBUG
        TYPE_TEST_LEFT(sp, T_LVALUE);
#endif

        /* Set argp to the actual value designated by sp[0] */
        for ( argp = sp->u.lvalue
            ; T_LVALUE == argp->type || T_PROTECTED_LVALUE == argp->type
            ; argp = argp->u.lvalue)
            NOOP;

        /* Now do it */
        if (argp->type == T_NUMBER)
        {
            sp--;
            if (sp->type != T_NUMBER)
            {
                OP_ARG_ERROR(2, TF_NUMBER, sp->type);
                /* NOTREACHED */
            }
            i = sp->u.number;
            argp->u.number >>= (uint)i > MAX_SHIFT ? (int)(MAX_SHIFT+1) : i;
            sp->u.number = argp->u.number;
            break;
        }

        if (argp->type == T_CHAR_LVALUE)
        {
            sp--;
            if (sp->type != T_NUMBER)
            {
                OP_ARG_ERROR(2, TF_NUMBER, sp->type);
                /* NOTREACHED */
            }
            i = sp->u.number;
            *argp->u.charp >>= (uint)i > MAX_SHIFT ? (int)MAX_SHIFT : i;
            sp->u.number = (unsigned char)(*argp->u.charp);
            break;
        }

        OP_ARG_ERROR(1, TF_NUMBER, argp->type);
        /* NOTREACHED */ break;
    }

    CASE(F_RSHL_EQ);               /* --- rshl_eq              --- */
    {
        /* Logically shift the value designated by lvalue sp[0] right by
         * sp[-1], assign the result to sp[0] and also leave it on the stack.
         *
         * Possible type combinations:
         *   int        << int                -> int
         */

        int i;
        svalue_t *argp;
#ifdef DEBUG
        TYPE_TEST_LEFT(sp, T_LVALUE);
#endif

        /* Set argp to the actual value designated by sp[0] */
        for ( argp = sp->u.lvalue
            ; T_LVALUE == argp->type || T_PROTECTED_LVALUE == argp->type
            ; argp = argp->u.lvalue)
            NOOP;

        /* Now do it */
        if (argp->type == T_NUMBER)
        {
            sp--;
            if (sp->type != T_NUMBER)
            {
                OP_ARG_ERROR(2, TF_NUMBER, sp->type);
                /* NOTREACHED */
            }
            i = sp->u.number;
            if ((uint)i > MAX_SHIFT)
                argp->u.number = 0;
            else
                argp->u.number = (p_uint)argp->u.number >> i;
            sp->u.number = argp->u.number;
            break;
        }

        if (argp->type == T_CHAR_LVALUE)
        {
            sp--;
            if (sp->type != T_NUMBER)
            {
                OP_ARG_ERROR(2, TF_NUMBER, sp->type);
                /* NOTREACHED */
            }
            i = sp->u.number;
            if ((uint)i > MAX_SHIFT)
                *argp->u.charp = 0;
            else
                *argp->u.charp = (p_uint)*argp->u.charp >> i;
            sp->u.number = (unsigned char)*argp->u.charp;
            break;
        }

        OP_ARG_ERROR(1, TF_NUMBER, argp->type);
        /* NOTREACHED */
        break;
    }

    /* --- Machine internal instructions --- */

    CASE(F_POP_VALUE);              /* --- pop_value           --- */
        /* Pop the topmost value from the stack (freeing it).
         * Simple, huh?
         */
        pop_stack();
        break;

    CASE(F_POP_SECOND);             /* --- pop_second          --- */
        /* Pop the value under the topmost value and put the
         * topmost value there.
         */
        free_svalue(--sp);
        *sp = sp[1];
        break;

    CASE(F_DUP);                    /* --- dup                 --- */
        /* Push a duplicate of sp[0] onto the stack.
         */
        sp++;
        assign_svalue_no_free(sp, sp-1);
        break;

    CASE(F_LDUP);                   /* --- ldup                --- */
      {
        /* Push a duplicate of sp[0] onto the stack.
         * If sp[0] is an lvalue, it is derefenced first.
         */
        svalue_t * svp = sp;
        sp++;
        while (svp->type == T_LVALUE || svp->type == T_PROTECTED_LVALUE)
            svp = svp->u.lvalue;
        assign_svalue_no_free(sp, svp);
        break;
      }

    CASE(F_SWAP_VALUES);            /* --- swap_values         --- */
      {
        /* Swap sp[0] and sp[-1] on the stack.
         */
        svalue_t sv = sp[0];
        sp[0] = sp[-1];
        sp[-1] = sv;
        break;
      }

    CASE(F_CLEAR_LOCALS);    /* --- clear_locals <first> <num> --- */
      {
        /* Set the local variables <first> .. <first>+<num>-1 back
         * to svalue-0. This is used to initalize local variables
         * of nested scopes.
         */
        int first, num;
        svalue_t *plocal;

        first = LOAD_UINT8(pc);
        num = LOAD_UINT8(pc);

        for (plocal = fp+first; num > 0; num--, plocal++)
        {
            free_svalue(plocal);
            *plocal = const0;
        }
        break;
      }

    CASE(F_SAVE_ARG_FRAME);         /* --- save_arg_frame      --- */
      {
        /* Save the current value of ap on the stack and set ap to
         * the next stack entry.
         */

        ++sp;
        sp->type = T_INVALID;
        sp->u.lvalue = ap;
        ap = sp+1;
        break;
      }

    CASE(F_RESTORE_ARG_FRAME);      /* --- restore_arg_frame   --- */
      {
        /* While sp points at a function result, restore the value
         * of ap from sp[-1]; then move the result down there.
         */

        ap = sp[-1].u.lvalue;
        sp[-1] = sp[0];
        sp--;
        break;
      }

    CASE(F_USE_ARG_FRAME);          /* --- use_arg_frame       --- */
      {
        /* Used as a prefix (and only as a prefix) to instructions which
         * usually know or take the number of arguments from the bytecode.
         * With this prefix, the instruction uses the difference between
         * sp and ap as the real number of arguments.
         *
         * use_arg_frame is recognized by: simul_efun, efun{0,1,2,3,4,v}.
         */

#ifdef DEBUG
        if (use_ap)
            fatal("Previous use_arg_frame hasn't been consumed.\n");
#endif
        use_ap = MY_TRUE;
        break;
      }

    CASE(F_FLATTEN_XARG);           /* --- flatten_xarg        --- */
      {
        /* Take the value at sp and if it is an array, put
         * the array's contents onto the stack in its place. Other values stay
         * as they are.
         * This code is used in conjunction with save/restore/use_arg_frame
         * to implement flexible varargs.
         */

        if (sp->type == T_POINTER)
        {
            /* The argument is an array: flatten it */

            vector_t *vec;  /* the array */
            svalue_t *svp;  /* pointer into the array */
            p_int i;         /* (remaining) vector size */

            vec = sp->u.vec;
            i = VEC_SIZE(vec);

            /* Check if there is enough space on the stack.
             */
            if (i + (sp - VALUE_STACK) >= EVALUATOR_STACK_SIZE)
            {
                errorf("VM Stack overflow: %"PRIdMPINT" too high.\n"
                     , ((mp_int)i + (sp - VALUE_STACK) - EVALUATOR_STACK_SIZE) );
                /* NOTREACHED */
                break;
            }

            /* Push the array elements onto the stack, overwriting the
             * array value itself.
             */
            if (deref_array(vec))
            {
                for (svp = vec->item; --i >= 0; )
                {
                    if (destructed_object_ref(svp))
                    {
                        put_number(sp, 0);
                        sp++;
                        svp++;
                    }
                    else
                        assign_svalue_no_free(sp++, svp++);
                }
            }
            else
            {
                /* The array will be freed, so use a faster function */
                for (svp = vec->item; --i >= 0; ) {
                    if (destructed_object_ref(svp))
                    {
                        put_number(sp, 0);
                        sp++;
                        svp++;
                    }
                    else
                        transfer_svalue_no_free(sp++, svp++);
                }
                free_empty_vector(vec);
            }

            sp--; /* undo the last extraneous sp++ */
        }
        break;
      }

    CASE(F_FBRANCH);                /* --- fbranch <offset>    --- */
    {
        /* Jump by (32-Bit) long <offset> bytes.
         * The <offset> is counted from its first byte (TODO: Ugh).
         */

        long offset;

        GET_LONG(offset, pc);
        pc += offset;
        break;
    }

    CASE(F_LBRANCH);                /* --- lbranch <offset>    --- */
    {
        /* Jump by (16-Bit) short <offset> bytes.
         * The <offset> is counted from its first byte (TODO: Ugh).
         */

        short offset;

        GET_SHORT(offset, pc);
        pc += offset;
        break;
    }

    CASE(F_LBRANCH_WHEN_ZERO); /* --- lbranch_when_zero <offset> --- */
    {
        /* Jump by (16-Bit) short <offset> bytes if sp[0] is number 0.
         * The <offset> is counted from its first byte (TODO: Ugh).
         * sp[0] is popped from the stack.
         */

        short offset;

        if (sp->type == T_NUMBER && sp->u.number == 0)
        {
            GET_SHORT(offset, pc);
            pc += offset;
            sp--;
            break;
        }
        pc += 2;
        pop_stack();
        break;
    }

    CASE(F_LBRANCH_WHEN_NON_ZERO); /* --- lbranch_when_non_zero <offset> --- */
    {
        /* Jump by (16-Bit) short <offset> bytes if sp[0] is not number 0.
         * The <offset> is counted from its first byte (TODO: Ugh).
         * sp[0] is popped from the stack.
         */

        short offset;

        if (sp->type != T_NUMBER || sp->u.number != 0)
        {
            GET_SHORT(offset, pc);
            pc += offset;
            pop_stack();
            break;
        }
        pc += 2;
        sp--;
        break;
    }

    CASE(F_BRANCH);                 /* --- branch <offset>     --- */
    {
        /* Jump forward by uint8 <offset> bytes.
         * The <offset> is counted from the next instruction.
         */

        pc += GET_UINT8(pc)+1;
        break;
    }

    CASE(F_BRANCH_WHEN_ZERO); /* --- branch_when_zero <offset> --- */
    {
        /* Jump forward by uint8 <offset> bytes if sp[0] is number 0.
         * The <offset> is counted from the next instruction.
         * sp[0] is popped from the stack.
         */

        if (sp->type == T_NUMBER)
        {
            if (sp->u.number == 0)
            {
                sp--;
                pc += GET_UINT8(pc) + 1;
                break;
            }
            sp--;
            pc++;
            break;
        }
        else
        {
            free_svalue(sp);
            sp--;
            pc++;
            break;
        }
    }

    CASE(F_BRANCH_WHEN_NON_ZERO); /* --- branch_when_non_zero <offset> --- */
    {
        /* Jump forward by uint8 <offset> bytes if sp[0] is not number 0.
         * The <offset> is counted from the next instruction.
         * sp[0] is popped from the stack.
         */

        if (sp->type == T_NUMBER)
        {
            if (sp->u.number == 0)
            {
                sp--;
                pc++;
                break;
            }
        }
        else
        {
            free_svalue(sp);
        }
        sp--;
        pc += GET_UINT8(pc) + 1;
        break;
    }

    CASE(F_BBRANCH_WHEN_ZERO);  /* --- bbranch_when_zero <offset> --- */
    {
        /* Jump backward by uint8 <offset> bytes if sp[0] is number 0.
         * The <offset> is counted from its first byte (TODO: Ugh).
         * sp[0] is popped from the stack.
         */

        if (sp->type == T_NUMBER && sp->u.number == 0)
        {
            sp--;
            pc -= GET_UINT8(pc);
            break;
        }
        pc += 1;
        pop_stack();
        break;
    }
    CASE(F_BBRANCH_WHEN_NON_ZERO); /* --- branch_when_non_zero <offset> --- */
    {
        /* Jump backward by uint8 <offset> bytes if sp[0] is not number 0.
         * The <offset> is counted from its first byte (TODO: Ugh).
         * sp[0] is popped from the stack.
         */

        if (sp->type == T_NUMBER)
        {
            if (sp->u.number == 0)
            {
                pc += 1;
                sp--;
                break;
            }
        }
        else
            free_svalue(sp);
        sp--;
        pc -= GET_UINT8(pc);
        break;
    }

    CASE(F_CALL_FUNCTION)         /* --- call_function <index> --- */
    {
        /* Call the function <index> with the arguments on the stack.
         * <index> is a (16-Bit) unsigned short, giving the index within
         * the programs function table. The number of arguments is determined
         * through the ap pointer.
         *
         * Since the function may be redefined through inheritance, the
         * function must be searched in the current_objects program, which
         * might not be the current_program.
         */

        unsigned short func_index;   /* function index within program */
        unsigned short func_offset;
          /* function index within the current object's program.
           * This way local function may be redefined through inheritance.
           */
        funflag_t  flags;     /* the function flags */
        fun_hdr_p  funstart;  /* the actual function (code) */

        /* Make sure that we are not calling from a set_this_object()
         * context.
         */
        if (is_sto_context())
        {
            ERROR("call_function: Can't execute with "
                  "set_this_object() in effect.\n"
                 );
        }

        /* Get the function's index */
        LOAD_SHORT(func_index, pc);
        func_offset = (unsigned short)(func_index + function_index_offset);

        /* Find the function in the function table. As the function may have
         * been redefined by inheritance, we must look in the last table,
         * which is pointed to by current_object.
         */

        if (func_offset >= current_object->prog->num_functions)
        {
            fatal("call_function: "
                  "Illegal function index: offset %hu (index %hu), "
                  "%d functions - current object %s\n"
                 , func_offset, func_index
                 , current_object->prog->num_functions
                 , get_txt(current_object->name)
                 );
        }

        /* NOT current_prog, which can be an inherited object. */
        flags = current_object->prog->functions[func_offset];

        /* If the function was cross-defined, get the real offset */
        if (flags & NAME_CROSS_DEFINED)
        {
            func_offset += CROSSDEF_NAME_OFFSET(flags);
        }

        /* Save all important global stack machine registers */
#ifdef USE_NEW_INLINES
        push_control_stack(sp, pc, fp, inter_context);
#else
        push_control_stack(sp, pc, fp);
#endif /* USE_NEW_INLINES */

        /* Set the current program back to the objects program _after_
         * the control stack push, since here is where we search for
         * the function.
         */
        current_prog = current_object->prog;

        /* Search for the function definition and determine the offsets.
         */
        csp->num_local_variables = sp - ap + 1;
        flags = setup_new_frame1(func_offset, 0, 0);
        funstart = (fun_hdr_p)(current_prog->program + (flags & FUNSTART_MASK));
        csp->funstart = funstart;

        /* Setup the stack, arguments and local vars */
        sp = setup_new_frame2(funstart, sp, MY_FALSE, MY_FALSE);

        /* Finish the setup */

#ifdef DEBUG
        if (!current_object->variables && variable_index_offset)
            fatal("%s Fatal: call function for object %p '%s' w/o variables, "
                  "but offset %d\n"
                 , time_stamp(), current_object, get_txt(current_object->name)
                 , variable_index_offset);
#endif
        current_variables = current_object->variables;
        if (current_variables)
            current_variables += variable_index_offset;
        current_strings = current_prog->strings;
        fp = inter_fp;
        pc = FUNCTION_CODE(funstart);
        csp->extern_call = MY_FALSE;
        break;
    }

                   /* --- call_inherited        <prog> <index> --- */
                   /* --- call_inherited_noargs <prog> <index> --- */
    CASE(F_CALL_INHERITED);
    CASE(F_CALL_INHERITED_NOARGS);
    {
        /* Call the (inherited) function <index> in program <prog> with
         * the arguments on the stack; or for the _noargs code, with no
         * arguments.
         *
         * <index> is a (16-Bit) unsigned short, giving the index within
         * the programs function table.
         * <prog> is a (16-Bit) unsigned short, giving the index within
         * the current programs inherit table.
         *
         * The number of arguments, if needed, is determined through the
         * ap pointer.
         *
         * The _noargs code is used to implement wildcarded
         * super calls, which take no argument, but store their results
         * above the ap. Without this extra bytecode, the normal argument
         * massaging would remove the intermediate results.
         */

        unsigned short prog_index;  /* Index within the inherit table */
        unsigned short func_index;  /* Index within the function table */
        funflag_t flags;            /* the functions flags */
        fun_hdr_p funstart;         /* the actual function (code) */
        inherit_t *inheritp;        /* the inheritance descriptor */

        /* Make sure that we are not calling from a set_this_object()
         * context.
         */
        if (is_sto_context())
        {
            ERROR("call_inherited: Can't execute with "
                  "set_this_object() in effect.\n"
                 );
        }

        /* Get the program and function index, and determine the
         * inheritance descriptor
         */
        LOAD_SHORT(prog_index, pc);
        LOAD_SHORT(func_index, pc);

#ifdef DEBUG
        inheritp = &current_prog->inherit[prog_index];
        if (func_index >= inheritp->prog->num_functions)
        {
            fatal("call_inherited: Illegal function index: "
                  "program %d, func %d, %d functions\n"
                 , prog_index, func_index, inheritp->prog->num_functions);
        }
#endif

        /* Save all important global stack machine registers */
#ifdef USE_NEW_INLINES
        push_control_stack(sp, pc, fp, inter_context);
#else
        push_control_stack(sp, pc, fp);
#endif /* USE_NEW_INLINES */

        inheritp = setup_inherited_call(prog_index);

        /* Search for the function definition and determine the offsets.
         */
        if (instruction != F_CALL_INHERITED_NOARGS)
            csp->num_local_variables = sp - ap + 1;
        else
            csp->num_local_variables = 0;
        flags = setup_new_frame1(
          func_index,
          function_index_offset + inheritp->function_index_offset,
          inheritp->variable_index_offset
        );
        funstart = (fun_hdr_p)(current_prog->program + (flags & FUNSTART_MASK));
        csp->funstart = funstart;

        /* Setup the stack, arguments and local vars */
        sp = setup_new_frame2(funstart, sp, MY_FALSE, MY_FALSE);

        /* Finish the setup */
        fp = inter_fp;
        pc = FUNCTION_CODE(funstart);
        current_variables += variable_index_offset;
        current_strings = current_prog->strings;
        csp->extern_call = MY_FALSE;
        break;
    }

    CASE(F_CALL_CLOSURE); /* --- call_closure --- */
        /* Call the closure on the stack with the arguments on the stack.
         * Just like funcall(), but as an internal call.
         * We leave the closure an the stack for a following F_POP_SECOND
         * to clear it up. This instruction is only used by lambda closures.
         */
    {
        num_arg = sp - ap;

        if (ap->type == T_CLOSURE)
        {
            inter_sp = sp;

            /* No external calls may be done when this object is
             * destructed.
             */
            if (current_object->flags & O_DESTRUCTED)
            {
                sp = _pop_n_elems(num_arg, sp);
                push_number(sp, 0);
                inter_sp = sp;
                warnf("Call from destructed object '%s' ignored.\n"
                     , get_txt(current_object->name));
                return sp;
            }

            /* Call the closure and push the result.
             * Note that the closure might destruct itself.
             */
            inter_pc = pc;

            int_call_lambda(ap, num_arg, MY_FALSE, MY_FALSE);

            pc = inter_pc;
            sp = inter_sp;
            fp = inter_fp;
        }
        else
        {
            /* Not a closure: pop the excess args and return <cl>
             * as result.
             */

            sp = _pop_n_elems(num_arg, sp);
            push_number(sp, 0);
        }

        break;
    }



#ifdef USE_NEW_INLINES
    CASE(F_CONTEXT_IDENTIFIER);  /* --- context_identifier <var_ix> --- */
        /* Push value of context variable <var_ix>.
         * It is possible that it is a variable that points to
         * a destructed object. In that case, it has to be replaced by 0.
         *
         * <var_ix> is a uint8.
         */

        if (inter_context == NULL)
            errorf("(eval_instruction) context_identifier: "
                  "inter_context is NULL\n");
            /* May happen if somebody does a funcall(symbol_function())
             * on the lfun of an context closure.
             */

        sp++;
        assign_checked_svalue_no_free(sp, inter_context+LOAD_UINT8(pc));
        break;

                               /* --- context_identifier16 <var_ix> --- */
    CASE(F_CONTEXT_IDENTIFIER16);
      {
        /* Push value of context variable <var_ix>.
         * It is possible that it is a variable that points to
         * a destructed object. In that case, it has to be replaced by 0.
         *
         * <var_ix> is a (16-Bit) unsigned short.
         */
        unsigned short var_index;


        if (inter_context == NULL)
            errorf("(eval_instruction) context_identifier16: "
                  "inter_context is NULL\n");
            /* May happen if somebody does a funcall(symbol_function())
             * on the lfun of an context closure.
             */

        LOAD_SHORT(var_index, pc);
        sp++;
        assign_checked_svalue_no_free(sp, inter_context+var_index);
        break;
     }

    CASE(F_PUSH_CONTEXT_LVALUE);   /* --- push_context_lvalue <num> --- */
        /* Push an lvalue onto the stack pointing to context variable <num>.
         *
         * <num> is an uint8.
         */

        if (inter_context == NULL)
            errorf("(eval_instruction) context_identifier: "
                  "inter_context is NULL\n");
            /* May happen if somebody does a funcall(symbol_function())
             * on the lfun of an context closure.
             */

        sp++;
        sp->type = T_LVALUE;
        sp->u.lvalue = inter_context + LOAD_UINT8(pc);
        break;

                                 /* --- push_context16_lvalue <num> --- */
    CASE(F_PUSH_CONTEXT16_LVALUE);
      {
        /* Push an lvalue onto the stack pointing to context variable <num>.
         *
         * <num> is an (16-Bit) unsigned short.
         */
        unsigned short var_index;


        if (inter_context == NULL)
            errorf("(eval_instruction) context_identifier: "
                  "inter_context is NULL\n");
            /* May happen if somebody does a funcall(symbol_function())
             * on the lfun of an context closure.
             */

        LOAD_SHORT(var_index, pc);
        sp++;
        sp->type = T_LVALUE;
        sp->u.lvalue = inter_context + var_index;
        break;
      }

#endif /* USE_NEW_INLINES */

    CASE(F_PUSH_IDENTIFIER_LVALUE);  /* --- push_identifier_lvalue <num> --- */
        /* Push an lvalue onto the stack pointing to object-global variable
         * <num>.
         *
         * <num> is an uint8 and used as index in the current objects
         * variable table.
         */
        sp++;
        sp->type = T_LVALUE;
        sp->u.lvalue = find_value((int)(LOAD_UINT8(pc) ));
        break;

    CASE(F_VIRTUAL_VARIABLE);         /* --- virtual_variable <num> --- */
        /* Push the virtual object-global variable <num> onto the stack.
         * It is possible that it is a variable that points to
         * a destructed object. In that case, it has to be replaced by 0.
         *
         * <num> is an uint8 and used as index in the current objects
         * variable table.
         */
        sp++;
        assign_checked_svalue_no_free(sp
                                     , find_virtual_value((int)(LOAD_UINT8(pc)))
        );
        break;

                          /* --- push_virtual_variable_lvalue <num> --- */
    CASE(F_PUSH_VIRTUAL_VARIABLE_LVALUE);
        /* Push an lvalue onto the stack pointing to virtual object-global
         * variable <num>.
         *
         * <num> is an uint8 and used as index in the current objects
         * variable table.
         */
        sp++;
        sp->type = T_LVALUE;
        sp->u.lvalue = find_virtual_value((int)(LOAD_UINT8(pc) ));
        break;

    CASE(F_IDENTIFIER16);         /* --- identifier16 <var_ix> --- */
    {
        /* Push value of object variable <var_ix>.
         * It is possible that it is a variable that points to
         * a destructed object. In that case, it has to be replaced by 0.
         *
         * <var_ix> is a (16-Bit) unsigned short.
         */
        unsigned short var_index;

        LOAD_SHORT(var_index, pc);
        sp++;
        assign_checked_svalue_no_free(sp, find_value((int)var_index));
        break;
    }

                       /* --- push_identifier16_lvalue <var_ix> --- */
    CASE(F_PUSH_IDENTIFIER16_LVALUE);
    {
        /* Push an lvalue onto the stack pointing to object-global variable
         * <num>.
         *
         * <num> is an uint8 and used as index in the current objects
         * variable table.
         */
        unsigned short var_index;

        LOAD_SHORT(var_index, pc);
        sp++;
        sp->type = T_LVALUE;
        sp->u.lvalue = find_value((int)var_index);
        break;
    }
                         /* --- push_local_variable_lvalue <num> --- */
    CASE(F_PUSH_LOCAL_VARIABLE_LVALUE);
        /* Push an lvalue onto the stack pointing to local variable <num>.
         *
         * <num> is an uint8 and used as index onto the framepointer.
         */
        sp++;
        sp->type = T_LVALUE;
        sp->u.lvalue = fp + LOAD_UINT8(pc);
        break;

#ifdef USE_STRUCTS
    CASE(F_PUSH_INDEXED_S_LVALUE); /* --- push_indexed_s_lvalue --- */
        /* Op. (struct v=sp[-2], mixed i=sp[-1], short idx=sp[0])
         *
         * Compute the lvalue &(v[i]) and push it into the stack. If v has
         * just one ref left, the indexed item is stored in indexing_quickfix
         * and the lvalue refers to that variable.
         *
         * <idx> gives the index of the expected struct type - the
         * operator accepts a struct of this type, or any of its children.
         * An negative <idx> accepts any struct.
         */

        sp = check_struct_op(sp, 0, -2, pc);
        sp = push_indexed_lvalue(sp, pc);
        break;
#endif /* USE_STRUCTS */

    CASE(F_PUSH_INDEXED_LVALUE);    /* --- push_indexed_lvalue --- */
        /* Operator F_PUSH_INDEXED_LVALUE(vector  v=sp[-1], int   i=sp[0])
         * Operator F_PUSH_INDEXED_LVALUE(mapping v=sp[-1], mixed i=sp[0])
         *
         * Compute the lvalue &(v[i]) and push it into the stack. If v has
         * just one ref left, the indexed item is stored in indexing_quickfix
         * and the lvalue refers to that variable.
         */

#ifdef USE_STRUCTS
        {
            svalue_t * svp = sp-1;

            while (svp->type == T_LVALUE || svp->type == T_PROTECTED_LVALUE)
                svp = svp->u.lvalue;
            if (svp->type == T_STRUCT)
            {
                ERRORF(("Illegal type to []: %s lvalue, "
                        "expected string/mapping/vector lvalue.\n"
                       , typename(svp->type)
                      ));
                /* NOTREACHED */
            }
        }
#endif /* USE_STRUCTS */
        sp = push_indexed_lvalue(sp, pc);
        break;

    CASE(F_PUSH_RINDEXED_LVALUE);   /* --- push_rindexed_lvalue --- */
        /* Operator F_PUSH_RINDEXED_LVALUE(vector v=sp[-1], int i=sp[0])
         *
         * Compute the lvalue &(v[<i]) and push it into the stack. If v has
         * just one ref left, the indexed item is stored in indexing_quickfix
         * and the lvalue refers to that variable.
         */

        sp = push_rindexed_lvalue(sp, pc);
        break;

    CASE(F_PUSH_AINDEXED_LVALUE);   /* --- push_aindexed_lvalue --- */
        /* Operator F_PUSH_AINDEXED_LVALUE(vector v=sp[-1], int i=sp[0])
         *
         * Compute the lvalue &(v[>i]) and push it into the stack. If v has
         * just one ref left, the indexed item is stored in indexing_quickfix
         * and the lvalue refers to that variable.
         */

        sp = push_aindexed_lvalue(sp, pc);
        break;

#ifdef USE_STRUCTS
    CASE(F_INDEX_S_LVALUE);         /* --- index_s_lvalue     --- */
        /* Op. (struct &v=sp[0], int i=sp[-2], short * idx=sp[-1])
         *
         * Compute the index &(v[i]) of lvalue <v> and push it into the stack.
         * The computed index is a lvalue itself.
         *
         * <idx> gives the index of the expected struct type - the
         * operator accepts a struct of this type, or any of its children.
         * An negative <idx> accepts any struct.
         */

        sp = check_struct_op(sp, -1, 1, pc);
        sp = index_lvalue(sp, pc);
        break;
#endif /* USE_STRUCTS */

    CASE(F_INDEX_LVALUE);           /* --- index_lvalue       --- */
        /* Operator F_INDEX_LVALUE (string|vector &v=sp[0], int   i=sp[-1])
         *          F_INDEX_LVALUE (mapping       &v=sp[0], mixed i=sp[-1])
         *
         * Compute the index &(v[i]) of lvalue <v> and push it into the stack.
         * The computed index is a lvalue itself.  If <v> is a string-lvalue,
         * it is made a malloced string if necessary, and the pushed result
         * will be a lvalue pointing to a CHAR_LVALUE stored in
         * <special_lvalue>.
         */

#ifdef USE_STRUCTS
        {
            svalue_t * svp = sp;

            while (svp->type == T_LVALUE || svp->type == T_PROTECTED_LVALUE)
                svp = svp->u.lvalue;
            if (svp->type == T_STRUCT)
            {
                ERRORF(("Illegal type to []: %s lvalue, "
                        "expected string/mapping/vector lvalue.\n"
                       , typename(svp->type)
                      ));
                /* NOTREACHED */
            }
        }
#endif /* USE_STRUCTS */
        sp = index_lvalue(sp, pc);
        break;

    CASE(F_RINDEX_LVALUE);          /* --- rindex_lvalue      --- */
        /* Operator F_RINDEX_LVALUE (string|vector &v=sp[0], int   i=sp[-1])
         *
         * Compute the index &(v[<i]) of lvalue <v> and push it into the
         * stack. The computed index is a lvalue itself.
         * If <v> is a string-lvalue, it is made a malloced string if
         * necessary, and the pushed result will be a lvalue pointing to a
         * CHAR_LVALUE stored in <special_lvalue>.
         */

        sp = rindex_lvalue(sp, pc);
        break;

    CASE(F_AINDEX_LVALUE);          /* --- aindex_lvalue      --- */
        /* Operator F_AINDEX_LVALUE (string|vector &v=sp[0], int   i=sp[-1])
         *
         * Compute the index &(v[>i]) of lvalue <v> and push it into the
         * stack. The computed index is a lvalue itself.
         * If <v> is a string-lvalue, it is made a malloced string if
         * necessary, and the pushed result will be a lvalue pointing to a
         * CHAR_LVALUE stored in <special_lvalue>.
         */

        sp = aindex_lvalue(sp, pc);
        break;

#ifdef USE_STRUCTS
    CASE(F_S_INDEX);                /* --- s_index            --- */
        /* Operator F_S_INDEX (struct v=sp[-2], mixed i=sp[-1], short idx=sp[0])
         *
         * Compute the value (v->i) and push it onto the stack.  If the value
         * would be a destructed object, 0 is pushed onto the stack and the
         * ref to the object is removed from the struct.
         *
         * <idx> gives the index of the expected struct type - the
         * operator accepts a struct of this type, or any of its children.
         * An negative <idx> accepts any struct.
         */

        sp = check_struct_op(sp, 0, -2, pc);
        sp = push_indexed_value(sp, pc);
        break;
#endif /* USE_STRUCTS */

    CASE(F_INDEX);                  /* --- index              --- */
        /* Operator F_INDEX (string|vector v=sp[-1], int   i=sp[0])
         *          F_INDEX (mapping       v=sp[-1], mixed i=sp[0])
         *
         * Compute the value (v[i]) and push it onto the stack.  If the value
         * would be a destructed object, 0 is pushed onto the stack and the
         * ref to the object is removed from the vector/mapping.
         *
         * Mapping indices may use <indexing_quickfix> for temporary storage.
         */

#ifdef USE_STRUCTS
        if ((sp-1)->type == T_STRUCT)
        {
            ERRORF(("Illegal type to []: %s, expected string/vector/mapping.\n"
                   , typename((sp-1)->type)
                  ));
            /* NOTREACHED */
        }
#endif /* USE_STRUCTS */
        sp = push_indexed_value(sp, pc);
        break;

    CASE(F_RINDEX);                 /* --- rindex              --- */
        /* Operator F_RINDEX (string|vector v=sp[0], int   i=sp[-1])
         *
         * Compute the value (v[<i]) and push it onto the stack.  If the value
         * would be a destructed object, 0 is pushed onto the stack and the
         * ref to the object is removed from the vector/mapping.
         */

        sp = push_rindexed_value(sp, pc);
        break;

    CASE(F_AINDEX);                 /* --- aindex              --- */
        /* Operator F_AINDEX (string|vector v=sp[0], int   i=sp[-1])
         *
         * Compute the value (v[<i]) and push it onto the stack.  If the value
         * would be a destructed object, 0 is pushed onto the stack and the
         * ref to the object is removed from the vector/mapping.
         */

        sp = push_aindexed_value(sp, pc);
        break;

    CASE(F_RANGE_LVALUE);           /* --- range_lvalue        --- */
        /* Operator F_RANGE_LVALUE (string|vector &v=sp[0]
         *                         , int i2=sp[-1], i1=sp[-2])
         *
         * Compute the range &(v[i1..i2]) of lvalue <v> and push it into the
         * stack.  The value pushed is a lvalue pointing to <special_lvalue>.
         * <special_lvalue> then is the POINTER_RANGE_- resp.
         * STRING_RANGE_LVALUE.
         *
         * TODO: Four different instructions for this? A single instruction plus
         * TODO:: argument would be as well.
         */

        inter_pc = pc;
        sp = range_lvalue(NN_RANGE, sp);
        break;

    CASE(F_NR_RANGE_LVALUE);           /* --- nr_range_lvalue     --- */
        /* Operator F_NR_RANGE_LVALUE (string|vector &v=sp[0]
         *                         , int i2=sp[-1], i1=sp[-2])
         *
         * Compute the range &(v[i1..<i2]) of lvalue <v> and push it into the
         * stack.  The value pushed is a lvalue pointing to <special_lvalue>.
         * <special_lvalue> then is the POINTER_RANGE_- resp.
         * STRING_RANGE_LVALUE.
         */

        inter_pc = pc;
        sp = range_lvalue(NR_RANGE, sp);
        break;

    CASE(F_RN_RANGE_LVALUE);           /* --- rn_range_lvalue     --- */
        /* Operator F_RN_RANGE_LVALUE (string|vector &v=sp[0]
         *                         , int i2=sp[-1], i1=sp[-2])
         *
         * Compute the range &(v[<i1..i2]) of lvalue <v> and push it into the
         * stack.  The value pushed is a lvalue pointing to <special_lvalue>.
         * <special_lvalue> then is the POINTER_RANGE_- resp.
         * STRING_RANGE_LVALUE.
         */

        inter_pc = pc;
        sp = range_lvalue(RN_RANGE, sp);
        break;

    CASE(F_RR_RANGE_LVALUE);           /* --- rr_range_lvalue     --- */
        /* Operator F_RR_RANGE_LVALUE (string|vector &v=sp[0]
         *                         , int i2=sp[-1], i1=sp[-2])
         *
         * Compute the range &(v[<i1..<i2]) of lvalue <v> and push it into the
         * stack.  The value pushed is a lvalue pointing to <special_lvalue>.
         * <special_lvalue> then is the POINTER_RANGE_- resp.
         * STRING_RANGE_LVALUE.
         */

        inter_pc = pc;
        sp = range_lvalue(RR_RANGE, sp);
        break;

    CASE(F_NA_RANGE_LVALUE);           /* --- na_range_lvalue     --- */
        /* Operator F_NA_RANGE_LVALUE (string|vector &v=sp[0]
         *                         , int i2=sp[-1], i1=sp[-2])
         *
         * Compute the range &(v[i1..>i2]) of lvalue <v> and push it into the
         * stack.  The value pushed is a lvalue pointing to <special_lvalue>.
         * <special_lvalue> then is the POINTER_RANGE_- resp.
         * STRING_RANGE_LVALUE.
         */

        inter_pc = pc;
        sp = range_lvalue(NA_RANGE, sp);
        break;

    CASE(F_AN_RANGE_LVALUE);           /* --- an_range_lvalue     --- */
        /* Operator F_AN_RANGE_LVALUE (string|vector &v=sp[0]
         *                         , int i2=sp[-1], i1=sp[-2])
         *
         * Compute the range &(v[>i1..i2]) of lvalue <v> and push it into the
         * stack.  The value pushed is a lvalue pointing to <special_lvalue>.
         * <special_lvalue> then is the POINTER_RANGE_- resp.
         * STRING_RANGE_LVALUE.
         */

        inter_pc = pc;
        sp = range_lvalue(AN_RANGE, sp);
        break;

    CASE(F_RA_RANGE_LVALUE);           /* --- ra_range_lvalue     --- */
        /* Operator F_RA_RANGE_LVALUE (string|vector &v=sp[0]
         *                         , int i2=sp[-1], i1=sp[-2])
         *
         * Compute the range &(v[<i1..>i2]) of lvalue <v> and push it into the
         * stack.  The value pushed is a lvalue pointing to <special_lvalue>.
         * <special_lvalue> then is the POINTER_RANGE_- resp.
         * STRING_RANGE_LVALUE.
         */

        inter_pc = pc;
        sp = range_lvalue(RA_RANGE, sp);
        break;

    CASE(F_AR_RANGE_LVALUE);           /* --- ar_range_lvalue     --- */
        /* Operator F_AR_RANGE_LVALUE (string|vector &v=sp[0]
         *                         , int i2=sp[-1], i1=sp[-2])
         *
         * Compute the range &(v[>i1..<i2]) of lvalue <v> and push it into the
         * stack.  The value pushed is a lvalue pointing to <special_lvalue>.
         * <special_lvalue> then is the POINTER_RANGE_- resp.
         * STRING_RANGE_LVALUE.
         */

        inter_pc = pc;
        sp = range_lvalue(AR_RANGE, sp);
        break;

    CASE(F_AA_RANGE_LVALUE);           /* --- aa_range_lvalue     --- */
        /* Operator F_AA_RANGE_LVALUE (string|vector &v=sp[0]
         *                         , int i2=sp[-1], i1=sp[-2])
         *
         * Compute the range &(v[>i1..>i2]) of lvalue <v> and push it into the
         * stack.  The value pushed is a lvalue pointing to <special_lvalue>.
         * <special_lvalue> then is the POINTER_RANGE_- resp.
         * STRING_RANGE_LVALUE.
         */

        inter_pc = pc;
        sp = range_lvalue(AA_RANGE, sp);
        break;

    CASE(F_NX_RANGE_LVALUE);           /* --- nx_range_lvalue     --- */
        /* Operator F_NX_RANGE_LVALUE (string|vector &v=sp[0]
         *                            , int i1=sp[-1])
         *
         * Compute the range &(v[i1..]) of lvalue <v> and push it into the
         * stack.  The value pushed is a lvalue pointing to <special_lvalue>.
         * <special_lvalue> then is the POINTER_RANGE_- resp.
         * STRING_RANGE_LVALUE.
         *
         * We implement this by pushing '1' onto the stack and then
         * call F_NR_RANGE_LVALUE, effectively computing &(v[i1..<1]).
         */

        inter_pc = pc;
        sp++;
        sp[0] = sp[-1];       /* Pull up the 'v' */
        put_number(sp-1, 1);  /* 'Push' the 1 for the upper bound */
        sp = range_lvalue(NR_RANGE, sp);
        break;

    CASE(F_RX_RANGE_LVALUE);           /* --- rx_range_lvalue     --- */
        /* Operator F_RX_RANGE_LVALUE (string|vector &v=sp[0]
         *                            , int i1=sp[-1])
         *
         * Compute the range &(v[<i1..]) of lvalue <v> and push it into the
         * stack.  The value pushed is a lvalue pointing to <special_lvalue>.
         * <special_lvalue> then is the POINTER_RANGE_- resp.
         * STRING_RANGE_LVALUE.
         *
         * We implement this by pushing '1' onto the stack and then
         * call F_RR_RANGE_LVALUE, effectively computing &(v[<i1..<1]).
         */

        inter_pc = pc;
        sp++;
        sp[0] = sp[-1];       /* Pull up the 'v' */
        put_number(sp-1, 1);  /* 'Push' the 1 for the upper bound */
        sp = range_lvalue(RR_RANGE, sp);
        break;

    CASE(F_AX_RANGE_LVALUE);           /* --- ax_range_lvalue     --- */
        /* Operator F_AX_RANGE_LVALUE (string|vector &v=sp[0]
         *                            , int i1=sp[-1])
         *
         * Compute the range &(v[>i1..]) of lvalue <v> and push it into the
         * stack.  The value pushed is a lvalue pointing to <special_lvalue>.
         * <special_lvalue> then is the POINTER_RANGE_- resp.
         * STRING_RANGE_LVALUE.
         *
         * We implement this by pushing '1' onto the stack and then
         * call F_AR_RANGE_LVALUE, effectively computing &(v[>i1..<1]).
         */

        inter_pc = pc;
        sp++;
        sp[0] = sp[-1];       /* Pull up the 'v' */
        put_number(sp-1, 1);  /* 'Push' the 1 for the upper bound */
        sp = range_lvalue(AR_RANGE, sp);
        break;

#ifdef USE_STRUCTS
                        /* --- push_protected_indexed_s_lvalue --- */
    CASE(F_PUSH_PROTECTED_INDEXED_S_LVALUE);
        /* Op. (struct  v=sp[-2], mixed i=sp[-1], short idx=sp[0])
         *
         * Compute the lvalue &(v[i]), store it in a struct
         * protected_lvalue, and push the protector as PROTECTED_LVALUE
         * into the stack.
         *
         * short <idx> gives the index of the expected struct type - the
         * operator accepts a struct of this type, or any of its children.
         * An negative <idx> accepts any struct.
         */

        sp = check_struct_op(sp, 0, 3, pc);
        sp = push_protected_indexed_lvalue(sp, pc);
        break;
#endif /* USE_STRUCTS */

                          /* --- push_protected_indexed_lvalue --- */
    CASE(F_PUSH_PROTECTED_INDEXED_LVALUE);
        /* Op. (vector  v=sp[-1], int   i=sp[0])
         * Op. (mapping v=sp[-1], mixed i=sp[0])
         *
         * Compute the lvalue &(v[i]), store it in a struct
         * protected_lvalue, and push the protector as PROTECTED_LVALUE
         * into the stack.
         */

#ifdef USE_STRUCTS
        if ((sp-1)->type == T_STRUCT)
        {
            ERRORF(("Illegal type to []: %s, expected vector/mapping.\n"
                   , typename((sp-1)->type)
                  ));
            /* NOTREACHED */
        }
#endif /* USE_STRUCTS */
        sp = push_protected_indexed_lvalue(sp, pc);
        break;

                         /* --- push_protected_rindexed_lvalue --- */
    CASE(F_PUSH_PROTECTED_RINDEXED_LVALUE);
        /* Op. (vector v=sp[-1], int i=sp[0])
         *
         * Compute the lvalue &(v[<i]), store it in a struct
         * protected_lvalue, and push the protector as PROTECTED_LVALUE
         * into the stack.
         */

        sp = push_protected_rindexed_lvalue(sp, pc);
        break;

                         /* --- push_protected_aindexed_lvalue --- */
    CASE(F_PUSH_PROTECTED_AINDEXED_LVALUE);
        /* Op. (vector v=sp[-1], int i=sp[0])
         *
         * Compute the lvalue &(v[>i]), store it in a struct
         * protected_lvalue, and push the protector as PROTECTED_LVALUE
         * into the stack.
         */

        sp = push_protected_aindexed_lvalue(sp, pc);
        break;

                      /* --- push_protected_indexed_map_lvalue --- */
    CASE(F_PUSH_PROTECTED_INDEXED_MAP_LVALUE);
        /* Op. (mapping m=sp[-2], mixed i=sp[-1], int   j=sp[0])
         *
         * Compute the lvalue &(m[i:j]), store it in a struct
         * protected_lvalue, and push the protector as PROTECTED_LVALUE
         * into the stack.
         */

        push_protected_indexed_map_lvalue(sp, pc);
        break;

#ifdef USE_STRUCTS
                               /* --- protected_index_s_lvalue --- */
    CASE(F_PROTECTED_INDEX_S_LVALUE);
        /* Operator (struct &v=sp[0], mixed i=sp[-2], short idx=sp[-1])
         *
         * Compute the index &(*v[i]) of lvalue <v>, wrap it into a
         * protector, and push the reference to the protector as
         * PROTECTED_LVALUE onto the stack.
         *
         * short <idx> gives the index of the expected struct type - the
         * operator accepts a struct of this type, or any of its children.
         * An negative <idx> accepts any struct.
         */

        sp = check_struct_op(sp, -1, 1, pc);
        sp = protected_index_lvalue(sp, pc);
        break;
#endif /* USE_STRUCTS */

                                 /* --- protected_index_lvalue --- */
    CASE(F_PROTECTED_INDEX_LVALUE);
        /* Operator (string|vector &v=sp[0], int   i=sp[-1])
         *          (mapping       &v=sp[0], mixed i=sp[-1])
         *
         * Compute the index &(*v[i]) of lvalue <v>, wrap it into a
         * protector, and push the reference to the protector as
         * PROTECTED_LVALUE onto the stack.
         *
         * If <v> is a protected non-string-lvalue, the protected_lvalue
         * referenced by <v>.u.lvalue will be deallocated, and the
         * protector itself will be stored in <last_indexing_protector>
         * for the time being.
         *
         * If <v> is a string-lvalue, it is made a malloced string if
         * necessary.
         */

#ifdef USE_STRUCTS
        if ((sp-1)->type == T_STRUCT)
        {
            ERRORF(("Illegal type to []: %s, expected string/vector/mapping.\n"
                   , typename((sp-1)->type)
                  ));
            /* NOTREACHED */
        }
#endif /* USE_STRUCTS */
        sp = protected_index_lvalue(sp, pc);
        break;

                                /* --- protected_rindex_lvalue --- */
    CASE(F_PROTECTED_RINDEX_LVALUE);
        /* Operator (string|vector &v=sp[0], int   i=sp[-1])
         *
         * Compute the index &(*v[<i]) of lvalue <v>, wrap it into a
         * protector, and push the reference to the protector as
         * PROTECTED_LVALUE onto the stack.
         *
         * If <v> is a protected non-string-lvalue, the protected_lvalue
         * referenced by <v>.u.lvalue will be deallocated, and the
         * protector itself will be stored in <last_indexing_protector>
         * for the time being.
         *
         * If <v> is a string-lvalue, it is made a malloced string if
         * necessary.
         */

        sp = protected_rindex_lvalue(sp, pc);
        break;

                                /* --- protected_aindex_lvalue --- */
    CASE(F_PROTECTED_AINDEX_LVALUE);
        /* Operator (string|vector &v=sp[0], int   i=sp[-1])
         *
         * Compute the index &(*v[>i]) of lvalue <v>, wrap it into a
         * protector, and push the reference to the protector as
         * PROTECTED_LVALUE onto the stack.
         *
         * If <v> is a protected non-string-lvalue, the protected_lvalue
         * referenced by <v>.u.lvalue will be deallocated, and the
         * protector itself will be stored in <last_indexing_protector>
         * for the time being.
         *
         * If <v> is a string-lvalue, it is made a malloced string if
         * necessary.
         */

        sp = protected_aindex_lvalue(sp, pc);
        break;

                              /* --- protected_range_lvalue --- */
    CASE(F_PROTECTED_RANGE_LVALUE);
        /* Operator (string|vector &v=sp[0], int i2=sp[-1], i1=sp[-2])
         *
         * Compute the range &(v[i1..i2]) of lvalue <v>, wrap it into a
         * protector, and push the reference to the protector onto the
         * stack.
         *
         * If <v> is a protected lvalue itself, its protecting svalue will
         * be used in the result protector.
         *
         * If <v> is a string-lvalue, it is made a malloced string if
         * necessary.
         */

        inter_pc = pc;
        sp = protected_range_lvalue(NN_RANGE, sp);
        break;

                           /* --- protected_nr_range_lvalue --- */
    CASE(F_PROTECTED_NR_RANGE_LVALUE);
        /* Operator (string|vector &v=sp[0], int i2=sp[-1], i1=sp[-2])
         *
         * Compute the range &(v[i1..<i2]) of lvalue <v>, wrap it into a
         * protector, and push the reference to the protector onto the
         * stack.
         *
         * If <v> is a protected lvalue itself, its protecting svalue will
         * be used in the result protector.
         *
         * If <v> is a string-lvalue, it is made a malloced string if
         * necessary.
         */

        inter_pc = pc;
        sp = protected_range_lvalue(NR_RANGE, sp);
        break;

                             /* --- protected_rn_range_lvalue --- */
    CASE(F_PROTECTED_RN_RANGE_LVALUE);
        /* Operator (string|vector &v=sp[0], int i2=sp[-1], i1=sp[-2])
         *
         * Compute the range &(v[<i1..i2]) of lvalue <v>, wrap it into a
         * protector, and push the reference to the protector onto the
         * stack.
         *
         * If <v> is a protected lvalue itself, its protecting svalue will
         * be used in the result protector.
         *
         * If <v> is a string-lvalue, it is made a malloced string if
         * necessary.
         */

        inter_pc = pc;
        sp = protected_range_lvalue(RN_RANGE, sp);
        break;

                             /* --- protected_rr_range_lvalue --- */
    CASE(F_PROTECTED_RR_RANGE_LVALUE);
        /* Operator (string|vector &v=sp[0], int i2=sp[-1], i1=sp[-2])
         *
         * Compute the range &(v[<i1..<i2]) of lvalue <v>, wrap it into a
         * protector, and push the reference to the protector onto the
         * stack.
         *
         * If <v> is a protected lvalue itself, its protecting svalue will
         * be used in the result protector.
         *
         * If <v> is a string-lvalue, it is made a malloced string if
         * necessary.
         */

        inter_pc = pc;
        sp = protected_range_lvalue(RR_RANGE, sp);
        break;

                           /* --- protected_na_range_lvalue --- */
    CASE(F_PROTECTED_NA_RANGE_LVALUE);
        /* Operator (string|vector &v=sp[0], int i2=sp[-1], i1=sp[-2])
         *
         * Compute the range &(v[i1..>i2]) of lvalue <v>, wrap it into a
         * protector, and push the reference to the protector onto the
         * stack.
         *
         * If <v> is a protected lvalue itself, its protecting svalue will
         * be used in the result protector.
         *
         * If <v> is a string-lvalue, it is made a malloced string if
         * necessary.
         */

        inter_pc = pc;
        sp = protected_range_lvalue(NA_RANGE, sp);
        break;

                             /* --- protected_an_range_lvalue --- */
    CASE(F_PROTECTED_AN_RANGE_LVALUE);
        /* Operator (string|vector &v=sp[0], int i2=sp[-1], i1=sp[-2])
         *
         * Compute the range &(v[>i1..i2]) of lvalue <v>, wrap it into a
         * protector, and push the reference to the protector onto the
         * stack.
         *
         * If <v> is a protected lvalue itself, its protecting svalue will
         * be used in the result protector.
         *
         * If <v> is a string-lvalue, it is made a malloced string if
         * necessary.
         */

        inter_pc = pc;
        sp = protected_range_lvalue(AN_RANGE, sp);
        break;

                           /* --- protected_ra_range_lvalue --- */
    CASE(F_PROTECTED_RA_RANGE_LVALUE);
        /* Operator (string|vector &v=sp[0], int i2=sp[-1], i1=sp[-2])
         *
         * Compute the range &(v[<i1..>i2]) of lvalue <v>, wrap it into a
         * protector, and push the reference to the protector onto the
         * stack.
         *
         * If <v> is a protected lvalue itself, its protecting svalue will
         * be used in the result protector.
         *
         * If <v> is a string-lvalue, it is made a malloced string if
         * necessary.
         */

        inter_pc = pc;
        sp = protected_range_lvalue(RA_RANGE, sp);
        break;

                             /* --- protected_ar_range_lvalue --- */
    CASE(F_PROTECTED_AR_RANGE_LVALUE);
        /* Operator (string|vector &v=sp[0], int i2=sp[-1], i1=sp[-2])
         *
         * Compute the range &(v[>i1..<i2]) of lvalue <v>, wrap it into a
         * protector, and push the reference to the protector onto the
         * stack.
         *
         * If <v> is a protected lvalue itself, its protecting svalue will
         * be used in the result protector.
         *
         * If <v> is a string-lvalue, it is made a malloced string if
         * necessary.
         */

        inter_pc = pc;
        sp = protected_range_lvalue(AR_RANGE, sp);
        break;

                             /* --- protected_aa_range_lvalue --- */
    CASE(F_PROTECTED_AA_RANGE_LVALUE);
        /* Operator (string|vector &v=sp[0], int i2=sp[-1], i1=sp[-2])
         *
         * Compute the range &(v[>i1..>i2]) of lvalue <v>, wrap it into a
         * protector, and push the reference to the protector onto the
         * stack.
         *
         * If <v> is a protected lvalue itself, its protecting svalue will
         * be used in the result protector.
         *
         * If <v> is a string-lvalue, it is made a malloced string if
         * necessary.
         */

        inter_pc = pc;
        sp = protected_range_lvalue(AA_RANGE, sp);
        break;

                              /* --- protected_nx_range_lvalue --- */
    CASE(F_PROTECTED_NX_RANGE_LVALUE);
        /* Operator (string|vector &v=sp[0], i1=sp[-1])
         *
         * Compute the range &(v[i1..]) of lvalue <v>, wrap it into a
         * protector, and push the reference to the protector onto the
         * stack.
         *
         * If <v> is a protected lvalue itself, its protecting svalue will
         * be used in the result protector.
         *
         * If <v> is a string-lvalue, it is made a malloced string if
         * necessary.
         *
         * We implement it by pushing '1' onto the stack and then
         * calling protected_nr_range_lvalue, effectively computing
         * &(v[i1..<1]).
         */

        inter_pc = pc;
        sp++;
        sp[0] = sp[-1];       /* Pull up the 'v' */
        put_number(sp-1, 1);  /* 'Push' the 1 for the upper bound */
        sp = protected_range_lvalue(NR_RANGE, sp);
        break;

                          /* --- protected_rx_range_lvalue --- */
    CASE(F_PROTECTED_RX_RANGE_LVALUE);
        /* Operator (string|vector &v=sp[0], int i1=sp[-1])
         *
         * Compute the range &(v[<i1..]) of lvalue <v>, wrap it into a
         * protector, and push the reference to the protector onto the
         * stack.
         *
         * If <v> is a protected lvalue itself, its protecting svalue will
         * be used in the result protector.
         *
         * If <v> is a string-lvalue, it is made a malloced string if
         * necessary.
         *
         * We implement it by pushing '1' onto the stack and then
         * calling protected_nr_range_lvalue, effectively computing
         * &(v[<i1..<1]).
         */

        inter_pc = pc;
        sp++;
        sp[0] = sp[-1];       /* Pull up the 'v' */
        put_number(sp-1, 1);  /* 'Push' the 1 for the upper bound */
        sp = protected_range_lvalue(RR_RANGE, sp);
        break;

                          /* --- protected_ax_range_lvalue --- */
    CASE(F_PROTECTED_AX_RANGE_LVALUE);
        /* Operator (string|vector &v=sp[0], int i1=sp[-1])
         *
         * Compute the range &(v[>i1..]) of lvalue <v>, wrap it into a
         * protector, and push the reference to the protector onto the
         * stack.
         *
         * If <v> is a protected lvalue itself, its protecting svalue will
         * be used in the result protector.
         *
         * If <v> is a string-lvalue, it is made a malloced string if
         * necessary.
         *
         * We implement it by pushing '1' onto the stack and then
         * calling protected_ar_range_lvalue, effectively computing
         * &(v[>i1..<1]).
         */

        inter_pc = pc;
        sp++;
        sp[0] = sp[-1];       /* Pull up the 'v' */
        put_number(sp-1, 1);  /* 'Push' the 1 for the upper bound */
        sp = protected_range_lvalue(AR_RANGE, sp);
        break;

    CASE(F_SIMUL_EFUN);             /* --- simul_efun <code>   --- */
    {
        /* Call the simul_efun <code> with the arguments on the stack.
         * If the simul_efun takes a variable number of arguments, or
         * if use_ap is TRUE, then the number of arguments is determined
         * through the ap pointer; otherwise the code assumes that the
         * compiler left the proper number of arguments on the stack.
         *
         * <code> is an ushort and indexes the function list *simul_efunp.
         */

        unsigned short      code;      /* the function index */
        fun_hdr_p           funstart;  /* the actual function */
        object_t           *ob;        /* the simul_efun object */
        int                 def_narg;  /* expected number of arguments */
        simul_efun_table_t *entry;

        assign_eval_cost_inl();  /* we're changing objects */

        /* Get the sefun code and the number of arguments on the stack */
        LOAD_SHORT(code, pc);
        def_narg = simul_efunp[code].num_arg;

        if (use_ap
         || def_narg == SIMUL_EFUN_VARARGS
         || (simul_efunp[code].flags & TYPE_MOD_XVARARGS)
           )
        {
            use_ap = MY_FALSE;  /* Reset the flag */
            num_arg = sp - ap + 1;
        }
        else
            num_arg = def_narg;

        /* Correct the number of arguments on the stack */
        if (num_arg != def_narg && def_narg != SIMUL_EFUN_VARARGS)
        {
            /* If it's an XVARARGS, we don't require the last argument. */
            if (simul_efunp[code].flags & TYPE_MOD_XVARARGS)
                def_narg--;

            /* Add eventually missing arguments */
            while (num_arg < def_narg)
            {
                sp++;
                put_number(sp, 0);
                num_arg++;
            }

            /* Remove extraneous arguments */
            if (!(simul_efunp[code].flags & TYPE_MOD_XVARARGS))
            {
                while (num_arg > def_narg)
                {
                    free_svalue(sp--);
                    num_arg--;
                }
            }
        }

        /* No external calls may be done when this object is destructed.
         */
        if (current_object->flags & O_DESTRUCTED)
        {
            pop_n_elems(num_arg);
            push_number(sp, 0);
            WARNF(("Call from destructed object '%s' ignored.\n"
                  , get_txt(current_object->name)));
            break;
        }

        /* Make sure the simul_efun object exists; loading it when
         * necessary.
         */
        if ( !(ob = simul_efun_object) )
        {
            inter_sp = sp;
            inter_pc = pc;
            if (!assert_simul_efun_object()
             || !(ob = simul_efun_object)
               )
            {
                errorf("Couldn't load simul_efun object.\n");
            }
        }

        /* Get the function code information */
        entry = &simul_efun_table[code];

        if ( NULL != (funstart = entry->funstart) )
        {
            /* The entry is valid: call the sefun by recursing into
             * eval_instruction(), so we can get the result from the
             * stack.
             * We recurse because some simul_efuns are called with
             * F_CALL_DIRECT, and the functions should not be able
             * to see any difference.
             */
            program_t *prog;
            svalue_t *new_sp;

#ifdef USE_NEW_INLINES
            push_control_stack(sp, pc, fp, inter_context);
#else
            push_control_stack(sp, pc, fp);
#endif /* USE_NEW_INLINES */
            csp->ob = current_object;
            csp->prev_ob = previous_ob;
            csp->funstart = funstart;
            csp->num_local_variables = num_arg;
            current_prog = prog = entry->program;
            function_index_offset = entry->function_index_offset;
#ifdef DEBUG
            if (!ob->variables && entry->variable_index_offset)
                fatal("%s Fatal: call sefun for object %p '%s' w/o variables, "
                      "but offset %"PRIdPINT"\n"
                     , time_stamp(), ob, get_txt(ob->name)
                     , (entry->variable_index_offset));
#endif
            current_variables = ob->variables;
            if (current_variables)
                current_variables += entry->variable_index_offset;
            new_sp = setup_new_frame2(funstart, sp, MY_TRUE, MY_FALSE);
            /* The simul_efun object should not use simul_efuns itself... */
            previous_ob = current_object;
            current_object = ob;
            current_strings = prog->strings;
            eval_instruction(FUNCTION_CODE(funstart), new_sp);
            sp -= num_arg - 1;
            /*
             * The result of the function call is on the stack.
             */
            break;
        }

        /* At this point the simul_efun was discarded meanwhile and
         * not recreated.
         * Call the function the old fashioned way with apply() in case it
         * exists in a slightly different form.
         */
        inter_sp = sp;
        inter_pc = pc;
        call_simul_efun(code, ob, num_arg);
        sp = inter_sp;
        /*
         * The result of the function call is on the stack.
         */
        break;
    }

    CASE(F_AGGREGATE);              /* --- aggregate <size>    --- */
    {
        /* Create an array ({ sp[<-size>+1], ..., sp[0] }), remove the
         * single values from the stack and leave the array as result.
         *
         * <size> is a (16-Bit) unsigned short.
         *
         * TODO: It is tempting to introduce flat 'literal arrays',
         * TODO:: which can be copied quickly and just need a few
         * TODO:: slots to filled in, if any.
         */

        int i;
        vector_t *v;
        unsigned short num;
        svalue_t *value, *item;

        /* Get the size */
        LOAD_SHORT(num, pc);

        /* Allocate the array */
        i = num;
        v = allocate_uninit_array(i);

        /* Set sp and value to the first single value on the stack */
        sp = value = sp - i + 1;

        /* Move the single values into the array.
         * Volatile strings are made shared during this.
         */
        item = v->item;
        while (--i >= 0)
            transfer_svalue_no_free(item++, value++);

        /* Leave the array on the stack (ref count is already ok) */
        put_array(sp, v);
        break;
    }

    CASE(F_M_AGGREGATE);     /* --- m_aggregate <size> <width> --- */
    CASE(F_M_CAGGREGATE);   /* --- m_caggregate <size> <width> --- */
    {
        /* Create a mapping from the <size>*<width> single values on the
         * stack, remove the single values and leave the mapping as result.
         * Starting at the lowest entry (sp[-(<size>*<width>)]), the values
         * are laid out in <key>:<data 1>...<data <width>> order.
         * Keys may appear several times.
         *
         * m_aggregate: <size> and <width> are (16-Bit) unsigned shorts.
         * m_caggregate: <size> and <width> are uint8.
         *
         * TODO: It is tempting to introduce flat 'literal mappings',
         * TODO:: which can be copied quickly and just need a few
         * TODO:: slots to filled in, if any.
         */
        int i, j;
        mapping_t *m;
        svalue_t *data;
        int num_values;
        svalue_t *value;

        /* Get the size and width from the code.
         */
        if (instruction == F_M_CAGGREGATE)
        {
            i = LOAD_UINT8(pc);
            num_values = LOAD_UINT8(pc);
        }
        else
        {
            unsigned short num[2];

            LOAD_SHORT(num[0], pc);
            LOAD_SHORT(num[1], pc);
            i = num[0];
            num_values = num[1];
        }

        if (max_mapping_size && (p_uint)i * (1+num_values) > (p_uint)max_mapping_size)
            ERRORF(("Illegal mapping size: %"PRIuPINT" elements (%u x %u)\n"
                   , ((p_uint)i * (1+num_values)), i, num_values));
        if (max_mapping_keys && (p_uint)i > (p_uint)max_mapping_keys)
            ERRORF(("Illegal mapping size: %u entries\n", i));

        /* Get the mapping */
        m = allocate_mapping(i, num_values);
        if (!m)
            ERROR("Out of memory\n");

        /* Set sp and value to the first single value on the stack.
         */
        sp = value = sp - (i * (num_values+1)) + 1;
        while (--i >= 0)
        {
            /* Create/reget the mapping entry */
            data = get_map_lvalue_unchecked(m, value);
            if (!data)
            {
                outofmemory("literal mapping");
                /* NOTREACHED */
                return MY_FALSE;
            }
            free_svalue(value++);
            for (j = num_values; --j >= 0;)
            {
                /* Copy over the entry data */
                if (data->type != T_NUMBER)
                    free_svalue(data);
                transfer_svalue_no_free(data++, value++);
            }
        }

        /* Put the mapping onto the stack */
        put_mapping(sp, m);
        break;
    }

#ifdef USE_STRUCTS
    CASE(F_S_AGGREGATE);
                        /* --- s_aggregate <idx> <num> --- */
    CASE(F_S_M_AGGREGATE);
           /* --- s_m_aggregate <idx> <num> <index>... --- */
    {
        /* Create a struct from the <num> values currently on the
         * stack. The struct can be found at short <idx> in
         * program.struct_defs[]. If <idx> is negative, the <num>+1th
         * value on the stack is a struct of the type to be generated
         * (F_S_AGGREGATE only).
         * For F_S_AGGREGATE, the values on the stack are to be assigned
         * to the struct members in ascending order.
         * For F_S_M_AGGREGATE, the <index>... values give for each
         * value on the stack into which struct member the value has to go.
         * This list of indices is given in reverse order, that is the
         * index for the topmost stack value comes first.
         */
        struct_t * st;
        short idx;
        int num_values;
        Bool has_template;
        svalue_t * svp;

        LOAD_SHORT(idx, pc);
        num_values = LOAD_UINT8(pc);
        has_template = MY_FALSE;

        if (idx < 0 && instruction == F_S_AGGREGATE)
        {
            struct_type_t *pType;

            if ((sp - num_values)->type != T_STRUCT)
            {
                ERRORF(("Bad template arg to #'(<: got %s, expected struct\n"
                       , typename((sp - num_values)->type)
                      ));
                /* NOTREACHED */
            }

            pType = (sp - num_values)->u.strct->type;

            if (num_values > struct_t_size(pType))
            {
                ERRORF(("Too many initializers for struct %s: "
                        "%ld, expected %ld\n"
                       , get_txt(struct_t_name(pType))
                       , (long)num_values
                       , (long)struct_t_size(pType)
                      ));
                /* NOTREACHED */
            }
            has_template = MY_TRUE;
            st = struct_new(pType);
        }
        else
        {
            st = struct_new(current_prog->struct_defs[idx].type);
        }
        if  (!st)
            ERROR("Out of memory!\n");

        if (instruction == F_S_AGGREGATE)
        {
            /* Easy way: just move all the values into the struct.
             * This allows for having less initializers than members.
             */

            for ( svp = st->member + num_values - 1
                ; num_values > 0
                ; num_values--, svp--, sp--
                )
            {
                *svp = *sp;
            }
        }
        else
        {
            /* Complex way: assign using the indices */
            int ix;

            for ( ; num_values > 0 ; num_values--, sp--)
            {
                ix = LOAD_UINT8(pc);
                st->member[ix] = *sp;
            }
        }

        /* If necessary, remove the template struct */
        if (has_template)
        {
            free_svalue(sp); sp--;
        }

        /* Put the struct onto the stack */
        sp++;
        put_struct(sp, st);

        break;
   }
#endif /* USE_STRUCTS */

    CASE(F_PREVIOUS_OBJECT0);       /* --- previous_object0    --- */
        /* EFUN previous_object(void)
         *
         * Push the previous_object onto the stack, if existing and
         * not destructed.
         *
         * The compiler generates this code when it sees the previous_object()
         * efun used with no arguments.
         *
         * (Reminder: the efun previous_object(int) has a different meaning.)
         * TODO: How do other driver handle this?
         */
        if (previous_ob == 0 || (previous_ob->flags & O_DESTRUCTED))
            push_number(sp, 0);
        else
            push_ref_object(sp, previous_ob, "previous_object0");
        break;

    CASE(F_LAMBDA_CCONSTANT);    /* --- lambda_cconstant <num> --- */
    {
        /* Push the constant value <num> of this lambda closure onto
         * the stack.
         *
         * The values are stored in an svalue[] before the actual
         * function code and uint8 <num> is used to index that array
         * from the end.
         */
        int ix;
        svalue_t * cstart;

        /* Get the value index */
        ix = LOAD_UINT8(pc);

        /* Get the pointer to the last constant value */
        cstart = (svalue_t *)((char *)(csp->funstart)
                                   - LAMBDA_VALUE_OFFSET);
        sp++;
        assign_checked_svalue_no_free(sp, cstart - ix);
        break;
    }

    CASE(F_LAMBDA_CONSTANT);     /* --- lambda_constant <num> --- */
    {
        /* Push the constant value <num> of this lambda closure onto
         * the stack.
         *
         * The values are stored in an svalue[] before the actual
         * function code and (16-Bit) ushort <num> is used to index
         * that array from the end.
         */
        unsigned short ix;
        svalue_t * cstart;

        /* Get the value index */
        LOAD_SHORT(ix, pc);

        /* Get the pointer to the last constant value */
        cstart = (svalue_t *)((char *)(csp->funstart)
                                   - LAMBDA_VALUE_OFFSET);
        sp++;
        assign_checked_svalue_no_free(sp, cstart - ix);
        break;
    }

    CASE(F_MAP_INDEX);              /* --- map_index           --- */
    {
        /* Operator F_MAP_INDEX( mapping m=sp[-2], mixed i=sp[-1], int j=sp[0])
         *
         * Compute m[i,j] and push it onto the stack.
         */

        mapping_t *m;
        mp_int n;
        svalue_t *data;

        if (sp[-2].type != T_MAPPING)
        {
            ERRORF(("(value) Indexing on illegal type: %s, expected mapping.\n"
                   , typename(sp[-2].type)
                  ));
        }
        if (sp[0].type != T_NUMBER)
        {
            ERRORF(("Illegal sub-index type: %s, expected number.\n"
                   , typename(sp[0].type)
                  ));
        }

        m = sp[-2].u.map;
        n = sp->u.number;

        if (n < 0 || n >= m->num_values)
        {
            ERRORF(("Illegal sub-index %"PRIdMPINT", mapping width is %"
                    PRIdPINT".\n", n, m->num_values));
        }

        sp--; /* the key */

        data = get_map_value(m, sp);
        pop_stack();

        if (data == &const0)
        {
            put_number(sp, 0);
        }
        else
        {
            assign_checked_svalue_no_free(sp, data + n);
        }
        free_mapping(m);
        break;
    }

    CASE(F_PUSH_INDEXED_MAP_LVALUE); /* --- push_indexed_map_lvalue --- */
    {
        /* Operator F_PUSH_INDEXED_MAP_LVALUE( mapping m=sp[-2]
         *                                   , mixed i=sp[-1], int j=sp[0])
         *
         * Compute the lvalue &(m[i,j]) and push it into the stack. If v has
         * just one ref left, the indexed item is stored in indexing_quickfix
         * and the lvalue refers to that variable.
         */
        svalue_t *data;
        mapping_t *m;
        mp_int n;

        if (sp[-2].type != T_MAPPING)
        {
            ERRORF(("(lvalue) Indexing on illegal type: %s, expected mapping.\n"
                   , typename(sp[-2].type)
                  ));
        }
        if (sp[0].type != T_NUMBER)
        {
            ERRORF(("Illegal sub-index type: %s, expected number.\n"
                   , typename(sp[0].type)
                  ));
        }

        m = sp[-2].u.map;
        n = sp->u.number;
        if (n < 0 || n >= m->num_values)
        {
            ERRORF(("Illegal sub-index %"PRIdMPINT", mapping width is %"
                    PRIdPINT".\n", n, m->num_values));
        }

        sp--; /* the key */
        data = get_map_lvalue(m, sp);
        if (!data)
        {
            outofmemory("indexed lvalue");
            /* NOTREACHED */
            return MY_FALSE;
        }
        pop_stack();

        if (!m->ref)
        {
            assign_svalue (&indexing_quickfix, data + n);
            sp->type = T_LVALUE;
            sp->u.lvalue = &indexing_quickfix;
            break;
        }
        else
        {
            sp->type = T_LVALUE;
            sp->u.lvalue = data + n;
        }
        free_mapping(m);
        break;
    }

    CASE(F_FOREACH);       /* --- foreach     <nargs> <offset> --- */
    CASE(F_FOREACH_REF);   /* --- foreach_ref <nargs> <offset> --- */
    CASE(F_FOREACH_RANGE); /* --- foreach_range <nargs> <offset> --- */
    {
        /* Initialize a foreach() loop. On the stack are <nargs>-1
         * lvalues where the (l)value(s) are to be stored. The last
         * value on the stack is the (l)value to loop over. (Do not
         * confuse <nargs> with the normal NUM_ARG!).
         *
         * ushort <offset> is the distance to the FOREACH_NEXT
         * instruction follwing the codeblock after the instruction,
         * counted from the byte following this instruction.
         *
         * The instruction pushes two or three more values onto
         * the stack to store its internal status.
         *
         *   sp[0]  -> number 'next':  index of the next value to assign (0).
         *             x.generic:      0: FOREACH, 1: FOREACH_REF
         *                             2: FOREACH_RANGE with one extra loop
         *                                (this falls back to FOREACH after
         *                                 the first encounter of
         *                                 FOREACH_NEXT).
         *   sp[-1] -> number 'count': number of values left to loop over.
         *             x.generic:      <nargs>, or -<nargs> if the value
         *                             is mapping
         *   sp[-2] -> array 'm_indices': if the value is a mapping, this
         *                             is the array with the indices.
         *
         * After pushing the values onto the stack, the instruction
         * branches to the FOREACH_NEXT instruction to start the first
         * iteration.
         */

        int vars_required;
        int nargs;
        p_int count, start;
        unsigned short offset;
        Bool gen_refs, use_range, do_extra_loop;
        svalue_t * arg;

        gen_refs = (instruction == F_FOREACH_REF);
        use_range = (instruction == F_FOREACH_RANGE);
        do_extra_loop = MY_FALSE;
        start = 0;

        nargs = LOAD_UINT8(pc);
        LOAD_SHORT(offset, pc);

        /* Unravel the lvalue chain (if any) to get to the actual value
         * to loop over.
         */
        if (gen_refs && sp->type != T_LVALUE)
        {
            ERRORF(("foreach() got a %s, expected a &(string/array/mapping).\n"
                   , typename(sp->type)
                   ));
        }

        for (arg = sp
            ; gen_refs && arg && arg->type == T_LVALUE
            ; arg = arg->u.lvalue)
            NOOP;

        if (use_range && arg->type != T_NUMBER)
            ERRORF(("foreach() got a %s, requires a number for upper range bound.\n"
                   , typename(arg->type)
                   ));

        if (arg->type != T_STRING
         && arg->type != T_POINTER
         && arg->type != T_NUMBER
#ifdef USE_STRUCTS
         && arg->type != T_STRUCT
#endif /* USE_STRUCTS */
         && arg->type != T_MAPPING)
            ERRORF(("foreach() got a %s, expected a (&)string/array/mapping/struct or number.\n"
                   , typename(sp->type)
                   ));

        if (gen_refs && arg->type == T_NUMBER)
            ERROR("foreach() got a &number, expected a (&)string/array/mapping/struct or number.\n"
                   );

        /* Find out how many variables we require */

        if (arg->type == T_NUMBER)
        {
            count = arg->u.number;
            if (count < 0 && !use_range)
                ERRORF(("foreach() got a %"PRIdPINT", expected a non-negative "
                        "number.", count));
            vars_required = 1;
        }
        else if (arg->type == T_STRING)
        {
            count = mstrsize(arg->u.str);
            vars_required = 1;

            if (gen_refs)
            {
                string_t *str;

                /* If the string is tabled, i.e. not changeable, or has more
                 * than one reference, allocate a new copy which can be
                 * changed safely.
                 */
                if (!mstr_singular(arg->u.str))
                {
                    memsafe(str = unshare_mstring(arg->u.str), mstrsize(arg->u.str)
                           , "modifiable string");
                    arg->u.str = str;
                }

                /* Replace the string-lvalue on the stack by the string
                 * itself - we don't need the lvalue any more.
                 */
                str = ref_mstring(arg->u.str);
                free_svalue(sp);
                put_string(sp, str);
            }
        }
        else if (arg->type == T_POINTER)
        {
            check_for_destr(arg->u.vec);
            count = VEC_SIZE(arg->u.vec);
            vars_required = 1;

            if (gen_refs)
            {
                /* Replace the array-lvalue on the stack by the array
                 * itself - we don't need the lvalue any more.
                 */
                vector_t * vec = arg->u.vec;

                (void)ref_array(vec);
                free_svalue(sp);
                put_array(sp, vec);
            }
        }
#ifdef USE_STRUCTS
        else if (arg->type == T_STRUCT)
        {
            struct_check_for_destr(arg->u.strct);
            count = struct_size(arg->u.strct);
            vars_required = 1;

            if (gen_refs)
            {
                /* Replace the struct-lvalue on the stack by the struct
                 * itself - we don't need the lvalue any more.
                 */
                struct_t * st = arg->u.strct;

                (void)ref_struct(st);
                free_svalue(sp);
                put_struct(sp, st);
            }
        }
#endif /* USE_STRUCTS */
        else
        {
            mapping_t *m;
            vector_t  *indices;

            m = arg->u.map;
            vars_required = 1 + m->num_values;
            indices = m_indices(m);

            count = MAP_SIZE(m);
              /* after m_indices(), else we'd count destructed entries */

            if (gen_refs)
            {
                /* Replace the mapping-lvalue on the stack by the mapping
                 * itself - we don't need the lvalue any more.
                 */
                (void)ref_mapping(m);
                free_svalue(sp);
                put_mapping(sp, m);
            }

            /* Push the indices array and remember the fact in nargs.
             */
            sp++;
            put_array(sp, indices);
            nargs = -nargs;
        }

        /* If this is a range foreach, drop the upper bound svalue
         * from the stack and calculate the actual number of steps, and
         * get the lower bound svalue to be used as starting index.
         * Since this lower bound svalue is an integer as well, we can
         * then pretend to execute a normal foreach over an integer.
         */
        if (use_range)
        {
            free_svalue(sp); sp--;
            if (sp->type != T_NUMBER)
                ERRORF(("foreach() got a %s, expected a number for lower range bound.\n"
                       , typename(sp->type)
                       ));
            start = sp->u.number;
            if (count < start)
                count = 0;
            else
            {
                count = count - sp->u.number + 1;
                if (!count)
                {
                    /* Range is __INT_MIN_..__INT_MAX__: for this
                     * we need to make one more loop than we can count.
                     */
                    do_extra_loop = MY_TRUE;
                }
            }
        }

        /* Push the count and the starting index */
        push_number(sp, count); sp->x.generic = nargs;
        push_number(sp, start); sp->x.generic = do_extra_loop
                                                ? 2
                                                : (gen_refs ? 1 : 0);

#ifdef DEBUG
        /* The <nargs> lvalues and our temporaries act as hidden
         * local variables. We therefore adapt the variable count
         * so that a F_RETURN won't complain.
         */
        if (nargs >= 0)
            csp->num_local_variables += 2 + nargs;
        else
            csp->num_local_variables += 3 + (-nargs);
#endif

        /* Now branch to the FOREACH_NEXT */
        pc += offset;

        break;
    }

    CASE(F_FOREACH_NEXT);         /* --- foreach_next <offset> --- */
    {
        /* Start the next (resp. the first) iteration of a foreach()
         * loop. ushort <offset> is the distance to branch back to the
         * loop body, counted from the first byte of the next instruction.
         * For the stack layout, see F_FOREACH.
         */

        unsigned short offset;
        p_int     ix;
        svalue_t *lvalue;  /* Pointer to the first lvalue */
        Bool      gen_refs;


        LOAD_SHORT(offset, pc);

        ix = sp->u.number;
        if (sp->x.generic == 2)
        {
            sp->x.generic = 0;
            /* FOREACH_RANGE with extra loop: don't increment the
             * 'next' number on this one.
             */
        }
        else
        {
            /* Is there something left to iterate? */
            if (0 == sp[-1].u.number)
                break; /* Nope */

            sp->u.number++; /* next number */
        }
        sp[-1].u.number--; /* decrement loop count */

        gen_refs = sp->x.generic;

        if (sp[-1].x.generic < 0)
        {
            /* We loop over a mapping */

            mapping_t *m;
            vector_t  *indices;
            svalue_t  *values;
            p_int        left;

            lvalue = sp + sp[-1].x.generic - 2;

            m = sp[-3].u.map;
            indices = sp[-2].u.vec;

            values = get_map_value(m, indices->item+ix);
            if (values == &const0)
            {
                /* Whoops, the entry has vanished.
                 * Start over with this instruction again, the
                 * index on the stack has been incremented already.
                 */
                pc -= 3;
                break;
            }

            /* Assign the index we used */
            {
                svalue_t *dest;

#ifdef DEBUG
                if (lvalue->type != T_LVALUE)
                    fatal("Bad argument to foreach(): not a lvalue\n");
                    /* TODO: Give type and value */
#endif
                dest = lvalue->u.lvalue;
                assign_svalue(dest, indices->item+ix);

                lvalue++;
            }

            /* Loop over the values and assign them */
            left = -(sp[-1].x.generic) - 2;
            if (left > m->num_values)
                left = m->num_values;

            for ( ; left > 0; left--, lvalue++, values++)
            {
                svalue_t *dest;

#ifdef DEBUG
                if (lvalue->type != T_LVALUE)
                    fatal("Bad argument to foreach(): not a lvalue\n");
                    /* TODO: Give type and value */
#endif
                dest = lvalue->u.lvalue;
                if (!gen_refs)
                {
                    assign_svalue(dest, values);
                }
                else
                {
                    struct protected_lvalue * prot;

                    free_svalue(dest);

                    prot = (struct protected_lvalue *)xalloc(sizeof *prot);
                    prot->v.type = T_PROTECTED_LVALUE;
                    prot->v.u.lvalue = values;
                    (void)ref_mapping(m);
                    BUILD_MAP_PROTECTOR(prot->protector, m)

                    dest->type = T_LVALUE;
                    dest->u.lvalue = &prot->v;
                }
            }

            /* Ta-Da! */
        }
        else
        {
            lvalue = sp - sp[-1].x.generic - 1;
#ifdef DEBUG
            if (lvalue->type != T_LVALUE)
                fatal("Bad argument to foreach(): not a lvalue\n");
                /* TODO: Give type and value */
#endif
            lvalue = lvalue->u.lvalue;

            if (sp[-2].type == T_NUMBER)
            {
                  free_svalue(lvalue);
                  put_number(lvalue, ix);
            }
            else if (sp[-2].type == T_STRING)
            {
                free_svalue(lvalue);
                if (!gen_refs)
                {
                    put_number(lvalue, get_txt(sp[-2].u.str)[ix]);
                }
                else
                {
                    svalue_t * str = sp-2;
                    struct protected_char_lvalue *val;

                    /* Compute and return the result */

                    (void)ref_mstring(str->u.str);
                    val = (struct protected_char_lvalue *)xalloc(sizeof *val);
                    val->v.type = T_PROTECTED_CHAR_LVALUE;
                    val->v.u.charp = &(get_txt(str->u.str)[ix]);
                    val->lvalue = str;
                    val->start = get_txt(str->u.str);
                    val->protector.type = T_INVALID;

                    lvalue->type = T_LVALUE;
                    lvalue->u.protected_char_lvalue = val;
                }
            }
            else if (sp[-2].type == T_POINTER)
            {
                if (ix >= VEC_SIZE(sp[-2].u.vec))
                    break;
                    /* Oops, this array shrunk while we're looping over it.
                     * We stop processing and continue with the following
                     * FOREACH_END instruction.
                     */

                if (!gen_refs)
                {
                    assign_svalue(lvalue, sp[-2].u.vec->item+ix);
                }
                else
                {
                    svalue_t * vec = sp-2;
                    svalue_t * item;
                    struct protected_lvalue * prot;

                    free_svalue(lvalue);

                    /* Compute the indexed item and set up the protector */

                    item = &vec->u.vec->item[ix];
                    prot = (struct protected_lvalue *)xalloc(sizeof *prot);
                    prot->v.type = T_PROTECTED_LVALUE;
                    prot->v.u.lvalue = item;
                    put_ref_array(&(prot->protector), vec->u.vec);

                    lvalue->type = T_LVALUE;
                    lvalue->u.lvalue = &prot->v;
                }
            }
#ifdef USE_STRUCTS
            else if (sp[-2].type == T_STRUCT)
            {
                if (ix >= struct_size(sp[-2].u.strct))
                    break;
                    /* Oops, somehow the struct managed to shring while
                     * we're looping over it.
                     * We stop processing and continue with the following
                     * FOREACH_END instruction.
                     */

                if (!gen_refs)
                {
                    assign_svalue(lvalue, sp[-2].u.strct->member+ix);
                }
                else
                {
                    svalue_t * st = sp-2;
                    svalue_t * item;
                    struct protected_lvalue * prot;

                    free_svalue(lvalue);

                    /* Compute the indexed item and set up the protector */

                    item = &st->u.strct->member[ix];
                    prot = (struct protected_lvalue *)xalloc(sizeof *prot);
                    prot->v.type = T_PROTECTED_LVALUE;
                    prot->v.u.lvalue = item;
                    put_ref_struct(&(prot->protector), st->u.strct);

                    lvalue->type = T_LVALUE;
                    lvalue->u.lvalue = &prot->v;
                }
            }
            else
              fatal("foreach() requires a string, array, struct or mapping.\n");
              /* If this happens, the check in F_FOREACH failed. */
#else /* USE_STRUCTS */
            else
              fatal("foreach() requires a string, array or mapping.\n");
              /* If this happens, the check in F_FOREACH failed. */
#endif /* USE_STRUCTS */
        }

        /* All that is left is to branch back. */
        pc -= offset;
        break;
    }

    CASE(F_FOREACH_END);            /* --- foreach_end         --- */
    {
        /* The foreach() loop ended or was terminated by a break.
         * All there's left to do is cleaning up the stack.
         */

        int nargs;

        nargs = sp[-1].x.generic;

        if (nargs < 0)
            nargs = (-nargs) + 3;
        else
            nargs = nargs + 2;

        pop_n_elems(nargs);

#ifdef DEBUG
        /* The <nargs> lvalues and our temporaries acted as hidden
         * local variables. We now count back the variable count
         * so that a F_RETURN won't complain.
         */
        csp->num_local_variables -= nargs;
#endif

        break;
    }

    CASE(F_END_CATCH);                  /* --- end_catch       --- */
        /* For a catch(...guarded code...) statement, the compiler
         * generates a F_END_CATCH as last instruction of the
         * guarded code.
         *
         * Executed when no error occured, it returns into
         * catch_instruction() to clean up the
         * error recovery information pushed by the F_CATCH
         * and leave a 0 on the stack.
         *
         * dump_trace() checks for this bytecode, but accepts a normal
         * instruction as well as an escaped instruction.
         */

        return MY_TRUE;
        break;

                          /* --- breakn_continue <num> <offset> ---*/
    CASE(F_BREAKN_CONTINUE);
        /* Implement the 'continue;' statement from within
         * a nested surrounding structure.
         *
         * Pop <num>+1 (uint8) break-levels from the break stack
         * and jump by (32-Bit) long <offset> bytes, counted from the
         * first by of <offset>
         */

        break_sp +=
          LOAD_UINT8(pc) * (sizeof(svalue_t)/sizeof(*break_sp));
        /* FALLTHROUGH */

    CASE(F_BREAK_CONTINUE);       /* --- break_continue <offset> ---*/
    {
        /* Implement the 'continue;' statement for the immediate
         * surrounding structure.
         *
         * Pop one break-level from the break stack and jump
         * by (32-Bit) unsigned long <offset> bytes, counted from the
         * first by of <offset>
         *
         * Pitfall: the offset is added to the current pc in 16-Bit
         * unsigned arithmetic, allowing to jump backwards using big
         * enough values.
         *
         * TODO: Make that a proper signed short.
         */

        /* TODO: uint16 */ unsigned long offset;

        break_sp += sizeof(svalue_t)/sizeof(*break_sp);
        GET_LONG(offset, pc);
        offset += pc - current_prog->program;
        pc = current_prog->program + offset;
        break;
    }

#ifdef F_JUMP
    CASE(F_JUMP);                   /* --- jump <dest>         --- */
    {
        /* Jump to the (24-Bit) unsigned address <dest> (absolute jump).
         */

        unsigned long dest;

        GET_3BYTE(dest, pc);
        pc = current_prog->program + dest;
        break;
    }
#endif /* F_JUMP */

    CASE(F_NO_WARN_DEPRECATED);     /* --- no_warn_deprecated  --- */
    {
        /* Set the runtime_no_warn_deprecated flag for the next
         * instruction.
         */

        runtime_no_warn_deprecated = MY_TRUE;
        break;
    }

    CASE(F_ARRAY_RANGE_CHECK);       /* --- array_range_check  --- */
    {
        /* Set the runtime_array_range_check flag for the next
         * instruction.
         */

        runtime_array_range_check = MY_TRUE;
        break;
    }

    /* --- Efuns: Miscellaneous --- */

    CASE(F_CLONEP);                 /* --- clonep              --- */
    {
        /* EFUN clonep()
         *
         *   int clonep()
         *   int clonep (object obj)
         *   int clonep (string obj)
         *
         * The efun returns 1 if <obj> is a clone, and 0 if it is not.
         * The <obj> can be given as the object itself, or by its name.
         * If <obj> is omitted, the current object is tested.
         * Arguments of other types return 0.
         */

        int i;

        if (sp->type == T_OBJECT)
        {
            i = (sp->u.ob->flags & O_CLONE);
        }
        else if (sp->type == T_STRING)
        {
            object_t *o;

            o = find_object(sp->u.str);
            if (!o)
                ERRORF(("No such object '%s'.\n", get_txt(sp->u.str)));
            i = o->flags & O_CLONE;
        }
        else
            i = 0;
        free_svalue(sp);
        put_number(sp, i ? 1 : 0);
        break;
    }

    CASE(F_CLOSUREP);               /* --- closurep            --- */
    {
        /* EFUN closurep()
         *
         *   int closurep(mixed)
         *
         * Returns 1 if the argument is a closure.
         */

        int i;

        i = sp->type == T_CLOSURE;
        free_svalue(sp);
        put_number(sp, i);
        break;
    }

    CASE(F_FLOATP);                 /* --- floatp              --- */
    {
        /* EFUN floatp()
         *
         *   int floatp(mixed)
         *
         * Returns 1 if the argument is a float.
         */

        int i;

        i = sp->type == T_FLOAT;
        free_svalue(sp);
        put_number(sp, i);
        break;
    }

    CASE(F_INTP);                   /* --- intp                --- */
    {
        /* EFUN intp()
         *
         *   int intp(mixed)
         *
         * Returns 1 if the argument is an integer.
         */

        int i;

        i = sp->type == T_NUMBER;
        free_svalue(sp);
        put_number(sp, i);
        break;
    }

    CASE(F_MAPPINGP);               /* --- mappingp            --- */
    {
        /* EFUN mappingp()
         *
         *   int mappingp(mixed)
         *
         * Returns 1 if the argument is a mapping.
         */

        int i;

        i = sp->type == T_MAPPING;
        free_svalue(sp);
        put_number(sp, i);
        break;
    }

    CASE(F_OBJECTP);                /* --- objectp              --- */
    {
        /* EFUN objectp()
         *
         *   int objectp(mixed)
         *
         * Returns 1 if the argument is an object.
         */

        int i;

        i = sp->type == T_OBJECT;
        free_svalue(sp);
        put_number(sp, i);
        break;
    }

    CASE(F_POINTERP);               /* --- pointerp            --- */
    {
        /* EFUN pointerp()
         *
         *   int pointerp(mixed)
         *
         * Returns 1 if the argument is an array.
         */

        int i;

        i = sp->type == T_POINTER;
        free_svalue(sp);
        put_number(sp, i);
        break;
    }

    CASE(F_REFERENCEP);                /* --- referencep      --- */
      {
        /* EFUN referencep()
         *
         *   int referencep(mixed arg)
         *
         * Returns true if arg was passed by reference to the current
         * function, instead of the usual call-by-value.
         */

        int i;

        i = (sp->type == T_LVALUE && sp->u.lvalue->type == T_LVALUE);
        free_svalue(sp);
        put_number(sp, i);
        break;
      }

    CASE(F_STRINGP);                /* --- stringp             --- */
    {
        /* EFUN stringp()
         *
         *   int stringp(mixed)
         *
         * Returns 1 if the argument is a string.
         */

        int i;

        i = sp->type == T_STRING;
        free_svalue(sp);
        put_number(sp, i);
        break;
    }

#ifdef USE_STRUCTS
    CASE(F_STRUCTP);                /* --- structp             --- */
    {
        /* EFUN structp()
         *
         *   int structp(mixed)
         *
         * Returns 1 if the argument is a struct.
         */

        int i;

        i = sp->type == T_STRUCT;
        free_svalue(sp);
        put_number(sp, i);
        break;
    }
#endif

    CASE(F_SYMBOLP);                /* --- symbolp             --- */
    {
        /* EFUN symbolp()
         *
         *   int symbolp(mixed)
         *
         * Returns 1 if the argument is a symbol.
         */

        int i;

        i = sp->type == T_SYMBOL;
        free_svalue(sp);
        put_number(sp, i);
        break;
    }

    CASE(F_TYPEOF);                    /* --- typeof          --- */
      {
        /* EFUN typeof()
         *
         *   int typeof(mixed)
         *
         * Returns a code for the type of the argument, as defined in
         * <sys/lpctypes.h>
         */

        mp_int i = sp->type;
        free_svalue(sp);
        put_number(sp, i);
        break;
      }

    CASE(F_NEGATE);                 /* --- negate              --- */
        /* EFUN negate()
         *
         *   int|float negate(int|float arg)
         *
         * Negate the value <arg> and leave it on the stack.
         * Calls to this efun are mainly generated by the compiler when
         * it sees the unary '-' used.
         */

        if (sp->type == T_NUMBER)
        {
            if (sp->u.number == PINT_MIN)
                ERRORF(("Numeric overflow: - %"PRIdPINT"\n", sp->u.number));
            sp->u.number = - sp->u.number;
            break;
        }
        else if (sp->type == T_FLOAT)
        {
            STORE_DOUBLE_USED
            double d;

            d = -READ_DOUBLE(sp);
            if (d < (-DBL_MAX) || d > DBL_MAX)
                ERRORF(("Numeric overflow: -(%g)\n", READ_DOUBLE(sp)));
            STORE_DOUBLE(sp,d);
            break;
        }
        ERRORF(("Bad arg to unary minus: got %s, expected number/float\n"
               , typename(sp->type)
               ));

    CASE(F_RAISE_ERROR);               /* --- raise_error     --- */
      {
        /* EFUN raise_error()
         *
         *   void raise_error(string arg)
         *
         * Abort execution. If the current program execution was initiated
         * by catch(), that catch expression will return arg as error
         * code, else the arg will printed as error message. This
         * is very similar to throw(), but while throw() is intended to be
         * called inside catch(), raise_error() can be called
         * anywhere.
         */

        TYPE_TEST1(sp, T_STRING);
        ERRORF(("%s", get_txt(sp->u.str)));
      }

    CASE(F_THROW);                  /* --- throw               --- */
        /* EFUN throw()
         *
         *   void throw(mixed arg)
         *
         * Abort execution. If the current program execution was initiated by
         * catch(), that catch expression will return arg as error code.
         */

        assign_eval_cost_inl();
        inter_sp = --sp;
        inter_pc = pc;
        throw_error(sp+1); /* do the longjump, with extra checks... */
        break;

    /* --- Efuns: Strings --- */

    CASE(F_STRLEN);                 /* --- strlen              --- */
    {
        /* EFUN strlen()
         *
         *   int strlen(string str)
         *
         * Returns the length of the string str.
         */

        size_t i;

        if (sp->type == T_STRING)
        {
            i = mstrsize(sp->u.str);
            free_string_svalue(sp);
            put_number(sp, i);
            break;
        }
        if (sp->type == T_NUMBER && sp->u.number == 0)
            break;
        RAISE_ARG_ERROR(1, TF_NULL|TF_STRING, sp->type);
        /* NOTREACHED */
    }

    /* --- Efuns: Arrays and Mappings --- */

    CASE(F_SIZEOF);                 /* --- sizeof              --- */
    {
        /* EFUN sizeof()
         *
         *   int sizeof(mixed arr)
         *
         * Returns the number of elements of an array, the number of
         * keys in a mapping, or the number of characters in a string.
         *
         * As a special case, the number 0 can be passed, and the function
         * will return 0.
         */

        p_int i;

        if (sp->type == T_STRING)
        {
            i = mstrsize(sp->u.str);
            free_svalue(sp);
            put_number(sp, i);
            break;
        }

        if (sp->type == T_POINTER)
        {
            i = VEC_SIZE(sp->u.vec);
            free_svalue(sp);
            put_number(sp, i);
            break;
        }

#ifdef USE_STRUCTS
        if (sp->type == T_STRUCT)
        {
            i = struct_size(sp->u.strct);
            free_svalue(sp);
            put_number(sp, i);
            break;
        }
#endif /* USE_STRUCTS */

        if (sp->type == T_MAPPING)
        {
            mapping_t *m = sp->u.map;
            check_map_for_destr(m); /* Don't count the destructed keys! */
            i = MAP_SIZE(m);
            free_svalue(sp);
            put_number(sp, i);
            break;
        }

        if (sp->type == T_NUMBER && sp->u.number == 0)
            break;

        RAISE_ARG_ERROR(1, TF_NULL|TF_MAPPING|TF_POINTER, sp->type);
        /* NOTREACHED */
    }

    /* --- Efuns: Functions and Closures --- */

    CASE(F_CALL_DIRECT);            /* --- call_direct         --- */
    CASE(F_CALL_OTHER);             /* --- call_other          --- */
    {
        /* EFUN call_other(), call_direct()
         *
         *     unknown call_other(object|string ob, string str, mixed arg, ...)
         *     unknown ob->fun(mixed arg, ...)
         *
         *     unknown call_direct(object|string ob, string str, mixed arg, ...)
         *
         * Call a member function in another object with an argument. The
         * return value is returned from the other object.  The object can be
         * given directly or as a string (i.e. its file name). If it is given
         * by a string and the object does not exist yet, it will be loaded.
         *
#ifdef USE_ARRAY_CALLS
         *     unknown * call_other(object|string *ob, string str, mixed arg, ...)
         *     unknown * ob->fun(mixed arg, ...)
         *
         * Call a member function in other objects with the given arguments.
         * The return values is returned collected in an array.
         * Every object can be given directly or as a string (i.e. its file name).
         * If it is given by a string and the object does not exist yet, it will
         * be loaded.
#endif
         *
         * The difference between call_other() and call_direct()
         * is that the latter does not allow the evaluation of default
         * methods.
         *
         * TODO: A VOID_CALL_OTHER would be nice to have when the result
         * TODO:: is not used.
         */

        svalue_t *arg;
        object_t *ob;
        Bool      b_use_default;

        num_arg = sp - ap + 1;
        inter_pc = pc;
        inter_sp = sp;

        arg = sp - num_arg + 1;

        /* Test the arguments */
        if (arg[0].type != T_OBJECT
         && arg[0].type != T_STRING
#ifdef USE_ARRAY_CALLS
         && arg[0].type != T_POINTER
#endif /* USE_ARRAY_CALLS */
           )
        {
#ifdef USE_ARRAY_CALLS
            RAISE_ARG_ERROR(1, TF_OBJECT|TF_STRING|TF_POINTER, arg[0].type);
#else
            RAISE_ARG_ERROR(1, TF_OBJECT|TF_STRING, arg[0].type);
#endif /* USE_ARRAY_CALLS */
        }

        TYPE_TEST2(arg+1, T_STRING)
        if (get_txt(arg[1].u.str)[0] == ':')
            ERRORF(("Illegal function name in call_other: %s\n",
                  get_txt(arg[1].u.str)));

        /* No external calls may be done when this object is
         * destructed.
         */
        if (current_object->flags & O_DESTRUCTED)
        {
            pop_n_elems(num_arg);
            push_number(sp, 0);
            WARNF(("Call from destructed object '%s' ignored.\n"
                  , get_txt(current_object->name)));
            break;
        }

#ifdef USE_ARRAY_CALLS
        if (arg[0].type != T_POINTER)
#endif /* USE_ARRAY_CALLS */
        {
            /* --- The normal call other to a single object --- */

            assign_eval_cost_inl();

            if (arg[0].type == T_OBJECT)
                ob = arg[0].u.ob;
            else /* it's a string */
            {
                ob = get_object(arg[0].u.str);
                if (ob == NULL)
                    ERRORF(("call_other() failed: can't get object '%s'\n"
                           , get_txt(arg[0].u.str)));
            }

            b_use_default =    (instruction != F_CALL_DIRECT)
                            && (ob != master_ob);

            /* Traceing, if necessary */
            if (TRACEP(TRACE_CALL_OTHER) && TRACE_IS_INTERACTIVE())
            {
                if (!++traceing_recursion)
                {
                    do_trace("Call other ", get_txt(arg[1].u.str), "\n");
                }
                traceing_recursion--;
            }

            /* Call the function with the remaining args on the stack.
             */
            if (!int_apply(arg[1].u.str, ob, num_arg-2, MY_FALSE, b_use_default))
            {
                /* Function not found */
                if (b_use_default) /* int_apply() removed the args */
                    sp -= num_arg-2;
                else
                    pop_n_elems(num_arg-2);
                pop_n_elems(2);
                push_number(sp, 0);
                break;
            }
            sp -= num_arg - 3;

            /* The result of the function call is on the stack. But so
             * is the function name and object that was called.
             * These have to be removed.
             */
            arg = sp;           /* Remember where the function call result is */
            free_string_svalue(--sp);
            free_svalue(--sp);  /* Remove old arguments to call_other */
            *sp = *arg;         /* Re-insert function result */
        }
#ifdef USE_ARRAY_CALLS
        else
        {
            /* --- The other call other to an array of objects --- */

            svalue_t *svp;
            size_t    size;

            /* The array with the objects will also hold the results.
             * For that, it mustn't be shared, therefore we create a
             * copy if necessary.
             */
            size = VEC_SIZE(arg->u.vec);
            if (arg->u.vec->ref != 1 && size != 0)
            {
                vector_t *vec;
                svalue_t *to;

                vec = allocate_array_unlimited(size);
                if (!vec)
                    ERROR("Out of memory.\n");
                for (svp = arg->u.vec->item, to = vec->item
                    ; size != 0
                    ; size--, svp++, to++)
                    assign_svalue_no_free(to, svp);
                free_array(arg->u.vec);
                arg->u.vec = vec; /* adopts the reference */
            }

            /* Now loop over the array of objects and call the function
             * in each of it. For that, the arguments are duly replicated
             * for every call.
             */
            size = VEC_SIZE(arg->u.vec);
            svp = arg->u.vec->item;
            for ( ; size != 0; size--, svp++)
            {
                int i;

                assign_eval_cost_inl();
                inter_sp = sp; /* Might be clobbered from previous loop */

                if (svp->type == T_OBJECT)
                    ob = svp->u.ob;
                else if (svp->type == T_STRING)
                {
                    ob = get_object(svp->u.str);
                    if (ob == NULL)
                    {
                        ERRORF(("call_other() failed: can't get object '%s'\n"
                               , get_txt(svp->u.str)));
                        /* NOTREACHED */
                        continue;
                    }
                }
                else if (svp->type == T_NUMBER && svp->u.number == 0)
                {
                    free_svalue(svp);
                    put_number(svp, 0);
                    continue;
                }
                else
                    ERRORF(("Bad arg for call_other() at index %"PRIdMPINT": "
                            "got %s, expected string/object\n"
                           , (mp_int)(svp - arg->u.vec->item)
                           , typename(svp->type)
                           ));

                /* Destructed objects yield 0 */
                if (ob->flags & O_DESTRUCTED)
                {
                    free_svalue(svp);
                    put_number(svp, 0);
                    continue;
                }

                b_use_default =    (instruction != F_CALL_DIRECT)
                                && (ob != master_ob);

                /* Traceing, if necessary */
                if (TRACEP(TRACE_CALL_OTHER) && TRACE_IS_INTERACTIVE())
                {
                    if (!++traceing_recursion)
                    {
                        do_trace("Call other ", get_txt(arg[1].u.str), "\n");
                    }
                    traceing_recursion--;
                }

                /* Duplicate the arguments to pass, increasing sp on
                 * the way. Optimizing this for the last pass is
                 * dangerous as not every iteration will come here.
                 */
                for (i = 2; i < num_arg; i++)
                    assign_svalue_no_free(++sp, arg+i);

                /* Call the function with the remaining args on the stack.
                 */
                inter_sp = sp; /* update to new setting */
                if (!int_apply(arg[1].u.str, ob, num_arg-2, MY_FALSE, b_use_default))
                {
                    /* Function not found, Assign 0 as result.
                     */
                    if (b_use_default) /* int_apply() removed the args */
                        sp -= num_arg-2;
                    else
                        pop_n_elems(num_arg-2);
                    free_svalue(svp);
                    put_number(svp, 0);
                }
                else
                {
                    /* Function found - assign the result from the stack */
                    sp -= num_arg-3;
                    free_svalue(svp);
                    transfer_svalue_no_free(svp, sp--);
                }
            } /* for (objects in array) */

            /* Remove the original function call arguments from the stack.
             */
            pop_n_elems(num_arg-2);

            /* Calls complete, left on the stack are now the function name
             * and, in arg, the final result.
             */
            free_string_svalue(sp); sp--;
        }
#endif /* USE_ARRAY_CALLS */

        break;
    }

    CASE(F_EXTERN_CALL);               /* --- extern_call     --- */
      {
        /* EFUN extern_call()
         *
         *   int extern_call();
         *
         * Returns zero, if the function that is currently being executed
         * was called by a local call, non-zero for call_other(), driver
         * applies, closure calls, etc. Currently the only return value
         * for them is 1, but later the various methods may be
         * distinguished by means of the return value.
         */


        struct control_stack * pt = csp;

        while (pt->catch_call) pt--;
        push_number(sp, (pt->extern_call & ~CS_PRETEND) ? 1 : 0);
        break;
      }

    /* --- Efuns: Objects --- */

    CASE(F_MASTER);                 /* --- master              --- */
      {
        /* EFUN master()
         *
         *   object master(int dont_load)
         *
         * Return the master object. If <dont_load> is false, the
         * function first makes sure that the master object exists.
         * If <dont_load> is true, the function just returns the current
         * master object, or 0 if the current master has been destructed.
         */

        TYPE_TEST1(sp, T_NUMBER)

        if (! sp->u.number)
            assert_master_ob_loaded();

        free_svalue(sp);

        if (master_ob)
            put_ref_object(sp, master_ob, "master");
        else
            put_number(sp, 0);
        break;
     }

    CASE(F_THIS_INTERACTIVE);       /* --- this_interactive    --- */
        /* EFUN this_interactive()
         *
         *   object this_interactive(void)
         *
         * this_interactive() returns the current interactive object, if
         * any, i.e. the one who "hit the RETURN key".
         */

        if (current_interactive
         && !(current_interactive->flags & O_DESTRUCTED))
            push_ref_object(sp, current_interactive, "this_interactive");
        else
            push_number(sp, 0);
        break;

    CASE(F_THIS_OBJECT);            /* --- this_object         --- */
        /* EFUN this_object()
         *
         *   object this_object(void)
         *
         * Return the object pointer for this object.
         */

        if (current_object->flags & O_DESTRUCTED)
        {
            push_number(sp, 0);
            break;
        }
        push_ref_object(sp, current_object, "this_object");
        break;

    /* --- Efuns: Verbs and Commands --- */

    CASE(F_THIS_PLAYER);            /* --- this_player         --- */
        /* EFUN this_player()
         *
         *   object this_player(void)
         *
         * Return the current command giver.  This can be an interactive
         * user or a living object like a npc.
         *
         * If called from inside the heart_beat() of a not living object
         * 0 will be returned.
         */

        if (command_giver && !(command_giver->flags & O_DESTRUCTED))
            push_ref_object(sp, command_giver, "this_player");
        else
            push_number(sp, 0);
        break;

    /* --- Optional Efuns: Technical --- */

#ifdef F_BREAK_POINT
    CASE(F_BREAK_POINT);            /* --- break_point         --- */
        /* EFUN break_point()
         *
         *   void break_point()
         *
         * This function is for system internal use and should never be called
         * by user objects. It is supposed to check the stack integrity and
         * aborts the driver when it detects corruption.
         *
         */

        if (sp - fp - csp->num_local_variables + 1 != 0)
            fatal("Bad stack pointer.\n");
        break;
#endif

#ifdef F_SWAP
    CASE(F_SWAP);                      /* --- swap            --- */
      {
        /* EFUN swap()
         *
         *   void swap(object obj)
         *
         * Swap out an object. This efun is only used for system internal
         * debugging and can cause a crash.
         */

        object_t *ob;

        /* Test the arguments */
        if (sp->type != T_OBJECT)
            RAISE_ARG_ERROR(1, TF_OBJECT, sp->type);

        ob = sp->u.ob;
        if (ob != current_object
         && !(ob->flags & O_DESTRUCTED)
          ) /* should also check csp */
        {
            if (!O_PROG_SWAPPED(ob))
                (void)swap_program(ob);
            if (!O_VAR_SWAPPED(ob))
                (void)swap_variables(ob);
        }
        free_svalue(sp--);
        break;
      }
#endif

    } /* end of the monumental switch */

    /* Instruction executed */

    /* Reset the no-warn-deprecated flag */
    if (instruction != F_NO_WARN_DEPRECATED)
        runtime_no_warn_deprecated = MY_FALSE;

    /* Reset the no-warn-deprecated flag */
    if (instruction != F_ARRAY_RANGE_CHECK)
        runtime_array_range_check = MY_FALSE;

    /* Even intermediate results could exceed the stack size.
     * We better check for that.
     */
    if (sp - VALUE_STACK == SIZEOF_STACK - 1)
    {
        /* sp ist just at then end of the stack area */
        stack_overflow(sp, fp, pc);
    }
    else if ((mp_int)(sp - VALUE_STACK) > (mp_int)(SIZEOF_STACK - 1))
    {
        /* When we come here, we already overwrote the bounds
         * of the stack :-(
         */
        fatal("Fatal stack overflow: %"PRIdMPINT" too high\n"
             , (mp_int)(sp - VALUE_STACK - (SIZEOF_STACK - 1))
             );
    }

#ifdef DEBUG
    if (expected_stack && expected_stack != sp)
    {
        fatal( "Bad stack after evaluation.\n"
               "sp: %p expected: %p\n"
               "Instruction %d(%s), num arg %d\n"
             , sp, expected_stack
             , instruction, get_f_name(instruction), num_arg);
    }

    if (sp < fp + csp->num_local_variables - 1)
    {
        fatal( "Bad stack after evaluation.\n"
               "sp: %p minimum expected: %p\n"
               "Instruction %d(%s), num arg %d\n"
             , sp, (fp + csp->num_local_variables - 1)
             , instruction, get_f_name(instruction), num_arg);
    }
#endif /* DEBUG */

    /* Execute the next instruction */

    goto again;

    /* Get rid of the handy but highly local macros */
#   undef GET_NUM_ARG
#   undef RAISE_ARG_ERROR
#   undef BAD_ARG_ERROR
#   undef OP_ARG_ERROR
#   undef BAD_OP_ARG
#   undef TYPE_TEST1
#   undef TYPE_TEST2
#   undef TYPE_TEST3
#   undef TYPE_TEST4
#   undef TYPE_TEST_LEFT
#   undef TYPE_TEST_RIGHT
#   undef TYPE_TEST_EXP_LEFT
#   undef TYPE_TEST_EXP_RIGHT
#   undef CASE
#   undef ARG_ERROR_TEMPL
#   undef OP_ARG_ERROR_TEMPL
#   undef TYPE_TEST_TEMPL
#   undef OP_TYPE_TEST_TEMPL
#   undef EXP_TYPE_TEST_TEMPL

} /* eval_instruction() */

/*-------------------------------------------------------------------------*/
static Bool
apply_low ( string_t *fun, object_t *ob, int num_arg
          , Bool b_ign_prot, Bool allowRefs)

/* The low-level implementation of function calls.
 *
 * Call function <fun> in <ob>ject with <num_arg> arguments pushed
 * onto the stack (<inter_sp> points to the last one). static and protected
 * functions can't be called from the outside unless <b_ign_prot> is true.
 * apply_low() takes care of calling shadows where necessary.
 *
 * If <allowRefs> is TRUE, references may be passed as extended varargs
 * ('(varargs mixed *)'). Currently this is used only for simul efuns.
 *
 * When apply_low() returns true, the call was successful, the arguments
 * one the stack have been popped and replaced with the result. But note
 * that <ob> might have been destructed during the call.
 *
 * If apply_low() returns false, the function was not found and the arguments
 * must be removed by the caller. One reason for failure can be an attempt
 * to call an inherited function '::foo' with this function.
 *
 * To speed up the calls, apply_low() maintains a cache of earlier calls, both
 * hits and misses.
 *
 * The function call will swap in the object and also unset its reset status.
 */

{
    program_t *progp;
    struct control_stack *save_csp;
    p_int ix;

    /* This object will now be used, and is thus a target for
     * reset later on (when time due).
     */
    ob->flags &= ~O_RESET_STATE;

#ifdef DEBUG
    if (num_error > 2) {
        fatal("apply_low with too many errors.\n");
        goto failure;
    }
#endif

    /* If there is a chain of objects shadowing, start with the first
     * of these.
     */
    if (ob->flags & O_SHADOW)
    {
        object_t *shadow;

        while (NULL != (shadow = O_GET_SHADOW(ob)->shadowed_by)
            && shadow != current_object)
        {
            ob = shadow;
        }
    }

retry_for_shadow:

    ob->time_of_ref = current_time;

    /* Load the object from swap */
    if (ob->flags & O_SWAPPED)
    {
        if (load_ob_from_swap(ob) < 0)
            errorf("Out of memory\n");
    }

    progp = ob->prog;

#ifdef DEBUG
    if (ob->flags & O_DESTRUCTED)
        fatal("apply() on destructed object '%s' function '%s'\n"
             , ob->name != NULL ? get_txt(ob->name) : "<null>"
             , fun != NULL ? get_txt(fun) : "<null>"
             );
#endif

    /* Get the function name as a shared (directly tabled) string.
     * Since function names are always tabled, such a string must exist
     * if the function exists.
     */
    if (!mstr_tabled(fun))
    {
        fun = find_tabled(fun);
        if (!fun)
            goto failure2;
    }
    /* fun is now guaranteed to be a shared string */

    /* Get the hashed index into the cache */
    ix =
      ( progp->id_number ^ (p_int)fun ^ ( (p_int)fun >> APPLY_CACHE_BITS ) )
         & (CACHE_SIZE-1);

    /* Check if we have an entry for this function call */
    if (cache[ix].id == progp->id_number
     && (cache[ix].name == fun || mstreq(cache[ix].name, fun))
       )
    {
        /* We have found a matching entry in the cache. The contents have
         * to match, not only the pointers, because cache entries for
         * functions not existant in _this_ object <ob> are stored as
         * separately allocated copy, not as another ref to the shared
         * string. Yet they shall be found here.
         */
#ifdef APPLY_CACHE_STAT
        apply_cache_hit++;
#endif
        if (cache[ix].progp
          /* Static functions may not be called from outside.
           * Protected functions not even from the inside
           */
          && (   !(cache[ix].flags & (TYPE_MOD_STATIC|TYPE_MOD_PROTECTED)) /* -> neither static nor protected */
              || b_ign_prot
              || (   !(cache[ix].flags & TYPE_MOD_PROTECTED)
                  && current_object == ob
                 ) /* --> static but not protected, and caller is owner */
             )
           )
        {
            /* the cache will tell us in wich program the function is, and
             * where.
             */
            fun_hdr_p funstart;

            // check for deprecated functions before pushing a new control stack frame.
            if (cache[ix].flags & TYPE_MOD_DEPRECATED)
                warnf("Callother to deprecated function \'%s\' in object %s (%s).\n",
                      get_txt(fun), get_txt(ob->name), get_txt(ob->prog->name));

#ifdef USE_NEW_INLINES
            push_control_stack(inter_sp, inter_pc, inter_fp, inter_context);
#else
            push_control_stack(inter_sp, inter_pc, inter_fp);
#endif /* USE_NEW_INLINES */
            csp->ob = current_object;
            csp->prev_ob = previous_ob;
            csp->num_local_variables = num_arg;
            csp->funstart = funstart = cache[ix].funstart;
            current_prog = cache[ix].progp;
            current_strings = current_prog->strings;
            function_index_offset = cache[ix].function_index_offset;
#ifdef DEBUG
            if (!ob->variables && cache[ix].variable_index_offset)
                fatal("%s Fatal: apply (cached) for object %p '%s' "
                      "w/o variables, but offset %d\n"
                     , time_stamp(), ob, get_txt(ob->name)
                     , cache[ix].variable_index_offset);
#endif
            current_variables = ob->variables;
            if (current_variables)
                current_variables += cache[ix].variable_index_offset;
            inter_sp = setup_new_frame2(funstart, inter_sp, allowRefs, MY_FALSE);
            previous_ob = current_object;
            current_object = ob;
            save_csp = csp;
            eval_instruction(FUNCTION_CODE(funstart), inter_sp);
#ifdef DEBUG
            if (save_csp-1 != csp)
                fatal("Bad csp after execution in apply_low\n");
#endif
            /* Arguments and local variables are now removed. One
             * resulting value is always returned on the stack.
             */
            return MY_TRUE;
        }

        /* when we come here, the cache has told us that the function isn't
         * defined in the object
         */
    }
    else
    {
        /* we have to search the function */

#ifdef APPLY_CACHE_STAT
        apply_cache_miss++;
#endif

        if ( NULL != fun)
        {
            int fx;

            /* Yup, fun is a function _somewhere_ */

            eval_cost++;
            total_evalcost++;
            fx = find_function(fun, progp);
            if (fx >= 0)
            {
                /* Found the function - setup the control stack and
                 * create a new cache entry.
                 */

                funflag_t flags;
                fun_hdr_p funstart;

                // check for deprecated functions before pushing a new control stack frame.
                if (progp->functions[fx] & TYPE_MOD_DEPRECATED)
                    warnf("Callother to deprecated function \'%s\' in object %s (%s).\n",
                          get_txt(fun), get_txt(ob->name), get_txt(ob->prog->name));

#ifdef USE_NEW_INLINES
                push_control_stack(inter_sp, inter_pc, inter_fp, inter_context);
#else
                push_control_stack(inter_sp, inter_pc, inter_fp);
#endif /* USE_NEW_INLINES */
                  /* if an error occurs here, it won't leave the cache in an
                   * inconsistent state.
                   */
                csp->ob = current_object;
                csp->prev_ob = previous_ob;
                if (cache[ix].name)
                    free_mstring(cache[ix].name);

                cache[ix].id = progp->id_number;
                cache[ix].name = ref_mstring(fun);

                csp->num_local_variables = num_arg;
                current_prog = progp;
                flags = setup_new_frame1(fx, 0, 0);

                current_strings = current_prog->strings;

                cache[ix].progp = current_prog;
                cache[ix].function_index_offset = function_index_offset;
                cache[ix].variable_index_offset = variable_index_offset;

#ifdef DEBUG
                if (!ob->variables && variable_index_offset)
                    fatal("%s Fatal: apply for object %p '%s' w/o variables, "
                          "but offset %d\n"
                         , time_stamp(), ob, get_txt(ob->name)
                         , variable_index_offset);
#endif
                current_variables = ob->variables;
                if (current_variables)
                    current_variables += variable_index_offset;
                funstart = current_prog->program + (flags & FUNSTART_MASK);

                cache[ix].funstart = funstart;
                cache[ix].flags = progp->functions[fx]
                                  & (TYPE_MOD_STATIC|TYPE_MOD_PROTECTED|TYPE_MOD_DEPRECATED);

                /* Static functions may not be called from outside,
                 * Protected functions not even from the inside.
                 */
                if (0 != (cache[ix].flags & (TYPE_MOD_STATIC|TYPE_MOD_PROTECTED))
                  && (   (cache[ix].flags & TYPE_MOD_PROTECTED)
                      || current_object != ob)
                  && !b_ign_prot
                    )
                {
                    /* Not found */

                    previous_ob = csp->prev_ob;
                    current_object = csp->ob;
                    pop_control_stack();
                    if (ob->flags & O_SHADOW && O_GET_SHADOW(ob)->shadowing)
                    {
                        /* This is an object shadowing another. The function
                         * was not found, but can maybe be found in the object
                         * we are shadowing.
                         */
                        ob = O_GET_SHADOW(ob)->shadowing;
                        goto retry_for_shadow;
                    }
                    else
                        goto failure;
                }
                csp->funstart = funstart;
                inter_sp = setup_new_frame2(funstart, inter_sp, allowRefs, MY_FALSE);
                previous_ob = current_object;
                current_object = ob;
                save_csp = csp;
                eval_instruction(FUNCTION_CODE(funstart), inter_sp);
#ifdef DEBUG
                if (save_csp-1 != csp)
                    fatal("Bad csp after execution in apply_low\n");
#endif
                /* Arguments and local variables are now removed. One
                 * resulting value is always returned on the stack.
                 */
                return MY_TRUE;
            } /* end if (fx >= 0) */
        } /* end if(fun) */

        /* We have to mark this function as non-existant in this object. */

        if (cache[ix].name)
            free_mstring(cache[ix].name);

        cache[ix].id = progp->id_number;
        cache[ix].name = ref_mstring(fun);
        cache[ix].progp = NULL;
    }

    /* At this point, the function was not found in the object. But
     * maybe this object is a shadow and we find the function in the
     * shadowed object.
     */

    if (ob->flags & O_SHADOW && O_GET_SHADOW(ob)->shadowing)
    {
        ob = O_GET_SHADOW(ob)->shadowing;
        goto retry_for_shadow;
    }

failure:
    if (get_txt(fun)[0] == ':')
        errorf("Illegal function call\n");

failure2:
    /* Failure. Deallocate stack. */
    return MY_FALSE;
} /* apply_low() */

/*-------------------------------------------------------------------------*/
static int
int_apply (string_t *fun, object_t *ob, int num_arg
          , Bool b_ign_prot, Bool b_use_default
          )

/* The wrapper around apply_low() to handle default methods.
 *
 * Call function <fun> in <ob>ject with <num_arg> arguments pushed
 * onto the stack (<inter_sp> points to the last one). static and protected
 * functions can't be called from the outside unless <b_ign_prot> is true.
 * int_apply() takes care of calling shadows where necessary.
 * If <b_use_default> is true and the function call can't be resolved,
 * the function will try to call the default method if one is defined.
 *
 * Results:
 *   APPLY_NOT_FOUND (0): The function was not found (and neither a default
 *       lfun, if allowed). If <b_use_default> was TRUE, the arguments
 *       have already been removed, otherwise the arguments must be
 *       removed by the caller.
 *       One eason for failure can be an attempt to call an inherited
 *       function '::foo' with this function.
 *
 *   APPLY_FOUND: The function was found, and the arguments on the stack
 *       have been popped and replaced with the result. But note
 *       that <ob> might have been destructed during the call.
 *
 *   APPLY_DEFAULT_FOUND: The function was not found, but the call to the
 *       default function succeeded and the arguments on the stack
 *       have been popped and replaced with the result. But note
 *       that <ob> might have been destructed during the call.
 *
 * The function call will swap in the object and also unset its reset status.
 */

{
    if (apply_low(fun, ob, num_arg, b_ign_prot, MY_FALSE))
        return APPLY_FOUND;

    if (b_use_default)
    {
        /* Check if there is a hook */
        svalue_t * hook = driver_hook + H_DEFAULT_METHOD;

        if (hook->type == T_STRING || hook->type == T_CLOSURE)
        {
            /* We got a default method hook.
             * Now we have to rearrange the stack contents to
             * make space for three more values.
             */
            svalue_t result;
            svalue_t * argp;
            int num_extra = (hook->type == T_STRING) ? 2 : 3;
            int i, rc;

            result = const0;

            argp = inter_sp - num_arg + 1;
            for (i = 0; i < num_arg; i++)
                inter_sp[-i+num_extra] = inter_sp[-i];
            inter_sp += num_extra;

            /* Add the three new arguments: &result, ob, fun
             * to the arguments on the stack.
             */
            argp[0].type = T_LVALUE;
            argp[0].u.lvalue = &result;
            if (hook->type == T_CLOSURE)
            {
                put_ref_object(argp+1, ob, "int_apply");
                put_ref_string(argp+2, fun);
            }
            else
                put_ref_string(argp+1, fun);

            /* Call the function */
            if (hook->type == T_STRING)
            {
                rc = apply_low(hook->u.str, ob, num_arg+num_extra, b_ign_prot, MY_TRUE);
            }
            else /* hook->type == T_CLOSURE */
            {
                int_call_lambda(hook, num_arg+num_extra, MY_TRUE, MY_TRUE);
                rc = 1; /* This call obviously succeeds */
            }

            /* Evaluate the result and clean up the stack */
            if (!rc)
            {
                /* Can happen only for T_STRING hooks: Function not found,
                 * but caller expects a clean stack.
                 */
                inter_sp = _pop_n_elems(num_arg+num_extra, inter_sp);
                rc = APPLY_NOT_FOUND;
            }
            else if (inter_sp->type == T_NUMBER
             && inter_sp->u.number == 0)
            {
                /* Default method found, but it denied executing the call.
                 */
                inter_sp--;
                free_svalue(&result);
                rc = APPLY_NOT_FOUND;
            }
            else
            {
                /* Default method found and executed.
                 * Copy the result onto the stack.
                 */
                transfer_svalue(inter_sp, &result);
                rc = APPLY_DEFAULT_FOUND;
            }

            /* rc is now the return value from int_apply(), and
             * the result, if any, is on the stack.
             */

            return rc;
        } /* if (hook is STRING or CLOSURE) */

        /* If we come here, there was no suitable default hook to
         * call - remove the arguments.
         */
        inter_sp = _pop_n_elems(num_arg, inter_sp);
    }
    return APPLY_NOT_FOUND;
} /* int_apply() */

/*-------------------------------------------------------------------------*/
void
push_apply_value (void)

/* Push the current <apply_return_value> onto the stack, <apply_return_value>
 * itself free afterwards.
 */

{
    *++inter_sp = apply_return_value;
    apply_return_value.type = T_NUMBER;
}

/*-------------------------------------------------------------------------*/
void
pop_apply_value (void)

/* Pop the current value on the stack into <apply_return_value>, after
 * freeing the latter of course.
 */

{
    free_svalue(&apply_return_value);
    apply_return_value = *inter_sp--;
}

/*-------------------------------------------------------------------------*/
svalue_t *
sapply_int (string_t *fun, object_t *ob, int num_arg
           , Bool b_find_static, Bool b_use_default)

/* Call function <fun> in <ob>ject with <num_arg> arguments pushed
 * onto the stack (<inter_sp> points to the last one). static and protected
 * functions can't be called from the outside unless <b_find_static> is true.
 * sapply() takes care of calling shadows where necessary.
 * If <b_use_default> is true, an unresolved apply may be redirected to
 * a default lfun.
 *
 * sapply() returns a pointer to the function result when the call was
 * successfull, or NULL on failure. The arguments are popped in any case.
 * The result pointer, if returned, points to a static area which will be
 * overwritten with the next sapply().
 *
 * The function call will swap in the object and also unset its reset status.
 *
 * interpret.h defines the macro sapply(fun,ob,num_arg) for the most
 * common call with b_find_static passed as false.
 */

{
#ifdef DEBUG
    svalue_t *expected_sp;
#endif

    /* Handle tracing */
    if (TRACEP(TRACE_APPLY) && TRACE_IS_INTERACTIVE())
    {
        if (!++traceing_recursion)
        {
            do_trace("Apply", "", "\n");
        }
        traceing_recursion--;
    }

#ifdef DEBUG
    expected_sp = inter_sp - num_arg;
#endif

    /* Do the call */
    if (!int_apply(fun, ob, num_arg, b_find_static, b_use_default))
    {
        if (!b_use_default) /* int_apply() did not clean up the stack */
            inter_sp = _pop_n_elems(num_arg, inter_sp);
        return NULL;
    }
    transfer_svalue(&apply_return_value, inter_sp);
    inter_sp--;

#ifdef DEBUG
    if (expected_sp != inter_sp)
        fatal("Corrupt stack pointer: expected %p, got %p.\n"
             , expected_sp, inter_sp);
#endif

    return &apply_return_value;
} /* sapply_int() */

/*-------------------------------------------------------------------------*/
svalue_t *
apply (string_t *fun, object_t *ob, int num_arg)

/* Call function <fun> in <ob>ject with <num_arg> arguments pushed
 * onto the stack (<inter_sp> points to the last one). static and protected
 * functions can't be called from the outside.
 * apply() takes care of calling shadows where necessary.
 *
 * apply() returns a pointer to the function result when the call was
 * successfull, or NULL on failure. The arguments are popped in any case.
 * The result pointer, if returned, points to a static area which will be
 * overwritten with the next apply().
 *
 * The function call will swap in the object and also unset its reset status.
 *
 * The big difference between apply() and sapply() is that apply() sets
 * the tracedepth to 0 before calling the function.
 */

{
    tracedepth = 0;
    return sapply_int(fun, ob, num_arg, MY_FALSE, MY_TRUE);
} /* apply() */

/*-------------------------------------------------------------------------*/
void
secure_apply_error ( svalue_t *save_sp, struct control_stack *save_csp
                   , Bool external)

/* Recover from an error during a secure apply. <save_sp> and <save_csp>
 * are the saved evaluator stack and control stack pointers, saving the
 * state from when secure_apply() was entered.
 *
 * The function pops all the arguments for the call from the stack, and
 * then calls runtime_error() in the master object with the necessary
 * information, unless it is a triple fault - in that case only a
 * debug_message() is generated.
 *
 * If <external> is TRUE, the eval costs and limits will be reset
 * before runtime_error() is called. This is used for top-level master
 * applies which should behave like normal function calls in the error
 * handling.
 */

{
    if (csp != save_csp)
    {
        /* Could be error before push.
         * We have to unroll the control stack in case it references
         * lambda closures.
         */

        while (csp > save_csp+1)
            pop_control_stack();

        previous_ob = csp->prev_ob;
        current_object = csp->ob;
        pop_control_stack();
    }

    if (inter_sp > save_sp)
        inter_sp = _pop_n_elems (inter_sp - save_sp, inter_sp);
        /* Note: On a stack overflow, the stack_overflow() routine
         * already removed the values from the stack
         */

    if (num_error == 3)
    {
        if (!out_of_memory)
        {
            debug_message("%s Master failure: %s", time_stamp()
                         , get_txt(current_error));
            free_mstring(current_error);
            free_mstring(current_error_file);
            free_mstring(current_error_object_name);
            if (current_error_trace)
            {
                free_array(current_error_trace);
                current_error_trace = NULL;
            }
            if (uncaught_error_trace)
            {
                free_array(uncaught_error_trace);
                uncaught_error_trace = NULL;
            }
        }
    }
    else if (!out_of_memory)
    {
        int a;
        object_t *save_cmd;

        push_string(inter_sp, current_error);
        a = 1;
        if (current_error_file)
        {
            push_string(inter_sp, current_error_file);
            push_string(inter_sp, current_error_object_name);
            push_number(inter_sp, current_error_line_number);
            a += 3;
        }

        if (current_heart_beat)
        {
            /* Heartbeat error: turn off the heartbeat in the object
             * and also pass it to RUNTIME_ERROR.
             */

            object_t *culprit;

            culprit = current_heart_beat;
            current_heart_beat = NULL;
            set_heart_beat(culprit, MY_FALSE);
            debug_message("%s Heart beat in %s turned off.\n"
                         , time_stamp(), get_txt(culprit->name));
            push_ref_valid_object(inter_sp, culprit, "heartbeat error");
            a++;
        }
        else
        {
            if (!current_error_file)
            {
                /* Push dummy values to keep the argument order correct */
                push_number(inter_sp, 0);
                push_number(inter_sp, 0);
                push_number(inter_sp, 0);
                a += 3;
            }

            /* Normal error: push -1 instead of a culprit. */
            push_number(inter_sp, -1);
            a++;
        }

        if (external)
        {
            mark_end_evaluation();
            CLEAR_EVAL_COST;
            RESET_LIMITS;
        }

        save_cmd = command_giver;
        apply_master(STR_RUNTIME, a);
        command_giver = save_cmd;
        /* STR_RUNTIME freed all the current_ variables, except
         * current_error_trace.
         */
    }
    num_error--;

} /* secure_apply_error() */

/*-------------------------------------------------------------------------*/
svalue_t *
secure_apply_ob (string_t *fun, object_t *ob, int num_arg, Bool external)

/* Aliases:
 *   secure_apply(fun, ob, num_arg) == secure_apply_ob(fun, ob, num_arg, FALSE)
 *   secure_callback(fun, ob, num_arg) == secure_apply_ob(fun, ob, num_arg, TRUE)
 *
 * Call function <fun> in <ob>ject with <num_arg> arguments pushed
 * onto the stack (<inter_sp> points to the last one). static and protected
 * functions can't be called from the outside.
 * secure_apply_ob() takes care of calling shadows where necessary.
 *
 * If <external> is TRUE, it means that this call is due to some external
 * event (like an ERQ message) instead of being caused by a running program.
 * The effect of this flag is that the error handling is like for a normal
 * function call (clearing the eval costs before calling runtime_error()).
 *
 * secure_apply_ob() returns a pointer to the function result when the call
 * was successfull, or NULL on failure. The arguments are popped in any case.
 * The result pointer, if returned, points to a static area which will be
 * overwritten with the next secure_apply_ob().
 *
 * The function call will swap in the object and also unset its reset status.
 *
 * Errors during the execution are caught (this is the big difference
 * to sapply()/apply()) and cause secure_apply_ob() to return NULL.
 */

{
    struct error_recovery_info error_recovery_info;
    svalue_t *save_sp;
    struct control_stack *save_csp;
    svalue_t *result;

    if (ob->flags & O_DESTRUCTED)
        return NULL;

    error_recovery_info.rt.last = rt_context;
    error_recovery_info.rt.type = ERROR_RECOVERY_APPLY;
    rt_context = (rt_context_t *)&error_recovery_info.rt;
    save_sp = inter_sp;
    save_csp = csp;
    if (setjmp(error_recovery_info.con.text))
    {
        secure_apply_error(save_sp - num_arg, save_csp, external);
        result = NULL;
    }
    else
    {
        if (external)
            mark_start_evaluation();
        result = sapply(fun, ob, num_arg);
        if (external)
            mark_end_evaluation();
    }
    rt_context = error_recovery_info.rt.last;
    return result;
} /* secure_apply_ob() */

/*-------------------------------------------------------------------------*/
svalue_t *
apply_master_ob (string_t *fun, int num_arg, Bool external)

/* Aliases:
 *   apply_master(fun, num_arg) == apply_master_ob(fun, num_arg, FALSE)
 *   callback_master(fun, num_arg) == apply_master_ob(fun, num_arg, TRUE)
 *
 * Call function <fun> in the master object with <num_arg> arguments pushed
 * onto the stack (<inter_sp> points to the last one). static and protected
 * functions can be called from the outside. The function takes care
 * of calling shadows where necessary.
 *
 * If <external> is TRUE, it means that this call is due to some external
 * event (like an ERQ message) instead of being caused by a running program.
 * The effect of this flag is that the error handling is like for a normal
 * function call (clearing the eval costs before calling runtime_error()).
 *
 * apply_master_object() returns a pointer to the function result when the
 * call was successfull, or NULL on failure. The arguments are popped in
 * any case.
 * The result pointer, if returned, points to a static area which will be
 * overwritten with the next apply_master_object().
 *
 * The function makes sure that there is a master object to be called. If
 * necessary, a new one is compiled or, failing that, an old one is
 * reactivated.
 *
 * Errors during the execution are caught and case the function to
 * return NULL.
 *
 * The function operates on an execution tick reserve of MASTER_RESERVED_COST
 * which is used then the normal evaluation cost is already too high.
 */

{
    static int eval_cost_reserve = MASTER_RESERVED_COST;
      /* Available eval_cost reserver. If needed, the reserve is halved
       * for the duration of the apply to establish a protection against
       * an endless recursion of master calls.
       */

    volatile Bool reserve_used = MY_FALSE;

    struct error_recovery_info error_recovery_info;
    svalue_t *save_sp;
    struct control_stack *save_csp;
    svalue_t *result;

    /* Get the master object. */
    assert_master_ob_loaded();

    /* Tap into the eval_cost reserve if the end is near */
    if (   (max_eval_cost && eval_cost > max_eval_cost - MASTER_RESERVED_COST)
        && eval_cost_reserve > 1)
    {
        eval_cost -= eval_cost_reserve;
        assigned_eval_cost -= eval_cost_reserve;
        eval_cost_reserve >>= 1;
        reserve_used = MY_TRUE;
    }

    /* Setup the the error recovery and call the function */
    error_recovery_info.rt.last = rt_context;
    error_recovery_info.rt.type = ERROR_RECOVERY_APPLY;
    rt_context = (rt_context_t *)&error_recovery_info.rt;
    save_sp = inter_sp;
    save_csp = csp;
    if (setjmp(error_recovery_info.con.text))
    {
        secure_apply_error(save_sp - num_arg, save_csp, external);
        printf("%s Error in master_ob->%s()\n", time_stamp(), get_txt(fun));
        debug_message("%s Error in master_ob->%s()\n", time_stamp(), get_txt(fun));
        result = NULL;
    }
    else
    {
        if (external)
            mark_start_evaluation();
        result = sapply_int(fun, master_ob, num_arg, MY_TRUE, MY_FALSE);
        if (external)
            mark_end_evaluation();
    }

    /* Free the reserve if we used it */
    if (reserve_used)
    {
        eval_cost_reserve <<= 1;
        assigned_eval_cost = eval_cost += eval_cost_reserve;
    }
    rt_context = error_recovery_info.rt.last;

    return result;
} /* apply_master_ob() */

/*-------------------------------------------------------------------------*/
void
assert_master_ob_loaded (void)

/* Make sure that there is a master object <master_ob>.
 * If necessary, a new master is compiled, or, failing that, an old
 * destructed one is reactivated. If everything fails, the driver exits.
 *
 * Note that the function may be called recursively:
 *  - While calling a master function from yyparse() (e.g. log_error()),
 *    the master self-destructs and then causes an error.
 *  - Another possibility is that some driver hook invokes some
 *    function that uses apply_master_ob().
 *  - The master object might have been reloaded without noticing that
 *    it is the master. This could happen when there already was a call to
 *    assert_master_ob_loaded(), clearing master_ob, and the master
 *    inherits itself. Partial working self-inheritance is possible if
 *    the H_INCLUDE_DIRS hook does something strange.
 */

{
    static Bool inside = MY_FALSE;
      /* Flag to notice recursive calls */

    static object_t *destructed_master_ob = NULL;
      /* Old, destructed master object */

    int i;

    if (!master_ob || master_ob->flags & O_DESTRUCTED)
    {
        /* The master object has been destructed. Free our reference,
         * and load a new one.
         */
        if (inside || !master_ob)
        {
            object_t *ob;
            object_t *prev;
            Bool newly_removed = MY_FALSE;
              /* TRUE if the old master was on the list of newly
               * destructed objects. That is important to know
               * because then it still has all its variables.
               */

            /* A recursive call while loading the master, or there
             * was no master to begin with.
             * If there is a destructed master, reactivate that
             * one, else stop the driver.
             */

            if (!destructed_master_ob)
            {
                add_message("Failed to load master object '%s'!\n"
                           , master_name);
                // fatal() may call us again. But fatal() and this function
                // are secured against recursion so it should be safe to call
                // it from here (otherwise we would not get a core dump...).
                fatal("Failed to load master object '%s'!\n",
                      master_name);
            }

            /* If we come here, we had a destructed master and failed
             * to load a new one. Now try to reactivate the
             * old one again.
             *
             * We don't have to reactivate any destructed inherits, though:
             * as long as the master references their programs, that's all
             * we need.
             */

            /* First, make sure that there is no half-done object
             * using the masters name.
             */
            if ( NULL != (ob = find_object(master_name_str)) )
            {
                destruct(ob);
            }

            /* Get the destructed master */
            ob = destructed_master_ob;
            destructed_master_ob = NULL;

            /* Remove the destructed master from the list
             * of newly destructed objects or destructed objects.
             */
            if (newly_destructed_objs != NULL)
            {
                if (ob == newly_destructed_objs)
                {
                    newly_destructed_objs = ob->next_all;
                    newly_removed = MY_TRUE;
                    num_newly_destructed--;
#ifdef CHECK_OBJECT_REF
                    {
                        object_shadow_t * sh = newly_destructed_obj_shadows;
                        newly_destructed_obj_shadows = sh->next;
                        xfree(sh);
                    }
#endif /* CHECK_OBJECT_REF */
                }
                else
                {
#ifdef CHECK_OBJECT_REF
                    object_shadow_t *sprev;
#endif /* CHECK_OBJECT_REF */
                    for ( prev = newly_destructed_objs
#ifdef CHECK_OBJECT_REF
                        , sprev = newly_destructed_obj_shadows
#endif /* CHECK_OBJECT_REF */
                        ; prev && prev->next_all != ob
                        ; prev = prev->next_all
#ifdef CHECK_OBJECT_REF
                        , sprev = sprev->next
#endif /* CHECK_OBJECT_REF */
                        ) NOOP;
                    if (prev)
                    {
                        prev->next_all = ob->next_all;
                        newly_removed = MY_TRUE;
                        num_newly_destructed--;
#ifdef CHECK_OBJECT_REF
                        {
                            object_shadow_t *sh = sprev->next;
                            sprev->next = sh->next;
                            xfree(sh);
                        }
#endif /* CHECK_OBJECT_REF */
                    }
                }
            }
            if (!newly_removed && destructed_objs != NULL)
            {
                if (ob == destructed_objs)
                {
                    destructed_objs = ob->next_all;
                    if (destructed_objs)
                        destructed_objs->prev_all = NULL;
                    num_destructed--;
#ifdef CHECK_OBJECT_REF
                    {
                        object_shadow_t * sh = destructed_obj_shadows;
                        destructed_obj_shadows = sh->next;
                        xfree(sh);
                    }
#endif /* CHECK_OBJECT_REF */
                }
                else
                {
#ifdef CHECK_OBJECT_REF
                    object_shadow_t *sprev;
#endif /* CHECK_OBJECT_REF */
                    for ( prev = destructed_objs
#ifdef CHECK_OBJECT_REF
                        , sprev = destructed_obj_shadows
#endif /* CHECK_OBJECT_REF */
                        ; prev && prev->next_all != ob
                        ; prev = prev->next_all
#ifdef CHECK_OBJECT_REF
                        , sprev = sprev->next
#endif /* CHECK_OBJECT_REF */
                        ) NOOP;
                    if (prev)
                    {
                        prev->next_all = ob->next_all;
                        if (prev->next_all)
                            prev->next_all->prev_all = prev;
                        num_destructed--;
#ifdef CHECK_OBJECT_REF
                        {
                            object_shadow_t *sh = sprev->next;
                            sprev->next = sh->next;
                            xfree(sh);
                        }
#endif /* CHECK_OBJECT_REF */
                    }
                }
            }
            ob->flags &= ~O_DESTRUCTED;

            /* Restore the old masters variable space.
             * Remember: as long as the objects are in the 'newly destructed'
             * list, they still have all variables.
             */
            if (!newly_removed && ob->prog->num_variables)
            {
                int save_privilege = malloc_privilege;
                int j;
                svalue_t *v;

                malloc_privilege = MALLOC_SYSTEM;
                ob->variables = v = (svalue_t *)
                    xalloc(sizeof *v * ob->prog->num_variables);
                malloc_privilege = save_privilege;
                for (j = ob->prog->num_variables; --j >= 0; )
                    *v++ = const0;
            }

            /* Reenter the object into the various lists */
            enter_object_hash(ob);
            ob->next_all = obj_list;
            ob->prev_all = NULL;
            if (obj_list)
                obj_list->prev_all = ob;
            obj_list = ob;
            if (!obj_list_end)
                obj_list_end = ob;
            num_listed_objs++;
            ob->super = NULL;
            ob->contains = NULL;
            ob->next_inv = NULL;

            /* Reactivate the old master */
            master_ob = ref_object(ob, "assert_master_ob_loaded");
            if (current_object == &dummy_current_object_for_loads)
                current_object = master_ob;
            push_number(inter_sp, newly_removed);
            sapply_int(STR_REACTIVATE, ob, 1, MY_TRUE, MY_FALSE);
            push_number(inter_sp, 2 - (newly_removed ? 1 : 0));
            sapply_int(STR_INAUGURATE, ob, 1, MY_TRUE, MY_FALSE);
            fprintf(stderr, "%s Old master reactivated.\n", time_stamp());
            inside = MY_FALSE;
            return;

        } /* if (inside || !master_obj) */

        /* A normal call to assert_master_ob_loaded: just load a new one */

        fprintf(stderr, "%s assert_master_ob_loaded: Reloading master '%s'\n"
               , time_stamp(), master_name);
        destructed_master_ob = master_ob;

        /* Clear the pointer, in case the load failed.
         */
        master_ob = NULL;
        inside = MY_TRUE;
        if (!current_object)
        {
            current_object = &dummy_current_object_for_loads;
        }

        /* Free the driver hooks.
         */
        for (i = NUM_DRIVER_HOOKS; i--;)
        {
            assign_svalue(driver_hook+i, &const0);
        }

        init_telopts();

        master_ob = get_object(master_name_str);
        if (current_object == &dummy_current_object_for_loads)
        {
            /* This might be due to the above assignment, or to setting
             * it in the backend.
             */
            current_object = master_ob;
        }

        initialize_master_uid();
        push_number(inter_sp, 3);
        apply_master(STR_INAUGURATE, 1);
        assert_master_ob_loaded();
          /* ...in case inaugurate_master() destructed this object again */
        inside = MY_FALSE;
        ref_object(master_ob, "assert_master_ob_loaded");

        if (destructed_master_ob)
            free_object(destructed_master_ob, "assert_master_ob_loaded");

        fprintf(stderr, "%s Reloading done.\n", time_stamp());
    }

    /* Master exists. Nothing to see here, move along... */

} /* assert_master_ob_loaded() */

/*-------------------------------------------------------------------------*/
void
int_call_lambda (svalue_t *lsvp, int num_arg, Bool allowRefs, Bool external)

/* Call the closure <lsvp> with <num_arg> arguments on the stack. On
 * success, the arguments are replaced with the result, else an errorf()
 *
 * If <allowRefs> is TRUE, references may be passed as extended varargs
 * ('(varargs mixed *)'). Currently this is used only for simul efuns.
 * is generated.
 *
 * If <external> is TRUE, the eval_instruction is called to execute the
 * closure. Otherwise inter_pc is just set and int_call_lambda returns
 * (this is only valid for non-alien lfun or lambda closures).
 */

{
#  define CLEAN_CSP \
        previous_ob = csp->prev_ob; \
        current_object = csp->ob; \
        pop_control_stack();
  /* Macro to undo all the call preparations in case the closure
   * can't be called after all.
   */

    svalue_t *sp;
    lambda_t *l = lsvp->u.lambda;

    sp = inter_sp;

    /* Basic setup for the new control frame.
     * If the closure can't be called, all this has to be undone
     * using the macro CLEAN_CSP.
     */
#ifdef USE_NEW_INLINES
    push_control_stack(sp, inter_pc, inter_fp, inter_context);
#else
    push_control_stack(sp, inter_pc, inter_fp);
#endif /* USE_NEW_INLINES */
    csp->ob = current_object;
    csp->prev_ob = previous_ob;
    csp->num_local_variables = num_arg;
    previous_ob = current_object;

    switch(lsvp->x.closure_type)
    {

    case CLOSURE_LFUN:  /* --- lfun closure --- */
      {
        Bool      extra_frame;

        /* Can't call from a destructed object */
        if (l->ob->flags & O_DESTRUCTED)
        {
            /* inter_sp == sp */
            CLEAN_CSP
            push_number(inter_sp, 0);
            return;
        }

        /* Reference the bound and the originating object */
        l->ob->time_of_ref = current_time;
        l->function.lfun.ob->time_of_ref = current_time;
        l->function.lfun.ob->flags &= ~O_RESET_STATE;

        current_object = l->ob;

        /* Can't call a function in a destructed object */
        if (l->function.lfun.ob->flags & O_DESTRUCTED)
        {
            /* inter_sp == sp */
            CLEAN_CSP
            push_number(inter_sp, 0);
            return;
        }

        /* Make the objects resident */
        if ( (   current_object->flags & O_SWAPPED
              && load_ob_from_swap(current_object) < 0)
         ||  (   l->function.lfun.ob->flags & O_SWAPPED
              && load_ob_from_swap(l->function.lfun.ob) < 0)
           )
        {
            /* inter_sp == sp */
            CLEAN_CSP
            errorf("Out of memory\n");
            /* NOTREACHED */
            return;
        }

#ifdef DEBUG
        if (l->function.lfun.index >= l->function.lfun.ob->prog->num_functions)
            fatal("Calling non-existing lfun closure #%hu in program '%s' "
                  "with %hu functions.\n"
                 , l->function.lfun.index
                 , get_txt(l->function.lfun.ob->prog->name)
                 , l->function.lfun.ob->prog->num_functions
                );
#endif

        /* If the object creating the closure wasn't the one in which
         * it will be executed, we need to record the fact in a second
         * 'dummy' control frame. If we didn't, major security holes
         * open up.
         */

        if (l->ob != l->function.lfun.ob)
        {
            extra_frame = MY_TRUE;
            csp->extern_call = MY_TRUE;
            csp->funstart = NULL;
#ifdef USE_NEW_INLINES
            push_control_stack(sp, 0, inter_fp, inter_context);
#else
            push_control_stack(sp, 0, inter_fp);
#endif /* USE_NEW_INLINES */
            csp->ob = current_object;
            csp->prev_ob = previous_ob;
            csp->num_local_variables = num_arg;
            previous_ob = current_object;
            external = MY_TRUE;
        }
        else
            extra_frame = MY_FALSE;

        /* Finish the setup of the control frame.
         * This is a real inter-object call.
         */
        csp->extern_call = external;
        current_object = l->function.lfun.ob;
        current_prog = current_object->prog;
        /* inter_sp == sp */
        setup_new_frame(l->function.lfun.index, l->function.lfun.inhProg);
#ifdef USE_NEW_INLINES
        if (l->function.lfun.context_size > 0)
            inter_context = l->context;
#endif /* USE_NEW_INLINES */
        if (external)
            eval_instruction(FUNCTION_CODE(csp->funstart), inter_sp);
        else
            inter_pc = FUNCTION_CODE(csp->funstart);

        /* If l->ob selfdestructs during the call, l might have been
         * deallocated at this point!
         */

        /* If necessary, remove the second control frame */
        if (extra_frame)
        {
            current_object = csp->ob;
            previous_ob = csp->prev_ob;
            pop_control_stack();
        }

        /* The result is on the stack (inter_sp) */
        return;
      }

    case CLOSURE_IDENTIFIER:  /* --- variable closure --- */
      {
        short i; /* the signed variant of lambda_t->function.index */

        CLEAN_CSP  /* no call will be done */

        /* Ignore any arguments passed to a variable closure. */
        pop_n_elems(num_arg);

        /* Don't use variables in a destructed object */
        if (l->ob->flags & O_DESTRUCTED)
        {
            push_number(inter_sp, 0);
            return;
        }

        /* Make the object resident */
        if (   (l->ob->flags & O_SWAPPED)
             && load_ob_from_swap(l->ob) < 0
           )
        {
            errorf("Out of memory.\n");
            /* NOTREACHED */
            return;
        }

        /* Do we have the variable? */
        if ( (i = (short)l->function.var_index) < 0)
        {
            errorf("Variable not inherited\n");
            /* NOTREACHED */
            return;
        }

        l->ob->time_of_ref = current_time;
#ifdef DEBUG
        if (!l->ob->variables)
            fatal("%s Fatal: call_lambda on variable for object %p '%s' "
                  "w/o variables, index %d\n"
                 , time_stamp(), l->ob, get_txt(l->ob->name), i);
#endif
        assign_svalue_no_free(++sp, &l->ob->variables[i]);
        inter_sp = sp;
        return;
      }

    case CLOSURE_PRELIMINARY:
        /* no valid current_object: fall out of the switch
         * and let the error handling clean up the control
         * stack.
         */
        break;

    case CLOSURE_BOUND_LAMBDA:  /* --- bound lambda closure --- */
      {
        lambda_t *l2;

        /* Deref the closure and then treat the resulting unbound
         * lambda like a normal lambda
         */
        l2 = l->function.lambda;
        l2->ob = l->ob;
        l = l2;
      }
      /* FALLTHROUGH */

    case CLOSURE_UNBOUND_LAMBDA:
      if (lsvp->x.closure_type == CLOSURE_UNBOUND_LAMBDA)
      {
          if (external)
              break;

          /* Internal call of an unbound closure.
           * Bind it on the fly.
           */
          l->ob = current_object;
      }
      /* FALLTHROUGH */

    case CLOSURE_LAMBDA:
      {
        fun_hdr_p funstart;

        /* Can't call from a destructed object */
        if (l->ob->flags & O_DESTRUCTED)
        {
            /* inter_sp == sp */
            CLEAN_CSP
            push_number(inter_sp, 0);
            return;
        }

        current_object = l->ob;

        /* Make the object resident */
        if (current_object->flags & O_SWAPPED
         && load_ob_from_swap(current_object) < 0)
        {
            /* inter_sp == sp */
            CLEAN_CSP
            errorf("Out of memory\n");
            /* NOTREACHED */
            return;
        }

        /* Reference the object */
        current_object->time_of_ref = current_time;
        current_object->flags &= ~O_RESET_STATE;

        /* Finish the setup */

        current_prog = current_object->prog;
        current_lambda = *lsvp; addref_closure(lsvp, "call_lambda()");
        variable_index_offset = 0;
        function_index_offset = 0;
        funstart = l->function.code + 1;
        csp->funstart = funstart;
        csp->extern_call = external;
        sp = setup_new_frame2(funstart, sp, allowRefs, MY_TRUE);
        current_variables = current_object->variables;
        current_strings = current_prog->strings;
        if (external)
            eval_instruction(FUNCTION_CODE(funstart), sp);
        else
        {
            inter_pc = FUNCTION_CODE(funstart);
            inter_sp = sp;
        }
        /* The result is on the stack (inter_sp). */
        return;
      }

    default: /* --- efun-, simul efun-, operator closure */
      {
        int i;  /* the closure type */

        current_object = lsvp->u.ob;
        /* Can't call from a destructed object */
        if (current_object->flags & O_DESTRUCTED)
        {
            /* inter_sp == sp */
            CLEAN_CSP
            push_number(inter_sp, 0);
            return;
        }

        /* Make the object resident */
        if (current_object->flags & O_SWAPPED
         && load_ob_from_swap(current_object) < 0)
        {
            /* inter_sp == sp */
            CLEAN_CSP
            errorf("Out of memory\n");
            /* NOTREACHED */
            return;
        }

        /* Reference the object */
        current_object->time_of_ref = current_time;

        i = lsvp->x.closure_type;
        if (i < CLOSURE_SIMUL_EFUN)
        {
            /* It's an operator or efun */

            if (i == CLOSURE_EFUN + F_UNDEF)
            {
                /* The closure was discovered to be bound to a destructed
                 * object and thus disabled.
                 * This situation should no longer happen - in all situations
                 * the closure should be zeroed out.
                 */
                CLEAN_CSP
                push_number(inter_sp, 0);
                return;
            }

            i -= CLOSURE_EFUN;
              /* Efuns have now a positive value, operators a negative one.
               */

            if (i >= 0
             || instrs[i -= CLOSURE_OPERATOR-CLOSURE_EFUN].min_arg)
            {
                /* To call an operator or efun, we have to construct
                 * a small piece of program with this instruction.
                 */
                bytecode_t code[9];    /* the code fragment */
                bytecode_p p;          /* the code pointer */

                int min, max, def;

                min = instrs[i].min_arg;
                max = instrs[i].max_arg;
                p = code;

                /* Fix up the number of arguments passed */
                if (num_arg < min)
                {
                    /* Add some arguments */

                    int f;

                    if (num_arg == min-1
                     && 0 != (def = instrs[i].Default) && def != -1)
                    {
                        /* We lack one argument for which a default
                         * is provided.
                         */
                        if (instrs[def].prefix)
                            *p++ = instrs[def].prefix;
                        *p++ = instrs[def].opcode;
                        max--;
                        min--;
                    }
                    else
                    {
                        /* Maybe there is a fitting replacement efun */
                        f = proxy_efun(i, num_arg);
                        if (f >= 0)
                            /* Yup, use that one */
                            i = f;
                        else
                        {
                            /* Nope. */
                            csp->extern_call = MY_TRUE;
                            inter_pc = csp->funstart = EFUN_FUNSTART;
                            csp->instruction = i;
                            errorf("Too few arguments to %s\n", instrs[i].name);
                        }
                    }
                }
                else if (num_arg > 0xff || (num_arg > max && max != -1))
                {
                    csp->extern_call = MY_TRUE;
                    inter_pc = csp->funstart = EFUN_FUNSTART;
                    csp->instruction = i;
                    errorf("Too many arguments to %s\n", instrs[i].name);
                }

                /* Store the instruction code */
                if (instrs[i].prefix)
                    *p++ = instrs[i].prefix;
                *p++ = instrs[i].opcode;

                /* And finally the return instruction */
                if ( instrs[i].ret_type.typeflags == TYPE_VOID )
                    *p++ = F_RETURN0;
                else
                    *p++ = F_RETURN;

                csp->instruction = i;
                csp->funstart = EFUN_FUNSTART;
                csp->num_local_variables = 0;
                inter_fp = sp - num_arg + 1;
#ifdef USE_NEW_INLINES
                inter_context = NULL;
#endif /* USE_NEW_INLINES */
                tracedepth++; /* Counteract the F_RETURN */
                eval_instruction(code, sp);
                /* The result is on the stack (inter_sp) */
                return;
            }
            else
            {
                /* It is an operator or syntactic marker: fall through
                 * to uncallable closure type.
                 */
                break;
            }
        }
        else
        {
            /* simul_efun */
            object_t *ob;

            /* Mark the call as sefun closure */
            inter_pc = csp->funstart = SIMUL_EFUN_FUNSTART;

            /* Get the simul_efun object */
            if ( !(ob = simul_efun_object) )
            {
                /* inter_sp == sp */
                if (!assert_simul_efun_object()
                 || !(ob = simul_efun_object)
                   )
                {
                    csp->extern_call = MY_TRUE;
                    errorf("Couldn't load simul_efun object\n");
                    /* NOTREACHED */
                    return;
                }
            }
            call_simul_efun(i - CLOSURE_SIMUL_EFUN, ob, num_arg);
            CLEAN_CSP
        }
        /* The result is on the stack (inter_sp) */
        return;
      }

    }

    CLEAN_CSP
    errorf("Uncallable closure\n");
    /* NOTREACHED */
    return;

#   undef CLEAN_CSP
} /* int_call_lambda() */

/*-------------------------------------------------------------------------*/
svalue_t *
secure_call_lambda (svalue_t *closure, int num_arg, Bool external)

/* Aliases:
 *   secure_apply_lambda(fun, num_arg)
 *     == secure_call_lambda(fun, num_arg, FALSE)
 *   secure_callback_lambda(fun, num_arg)
 *     == secure_call_lambda(fun, num_arg, TRUE)
 *
 * Call the closure <closure> with <num_arg> arguments on the stack.
 * On success, the functions returns a pointer to the result in the
 * global apply_return_value, on failure it returns NULL. The arguments are
 * removed in either case.
 *
 * If <external> is TRUE, it means that this call is due to some external
 * event (like an ERQ message) instead of being caused by a running program.
 * The effect of this flag is that the error handling is like for a normal
 * function call (clearing the eval costs before calling runtime_error()).
 *
 * This error recovery is the difference to call_lambda().
 */

{
    struct error_recovery_info error_recovery_info;
    svalue_t *save_sp;
    struct control_stack *save_csp;
    svalue_t *result;

    error_recovery_info.rt.last = rt_context;
    error_recovery_info.rt.type = ERROR_RECOVERY_APPLY;
    rt_context = (rt_context_t *)&error_recovery_info.rt;
    save_sp = inter_sp;
    save_csp = csp;

    if (setjmp(error_recovery_info.con.text))
    {
        secure_apply_error(save_sp - num_arg, save_csp, external);
        result = NULL;
    }
    else
    {
        if (external)
            mark_start_evaluation();
        call_lambda(closure, num_arg);
        transfer_svalue((result = &apply_return_value), inter_sp);
        inter_sp--;
        if (external)
            mark_end_evaluation();
    }
    rt_context = error_recovery_info.rt.last;
    return result;
} /* secure_call_lambda() */

/*-------------------------------------------------------------------------*/
static void
call_simul_efun (unsigned int code, object_t *ob, int num_arg)

/* Call the simul_efun <code> in the sefun object <ob> with <num_arg>
 * arguments on the stack. If it can't be found in the <ob>ject, the
 * function queries the auxiliary sefun objects in <simul_efun_vector>.
 *
 * The function is looked up in the objects by name because its original
 * entry in the simul_efun_table[] has been marked as "discarded".
 *
 * Leave the result on the stack on return.
 */

{
    string_t *function_name;

    function_name = simul_efunp[code].name;

    /* First, try calling the function in the given object */
    if (!int_apply(function_name, ob, num_arg, MY_FALSE, MY_FALSE))
    {
        /* Function not found: try the alternative sefun objects */
        if (simul_efun_vector)
        {
            p_int i;
            svalue_t *v;

            i = VEC_SIZE(simul_efun_vector);
            for (v = simul_efun_vector->item+1 ; ; v++)
            {
                if (--i <= 0 || v->type != T_STRING)
                {
                    errorf("Calling a vanished simul_efun\n");
                    return;
                }
                if ( !(ob = get_object(v->u.str)) )
                    continue;
                if (int_apply(function_name, ob, num_arg, MY_FALSE, MY_FALSE))
                    return;
            }
            return;
        }
        errorf("Calling a vanished simul_efun\n");
        return;
    }
    /*
     * The result of the function call is on the stack.
     */
} /* call_simul_efun() */

/*-------------------------------------------------------------------------*/
void
call_function (program_t *progp, int fx)

/* Call the function <fx> in program <progp> for the current_object.
 * This is done with no frame set up. No arguments are passed,
 * returned values are removed.
 *
 * Right now this function is used just for heartbeats, and the
 * way of calling prevents shadows from being called.
 */

{
#ifdef USE_NEW_INLINES
    push_control_stack(inter_sp, inter_pc, inter_fp, inter_context);
#else
    push_control_stack(inter_sp, inter_pc, inter_fp);
#endif /* USE_NEW_INLINES */
    csp->ob = current_object;
    csp->prev_ob = previous_ob;
#ifdef DEBUG
    if (csp != CONTROL_STACK)
        fatal("call_function with bad csp\n");
#endif
    csp->num_local_variables = 0;
    current_prog = progp;
    setup_new_frame(fx, NULL);
    previous_ob = current_object;
    tracedepth = 0;
    eval_instruction(FUNCTION_CODE(csp->funstart), inter_sp);
    free_svalue(inter_sp--);  /* Throw away the returned result */
} /* call_function() */

/*-------------------------------------------------------------------------*/
int
get_line_number (bytecode_p p, program_t *progp, string_t **namep)

/* Look up the line number for address <p> within the program <progp>.
 * Result is the line number, and *<namep> is set to the name of the
 * source resp. include file.
 *
 * If the code was generated from an included file, and if the name lengths
 * allow it, the returned name is "<program name> (<include filename>)".
 * In this case, the returned *<namep> points to an untabled string.
 *
 * In either case, the string returned in *<namep> has one reference
 * added.
 *
 * TODO: (an old comment which might no longer be true): This can be done
 * TODO:: much more efficiently, but that change has low priority.)
 */
{
    /* Datastructure to keep track of included files */
    struct incinfo
    {
        string_t *name;         /* Name of parent file */
        struct incinfo *super;  /* Pointer to parent entry */
        int super_line;         /* Line number within parent file */
    };

    p_int offset;          /* (Remaining) program offset to resolve */
    int i;                 /* Current line number */
    include_t *includes;   /* Pointer to the next include info */
    struct incinfo *inctop = NULL;  /* The include information stack. */
    int relocated_from = 0;
    int relocated_to = -1;
    Bool used_system_mem;
      /* TRUE if the line numbers needed SYSTEM privilege to be swapped in,
       * because this means that afterwards they need to be deallocated
       * again.
       */

    if (!progp || !p)
    {
        *namep = ref_mstring(STR_UNDEFINED);
        return 0;
    }

    used_system_mem = MY_FALSE;

    /* Get the line numbers */
    if (!progp->line_numbers)
    {
        if (!load_line_numbers_from_swap(progp))
        {
            /* Uhhmm, out of memory - try to pull some rank */

            int save_privilege;
            Bool rc;

            used_system_mem = MY_TRUE;
            save_privilege = malloc_privilege;
            malloc_privilege = MALLOC_SYSTEM;
            rc = load_line_numbers_from_swap(progp);
            malloc_privilege = save_privilege;
            if (!rc)
            {
                *namep = ref_mstring(STR_UNDEFINED);
                return 0;
            }
        }
    }

    /* Get the offset within the program */
    offset = (p - progp->program);
    if (p < progp->program || p > PROGRAM_END(*progp))
    {
        printf("%s get_line_number(): Illegal offset %"PRIdPINT" in object %s\n"
              , time_stamp(), offset, get_txt(progp->name));
        debug_message("%s get_line_number(): Illegal offset %"PRIdPINT
                      " in object %s\n",
                      time_stamp(), offset, get_txt(progp->name));
        *namep = ref_mstring(STR_UNDEFINED);
        return 0;
    }

    includes = progp->includes;

    /* Decode the line number information until the line number
     * for offset is found. We do this by reading the line byte codes,
     * counting up the line number <i> while decrementing the <offset>.
     * If the offset becomes <= 0, we found the line.
     */
    for (i = 0, p = progp->line_numbers->line_numbers; ; )
    {
        int o;

        o = GET_CODE(p);

        if (o <= 63)  /* 0x00..0x3F */
        {
            if (o >= LI_MAXOFFSET)  /* 0x3b..0x3f */
            {
                if (o != LI_MAXOFFSET)
                {
                    switch (o)
                    {

                    case LI_BACK:
                      {
                        unsigned int off;

                        p++;
                        off = GET_CODE(p);
                        i -= off+1;
                        break;
                      }

                    case LI_INCLUDE:
                      {
                        /* Included file: push the information */

                        struct incinfo *inc_new;

                        /* Find the next include which generated code.
                         * We know that there is one.
                         */
                        while (includes->depth < 0) includes++;

                        i++;
                        inc_new = xalloc(sizeof *inc_new);
                        /* TODO: What if this fails? */
                        inc_new->name = includes->filename;
                        includes++;
                        inc_new->super = inctop;
                        inc_new->super_line = i;
                        inctop = inc_new;
                        i = 0;
                        break;
                      }

                    case LI_INCLUDE_END:
                      {
                        /* End of include: retrieve old position */

                        struct incinfo *inc_old;

                        inc_old = inctop;
                        i = inc_old->super_line;
                        inctop = inc_old->super;
                        xfree(inc_old );
                        break;
                      }

                    case LI_L_RELOCATED:
                      {
                        int h, l;

                        p++;
                        h = GET_CODE(p);
                        p++;
                        l = GET_CODE(p);
                        i -= 2;
                        relocated_to = i;
                        relocated_from = relocated_to - ((h << 8) + l);
                        p++; /* skip trailing LI_L_RELOCATED */
                        break;
                      }
                    }
                }
                else /* 0x3c */
                {
                    offset -= o;
                }
            }
            else  /* 0x00..0x3b */
            {
                offset -= o;
                i++;
                if (offset <= 0)
                    break;
            }
        }
        else if (o <= 127)  /* 0x40..0x7f */
        {
            /* Simple entry: count offset and lines */
            offset -= (o&7) + 1;
            i += (o>>3) - 6;
            if (offset <= 0)
                break;
        }
        else if (o >= 256-LI_MAXEMPTY)  /* 0xE0 .. 0xFF */
        {
            i += 256-o;
        }
        else /* 0x80 .. 0xDF */
        {
            i -= 2;
            relocated_from = (relocated_to = i) - (o - LI_RELOCATED);
        }

        /* Get the next line number bytecode */
        p++;
    } /* line number search */

    if (i == relocated_to + 1)
        i = relocated_from + 1;
        /* Perform the announced relocation */

    /* Here, i is the line number, and if inctop is not NULL, the
     * code originates from the included file pointed to by inctop.
     * In either case, set *<namep> to the pointer to the name
     * of the file.
     */

    if (inctop)
    {
        /* The code was included */

        string_t * namebuf;

        namebuf = alloc_mstring(mstrsize(inctop->name) + mstrsize(progp->name)
                                                       + 3);
        if (namebuf)
        {
            sprintf(get_txt(namebuf), "%s (%s)"
                           , get_txt(progp->name), get_txt(inctop->name));
            *namep = namebuf;
        }
        else
        {
            /* No memory for the new string - improvise */
            *namep = ref_mstring(inctop->name);
        }

        /* Free the include stack structures */
        do {
            struct incinfo *inc_old;

            inc_old = inctop;
            inctop = inc_old->super;
            xfree(inc_old);
        } while (inctop);
    }
    else
    {
        /* Normal code */

        *namep = ref_mstring(progp->name);
    }

    if (used_system_mem)
    {
        /* We used SYSTEM priviledged memory - now we have to return it.
         */

        total_prog_block_size -= progp->line_numbers->size;
        total_bytes_unswapped -= progp->line_numbers->size;
        xfree(progp->line_numbers);
        progp->line_numbers = NULL;
        reallocate_reserved_areas();
    }

    /* Return the line number */
    return i;
} /* get_line_number() */

/*-------------------------------------------------------------------------*/
int
get_line_number_if_any (string_t **name)

/* Look up the line number for the current execution address.
 * Result is the line number, and *<name> is set to the name of the
 * source resp. include file.
 *
 * The function recognizes sefun and lambda closures, the latter return
 * the approximate position offset of the offending instruction within
 * the closure.
 *
 * *<name> may point to an untabled string; and in any case has its
 * own reference.
 */

{
    if (csp >= &CONTROL_STACK[0] && csp->funstart == SIMUL_EFUN_FUNSTART)
    {
        *name = ref_mstring(STR_SEFUN_CLOSURE);
        return 0;
    }

    if (csp >= &CONTROL_STACK[0] && csp->funstart == EFUN_FUNSTART)
    {
        static char buf[256];
        char *iname;

        iname = instrs[csp->instruction].name;
        if (iname)
        {
            buf[sizeof buf - 1] = '\0';
            buf[0] = '#';
            buf[1] = '\'';
            strcpy(buf+2, iname);
            if (buf[sizeof buf - 1] != '\0')
                fatal("interpret:get_line_number_if_any(): "
                      "buffer overflow.\n");
            memsafe(*name = new_mstring(buf), strlen(buf), "instruction name");
        }
        else
            *name = ref_mstring(STR_EFUN_CLOSURE);

        return 0;
    }

    if (current_prog)
    {
        if (csp->funstart < current_prog->program
         || csp->funstart > PROGRAM_END(*current_prog))
        {
            static char name_buffer[24];
            string_t * location, *tmp;
            lambda_t * l;

            sprintf(name_buffer, "<lambda 0x%6p>", csp->funstart);
            memsafe(*name = new_mstring(name_buffer), strlen(name_buffer)
                   , "lambda name");
            /* Find the beginning of the lambda structure.*/
            l = (lambda_t *)( (PTRTYPE)(csp->funstart - 1)
                             - offsetof(lambda_t, function.code));

            location = closure_location(l);

            tmp = mstr_add(*name, location);
            if (tmp)
            {
                free_mstring(*name);
                *name = tmp;
            }
            free_mstring(location);
            return inter_pc - csp->funstart - 2;
        }
        return get_line_number(inter_pc, current_prog, name);
    }

    *name = ref_mstring(STR_EMPTY);
    return 0;
} /* get_line_number_if_any() */

/*-------------------------------------------------------------------------*/
string_t *
collect_trace (strbuf_t * sbuf, vector_t ** rvec )

/* Collect the traceback for the current (resp. last) function call, starting
 * from the first frame.
 *
 * If <sbuf> is not NULL, traceback is written in readable form into the
 * stringbuffer <sbuf>.
 *
 * If <rvec> is not NULL, the traceback is returned in a newly created array
 * which pointer is put into *<rvec>. For the format of the array, see
 * efun debug_info().
 *
 * If a heart_beat() is involved, return an uncounted pointer to the name of
 * the object that had it, otherwise return NULL.
 */

{
    struct control_stack *p;  /* Control frame under inspection */
    string_t *ret = NULL;     /* Uncounted ref to object name */
    bytecode_p pc = inter_pc;
    int line = 0;
    string_t *name;           /* Uncounted ref to function name */
    string_t *file;           /* Counted ref to most recent file name */
    object_t *ob = NULL;
    bytecode_p last_catch = NULL;  /* Last found catch */

    /* Temporary structure to hold the tracedata before it is condensed
     * into the result array.
     */
    struct traceentry {
        vector_t          * vec;
        struct traceentry * next;
    } *first_entry, *last_entry;
    size_t num_entries;

#ifdef EVAL_COST_TRACE
#define PUT_EVAL_COST(var, cost) \
        put_number(var->vec->item+TRACE_EVALCOST, cost);
#else
#define PUT_EVAL_COST(var, cost)
#endif

#define NEW_ENTRY(var, type, progname, cost) \
        struct traceentry * var; \
        var = alloca(sizeof(*var)); \
        if (!var) \
            errorf("Stack overflow in collect_trace()"); \
        var->vec = allocate_array_unlimited(TRACE_MAX); \
        var->next = NULL; \
        if (!first_entry) \
            first_entry = last_entry = var; \
        else { \
            last_entry->next = var; \
            last_entry = var; \
        } \
        num_entries++; \
        put_number(var->vec->item+TRACE_TYPE, type); \
        put_ref_string(var->vec->item+TRACE_PROGRAM, progname); \
        put_ref_string(entry->vec->item+TRACE_OBJECT, ob->name); \
	PUT_EVAL_COST(var, cost)

#define PUT_LOC(entry, val) \
        put_number(entry->vec->item+TRACE_LOC, (p_int)(val))

    first_entry = last_entry = NULL;
    num_entries = 0;

    if (!current_prog)
    {
        if (sbuf)
           strbuf_addf(sbuf, "%s\n", get_txt(STR_NO_PROG_TRACE));
        if (rvec)
        {
            vector_t * vec;

            vec = allocate_array_unlimited(1);
            put_ref_string(vec->item, STR_NO_PROG_TRACE);
            *rvec = vec;
        }
        return NULL;
    }

    if (csp < &CONTROL_STACK[0])
    {
        if (sbuf)
           strbuf_addf(sbuf, "%s\n", get_txt(STR_NO_TRACE));
        if (rvec)
        {
            vector_t * vec;

            vec = allocate_array_unlimited(1);
            put_ref_string(vec->item, STR_NO_TRACE);
            *rvec = vec;
        }
        return NULL;
    }

    /* Loop through the call stack.
     * The organisation of the control stack results in the information
     * for this frame (p[0]) being stored in the next (p[1]).
     * Confused now? Good.
     */
    file = ref_mstring(STR_EMPTY);
    p = &CONTROL_STACK[0];
    do {
        bytecode_p  dump_pc;  /* the frame's pc */
        program_t  *prog;     /* the frame's program */
#ifdef EVAL_COST_TRACE
        int32       dump_eval_cost; /* The eval cost at that frame. */
#endif

        /* Note: Under certain circumstances the value of file carried over
         * from the previous iteration is reused in this one.
         */

        if (p->extern_call)
        {
            /* Find the next extern_call and set <ob> to the
             * then-current object for all the coming frames.
             */
            struct control_stack *q = p;
            for (;;) {
                if (++q > csp)
                {
                    ob = current_object;
                    break;
                }
                if (q->extern_call)
                {
                    ob = q->ob;
                    break;
                }
            }
            last_catch = NULL;
        }

        /* Retrieve pc and program from the stack */
        if (p == csp)
        {
            dump_pc = pc;
            prog = current_prog;
#ifdef EVAL_COST_TRACE
            dump_eval_cost = eval_cost;
#endif
        }
        else
        {
            dump_pc = p[1].pc;
            prog = p[1].prog;
#ifdef EVAL_COST_TRACE
            dump_eval_cost = p[1].eval_cost;
#endif
        }

        /* Use some heuristics first to see if it could possibly be a CATCH.
         * The pc should point at a F_END_CATCH instruction, or at a LBRANCH
         * to that instruction.
         */
        if (p > &CONTROL_STACK[0] && p->funstart == p[-1].funstart)
        {
            bytecode_p pc2 = p->pc;

            if (!pc2)
                goto not_catch;  /* shouldn't happen... */

            if (GET_CODE(pc2) == F_LBRANCH)
            {
                short offset;
                pc2++;
                GET_SHORT(offset, pc2);
                if (offset <= 0)
                    goto not_catch;
                pc2 += offset;
            }

            if (pc2 - FUNCTION_CODE(p->funstart) < 1)
                goto not_catch;

            if (GET_CODE(pc2-1) != F_END_CATCH)
            {
                goto not_catch;
            }

            if (last_catch == pc2)
                goto not_catch;
            last_catch = pc2;
            name = STR_CATCH;
            if (file)
                free_mstring(file);
            file = NULL;
            line = 0;
            goto name_computed;
        }

not_catch:  /* The frame does not point at a catch here */

        /* Efun symbol? */
        if (!prog || !dump_pc)
        {
            /* TODO: See comments in call_lambda(): this code
             * TODO:: should never be reached.
             */
            if (sbuf)
#ifndef EVAL_COST_TRACE
                strbuf_addf(sbuf, "<function symbol> in '%20s' ('%20s')\n"
#else
                strbuf_addf(sbuf, "%8d <function symbol> in '%20s' ('%20s')\n"
                           , dump_eval_cost
#endif
                           , get_txt(ob->prog->name), get_txt(ob->name));
            if (rvec)
            {
                NEW_ENTRY(entry, TRACE_TYPE_SYMBOL, ob->prog->name, dump_eval_cost);
            }
            continue;
        }

        /* simul_efun closure? */
        if (p[0].funstart == SIMUL_EFUN_FUNSTART)
        {
            if (sbuf)
                strbuf_addf( sbuf
#ifndef EVAL_COST_TRACE
                           , "<simul_efun closure> bound to '%20s' ('%20s')\n"
#else
                           , "%8d <simul_efun closure> bound to '%20s' ('%20s')\n"
                           , dump_eval_cost
#endif
                           , get_txt(ob->prog->name), get_txt(ob->name));
            if (rvec)
            {
                NEW_ENTRY(entry, TRACE_TYPE_SEFUN, ob->prog->name, dump_eval_cost);
            }
            continue;
        }

        /* efun closure? */
        if (p[0].funstart == EFUN_FUNSTART)
        {
            char * iname;

            iname = instrs[p[0].instruction].name;
            if (iname)
            {
                if (sbuf)
#ifndef EVAL_COST_TRACE
                    strbuf_addf(sbuf, "#\'%-14s for '%20s' ('%20s')\n"
#else
                    strbuf_addf(sbuf, "%8d #\'%-14s for '%20s' ('%20s')\n"
                               , dump_eval_cost
#endif
                               , iname, get_txt(ob->prog->name)
                               , get_txt(ob->name));
                if (rvec)
                {
                    string_t *tmp;

                    NEW_ENTRY(entry, TRACE_TYPE_EFUN, ob->prog->name, dump_eval_cost);
                    memsafe(tmp = new_mstring(iname), strlen(iname)
                           , "instruction name");
                    put_string(entry->vec->item+TRACE_NAME, tmp);
                }
            }
            else
            {
                if (sbuf)
#ifndef EVAL_COST_TRACE
                    strbuf_addf( sbuf, "<efun closure %d> for '%20s' ('%20s')\n"
#else
                    strbuf_addf( sbuf, "%8d <efun closure %d> for '%20s' ('%20s')\n"
                               , dump_eval_cost
#endif
                               , p[0].instruction, get_txt(ob->prog->name)
                               , get_txt(ob->name));
                if (rvec)
                {
                    NEW_ENTRY(entry, TRACE_TYPE_EFUN, ob->prog->name, dump_eval_cost);
                    put_number(entry->vec->item+TRACE_NAME, p[0].instruction);
                }
            }
            continue;
        }

        /* Lambda closure? */
        if (p[0].funstart < prog->program
         || p[0].funstart > PROGRAM_END(*prog))
        {
            if (sbuf)
                strbuf_addf( sbuf
#ifndef EVAL_COST_TRACE
                           , "<lambda 0x%6lx> in '%20s' ('%20s') offset %ld\n"
#else
                           , "%8d <lambda 0x%6lx> in '%20s' ('%20s') offset %ld\n"
                           , dump_eval_cost
#endif
                           , (long)p[0].funstart
                           , get_txt(ob->prog->name)
                           , get_txt(ob->name)
                           , (long)(FUNCTION_FROM_CODE(dump_pc) - p[0].funstart)
                           );
            if (rvec)
            {
                NEW_ENTRY(entry, TRACE_TYPE_LAMBDA, ob->prog->name, dump_eval_cost);
                put_number(entry->vec->item+TRACE_NAME, (p_int)p[0].funstart);
                PUT_LOC(entry, (FUNCTION_FROM_CODE(dump_pc) - p[0].funstart));
            }
            continue;
        }

        /* Nothing of the above: a normal program */
        if (file)
            free_mstring(file);
        line = get_line_number(dump_pc, prog, &file);
        memcpy(&name, FUNCTION_NAMEP(p[0].funstart), sizeof name);

name_computed: /* Jump target from the catch detection */

        /* Print the name and line */

        if (mstreq(name, STR_HEART_BEAT) && p != csp)
            ret = p->extern_call ? (p->ob ? p->ob->name : NULL) : ob->name;

        if (sbuf)
        {
            if (file != NULL)
#ifndef EVAL_COST_TRACE
                strbuf_addf(sbuf, "'%15s' in '%20s' ('%20s') line %d\n"
#else
                strbuf_addf(sbuf, "%8d '%15s' in '%20s' ('%20s') line %d\n"
                           , dump_eval_cost
#endif
                           , get_txt(name), get_txt(file)
                           , get_txt(ob->name), line);
            else
#ifndef EVAL_COST_TRACE
                strbuf_addf(sbuf, "'%15s' in %22s ('%20s')\n"
#else
                strbuf_addf(sbuf, "%8d '%15s' in %22s ('%20s')\n"
                           , dump_eval_cost
#endif
                           , get_txt(name), "", get_txt(ob->name));
        }

        if (rvec)
        {
            NEW_ENTRY(entry, TRACE_TYPE_LFUN, file != NULL ? file : STR_EMPTY, dump_eval_cost);
            put_ref_string(entry->vec->item+TRACE_NAME, name);
            PUT_LOC(entry, line);
        }

    } while (++p <= csp);

    if (file)
        free_mstring(file);


    /* Condense the singular entries into the result array */
    if (rvec)
    {
        vector_t * vec;
        size_t ix;

        vec = allocate_array_unlimited(num_entries+1);

        if (ret)
            put_ref_string(vec->item, ret);

        for (ix = 1; first_entry != NULL; ix++, first_entry = first_entry->next)
        {
            put_array(vec->item+ix, first_entry->vec);
        }

        *rvec = vec;
    }

    /* Done */
    return ret;

#undef NEW_ENTRY
#undef PUT_LOC

} /* collect_trace() */

/*-------------------------------------------------------------------------*/
string_t *
dump_trace (Bool how, vector_t ** rvec)

/* Write out a traceback, starting from the first frame. If a heart_beat()
 * is involved, return (uncounted) the name of the object that had it.
 *
 * If <how> is FALSE (the normal case), the trace is written with
 * debug_message() only. If <how> is TRUE (used for internal errors), the
 * trace is also written to stdout.
 *
 * If TRACE_CODE is defined and <how> is true, the last executed
 * instructions are printed, too.
 *
 * If <rvec> is not NULL, the traceback is returned in a newly created array
 * which pointer is put into *<rvec>. For the format of the array, see
 * efun debug_info().
 */

{
    strbuf_t sbuf;
    string_t *hb_obj_name;

    strbuf_zero(&sbuf);
    hb_obj_name = collect_trace(&sbuf, rvec);

    /* Print the last instructions if required */
#ifdef TRACE_CODE
    if (how) {
        /* TODO: This number of instructions should be a runtime arg */
#ifdef DEBUG
        (void)last_instructions(200, MY_TRUE, NULL);
        if (inter_pc)
            printf("%6p: %3d %3d %3d %3d %3d %3d %3d %3d\n"
                  , inter_pc
                  , inter_pc[0], inter_pc[1], inter_pc[2], inter_pc[3]
                  , inter_pc[4], inter_pc[5], inter_pc[6], inter_pc[7] );
        else
            printf("No program counter.\n");
#else  /* DEBUG */
        last_instructions(20, MY_TRUE, NULL);
#endif /* DEBUG */
    }
#endif /* TRACE_CODE */

    /* Print the trace */
    if (how)
        fputs(sbuf.buf, stdout);
    debug_message("%s", sbuf.buf);

    /* Cleanup and return */
    strbuf_free(&sbuf);

    return hb_obj_name;
} /* dump_trace() */

/*-------------------------------------------------------------------------*/
void
invalidate_apply_low_cache (void)

/* Called in the (unlikely) case that all programs had to be renumbered,
 * this invalidates the call cache.
 */

{
    int i;

    for (i = 0; i < CACHE_SIZE; i++)
    {
        cache[i].id = 0;
        if (cache[i].name)
        {
            free_mstring(cache[i].name);
            cache[i].name = NULL;
        }
    }
}


/*-------------------------------------------------------------------------*/
size_t
interpreter_overhead (void)

/* Return the amount of memory allocated for the interpreter.
 * Right now, there is none.
 */

{
    size_t sum;

    sum = 0;

    return sum;
} /* interpreter_overhead() */


#ifdef GC_SUPPORT

/*-------------------------------------------------------------------------*/
void
clear_interpreter_refs (void)

/* GC Support: Clear the interpreter references.
 */

{
#ifdef TRACE_CODE
    {
        int i;

        for (i = TOTAL_TRACE_LENGTH; --i >= 0; )
        {
            object_t *ob;

            if (NULL != (ob = previous_objects[i])
             && ob->flags & O_DESTRUCTED
             && ob->ref
               )
            {
                ob->ref = 0;
                ob->prog->ref = 0;
                clear_program_ref(ob->prog, MY_FALSE);
            }
        }
    }
#endif
} /* clear_interpreter_refs() */

/*-------------------------------------------------------------------------*/
void
count_interpreter_refs (void)

/* GC Support: Count/mark all interpreter held structures.
 */

{
    int i;

    for (i = CACHE_SIZE; --i>= 0; ) {
        if (cache[i].name)
            count_ref_from_string(cache[i].name);
    }
#ifdef TRACE_CODE
    for (i = TOTAL_TRACE_LENGTH; --i >= 0; )
    {
        object_t *ob;

        if ( NULL != (ob = previous_objects[i]) )
        {
            if (ob->flags & O_DESTRUCTED)
            {
                previous_objects[i] = NULL;
                previous_instruction[i] = 0;
                reference_destructed_object(ob);
            }
            else
            {
                ob->ref++;
            }
        }
    }
#endif
}
/*-------------------------------------------------------------------------*/

#endif /* GC_SUPPORT */

/*=========================================================================*/

/*                            D E B U G G I N G                            */

/*-------------------------------------------------------------------------*/
#ifdef OPCPROF
Bool
opcdump (string_t * fname)

/* Print the usage statistics for the opcodes into the file <fname>.
 * Return TRUE on success, FALSE if <fname> can't be written.
 */

{
    int i;
    FILE *f;

    fname = check_valid_path(fname, current_object, STR_OPCDUMP, MY_TRUE);
    if (!fname)
        return MY_FALSE;
    f = fopen(get_txt(fname), "w");
    free_mstring(fname);
    if (!f)
        return MY_FALSE;
    FCOUNT_WRITE(fname);


    for(i = 0; i < MAXOPC; i++)
    {
        if (opcount[i])
#ifdef VERBOSE_OPCPROF
            fprintf(f,"%d: \"%-16s\" %6d\n",i, get_f_name(i), opcount[i]);
#else
            fprintf(f,"%d: %d\n", i, opcount[i]);
#endif
    }
    fclose(f);

    return MY_TRUE;
}
#endif /* OPCPROF */


#ifdef TRACE_CODE

/*-------------------------------------------------------------------------*/
static char *
get_arg (int a)

/* Return the argument for the instruction at previous_pc[<a>] as a string.
 * If there is no argument, return "".
 *
 * Helper function for last_instructions().
 */

{
    static char buff[12];
    bytecode_p from, to;
    int b;

    b = (a+1) % TOTAL_TRACE_LENGTH;
    from = previous_pc[a];
    to = previous_pc[b];

    if (to - from < 2)
        return "";

    if (to - from == 2)
    {
        snprintf(buff, sizeof(buff), "%d", GET_CODE(from+1));
        return buff;
    }

    if (to - from == 3)
    {
        short arg;

        GET_SHORT(arg, from+1);
        snprintf(buff, sizeof(buff), "%hd", arg);
        return buff;
    }

    if (to - from == 5)
    {
        int32 arg;

        GET_INT32(arg, from+1);
        snprintf(buff, sizeof(buff), "%"PRId32, arg);
        return buff;
    }

    return "";
} /* get_arg() */

/*-------------------------------------------------------------------------*/
static void
last_instr_output (char *str, svalue_t **svpp)

/* <svpp> == NULL: print string <str>
 * <svpp> != NULL: store a copy of <str> as string-svalue to *<svpp>, then
 *                 increment *<svpp>
 *
 * Helper function to last_instructions() to either print strings for
 * a tracedump, or to push them onto the evaluator stack for the efun
 * last_instructions().
 */

{
    if (svpp)
    {
        string_t *s;
        memsafe(s = new_mstring(str), strlen(str), "copy of instruction name");
        put_string((*svpp), s);
        (*svpp)++;
    }
    else
    {
        fputs(str, stdout);
        putc('\n', stdout);
    }
} /* last_instr_output() */

/*-------------------------------------------------------------------------*/
static Bool
program_referenced (program_t *prog, program_t *prog2)

/* Return TRUE if <prog2> inherits <prog>.
 *
 * Auxiliary function to last_instructions().
 */

{
    inherit_t *inh;
    int i;

    if (prog == prog2)
        return MY_TRUE;

    /* If a prog2 is swapped out, it can't have prog inherited
     * and swapped in.
     */
    if (P_PROG_SWAPPED(prog2))
        return MY_FALSE;

    /* Recursively test the inherits */
    for (i = prog2->num_inherited, inh = prog2->inherit; --i >= 0; inh++)
    {
        if (program_referenced(prog, inh->prog))
            return MY_TRUE;
    }

    return MY_FALSE;
}

/*-------------------------------------------------------------------------*/
static Bool
program_exists (program_t *prog, object_t *guess)

/* Test if <prog> exists - either by itself or as inherited program.
 * Start testing with the program of <guess>, if it is not there,
 * test all objects in the list.
 *
 * Auxiliary function to last_instructions().
 */

{
    if (program_referenced(prog, guess->prog))
        return MY_TRUE;

    for (guess = obj_list; guess; guess = guess->next_all)
    {
#ifdef DEBUG
        if (guess->flags & O_DESTRUCTED)  /* TODO: Can't happen */
            continue;
#endif
        if (program_referenced(prog, guess->prog))
            return MY_TRUE;
    }

    return MY_FALSE;
}

/*-------------------------------------------------------------------------*/
int
last_instructions (int length, Bool verbose, svalue_t **svpp)

/* 'Print' a dump of the <length> last instructions. If <svpp> is NULL,
 * all the data is printed, else *<svpp> points to the evaluator stack
 * and all the 'printed' lines are pushed onto the stack using *<svpp>
 * as pointer.
 *
 * If <verbose> is true, more information is printed.
 *
 * Return the index for the last executed instruction.
 *
 * This function is called from dump_trace() and f_last_instructions().
 */

{
    int i;
    object_t *old_obj;
    char buf[400];
    string_t *old_file;
    int old_line, line = 0;

    old_obj = NULL;
    old_file = NULL;
    old_line = 0;
    i = (last - length + TOTAL_TRACE_LENGTH) % TOTAL_TRACE_LENGTH;

    /* Walk through the instructions.
     * Instructions with value 0 are not used yet, or have been
     * removed while cleaning up destructed objects.
     */
    do {
        i = (i + 1) % TOTAL_TRACE_LENGTH;
        if (previous_instruction[i] != 0)
        {
            if (verbose)
            {
                string_t *file;
                program_t *ppr;
                bytecode_p ppc;

                ppr = previous_programs[i];
                ppc = previous_pc[i]+1;
                if (!program_exists(ppr, previous_objects[i]))
                {
                    file = ref_mstring(STR_PROG_DEALLOCATED);
                    line = 0;
                }
                else if (ppc < ppr->program || ppc > PROGRAM_END(*ppr))
                {
                    file = ref_mstring(STR_UNKNOWN_LAMBDA);
                    line = 0;
                }
                else
                {
                    line = get_line_number(ppc, ppr, &file);
                }

                if (previous_objects[i] != old_obj
                 || (old_file && !mstreq(file, old_file))
                   )
                {
                    snprintf(buf, sizeof(buf), "%.170s %.160s line %d"
                               , get_txt(previous_objects[i]->name)
                               , get_txt(file), line
                    );
                    last_instr_output(buf, svpp);
                    old_obj = previous_objects[i];
                    if (old_file)
                        free_mstring(old_file);
                    old_file = ref_mstring(file);
                }

                if (file)
                    free_mstring(file);
            }
            snprintf(buf, sizeof(buf)-40, "%6p: %3d %8s %-26s (%td:%3td)"
                   , previous_pc[i]
                   , previous_instruction[i] /* instrs.h has these numbers */
                   , get_arg(i)
                   , get_f_name(previous_instruction[i])
                   , (stack_size[i] + 1)
                   , (abs_stack_size[i])
            );
            if (verbose && line != old_line)
                snprintf(buf + strlen(buf), 40, "\tline %d", old_line = line);
            last_instr_output(buf, svpp);
        }
    } while (i != last);

    if (old_file)
        free_mstring(old_file);

    return last;
} /* last_instructions() */

/*-------------------------------------------------------------------------*/
svalue_t *
f_last_instructions (svalue_t *sp)

/* EFUN last_instructions()
 *
 *   string *last_instructions (int length, int verbose)
 *
 * Return an array showing the 'length' last executed
 * instructions in disassembled form. If 'verbose' is non-zero
 * (the default), line number information are also included.
 * Each string is built as this:
 *
 *   Opcode-Address: Opcode Operand Mnemonic (Stackdepth) Linenumber
 *
 * The Stackdepth information consists of two numbers <rel>:<abs>:
 * <rel> is the relative stack usage in this function, <abs> is the
 * absolute stack usage.
 *
 * The linenumber information is appended if requested and a new
 * source line is reached. Also, calls between objects produce a
 *
 *   Objectname Programname Linenumber
 *
 * entry in the resulting array (in verbose mode only).
 *
 * There is a preconfigured upper limit for the backtrace.
 */

{
    vector_t *v, *v2;
    mp_int num_instr, size;
    svalue_t *svp;

    /* Test the arguments */
    num_instr = sp[-1].u.number;
    if (num_instr <= 0)
        errorf("Illegal number of instructions: %"PRIdMPINT".\n", num_instr);

    sp--;
    inter_sp = sp; /* Out of memory possible */
    if (num_instr > TOTAL_TRACE_LENGTH)
        num_instr = TOTAL_TRACE_LENGTH;

    /* Allocate the result vector */
    size = sp[1].u.number ? num_instr << 1 : num_instr;
    v = allocate_array(size);

    /* Enter the vector into the stack for now, so that it will be
     * freed when an out of memory error occurs.
     */
    put_array(sp, v);
    svp = v->item;
    last_instructions(num_instr, sp[1].u.number != 0, &svp);

    /* If we allocated the vector to big, get a shorter one and copy
     * the data.
     */
    if (svp - v->item < size)
    {
        size = svp - v->item;
        v2 = allocate_array(size);
        memcpy(v2->item, v->item, size * sizeof *svp);
        sp->u.vec = v2;
        free_empty_vector(v);
    }

    return sp;
} /* f_last_instructions() */

/*-------------------------------------------------------------------------*/

#endif /* TRACE_CODE */

/*-------------------------------------------------------------------------*/
int control_stack_depth (void)
  /* Returns the number of frames on the control stack. Can be used to estimate
   * the still available stack depth in recursive code.
   */
{
    return (csp - CONTROL_STACK) + 1;
} /* control_stack_depth() */

/*-------------------------------------------------------------------------*/
static INLINE int
caller_stack_depth(void)
/* static helper function for f_caller_stack_depth() and f_caller_stack() for
 * calculating the stack depth. It is a separate function because the code
 * is used at two places and the compiler will probably inline it anyway.
 */
{
  int depth;
  Bool done;
  struct control_stack *p;

  /* Determine the depth of the call stack */
  p = csp;
  for (depth = 0, done = MY_FALSE; ; depth++)
  {
    do {
      if (p == CONTROL_STACK)
      {
        done = MY_TRUE;
        break;
      }
    } while ( !(--p)[1].extern_call );
    if (done)
      break;
  }

  return depth;
} /* caller_stack_depth() */

/*-------------------------------------------------------------------------*/
svalue_t *
f_caller_stack_depth (svalue_t *sp)
/* EFUN caller_stack_depth()
 *
 *   int caller_stack_depth(void)
 *
 * Returns the number of previous objects on the stack. This
 * can be used for security checks.
 */

{
    push_number(sp, caller_stack_depth());

    return sp;
} /* f_caller_stack_depth() */

/*-------------------------------------------------------------------------*/
svalue_t *
f_caller_stack (svalue_t *sp)

/* EFUN caller_stack()
 *
 *   object *caller_stack()
 *   object *caller_stack(int add_interactive)
 *
 * Returns an array of the previous_object()s who caused the
 * call_other() to this_object().  previous_object(i) equals
 * caller_stack()[i].

 * If you pass the optional argument <add_interactive> (as true
 * value), this_interactive() (or 0 if not existing) is appended
 * to the array.
 */

{
    int depth, i;
    Bool done;
    struct control_stack *p;
    vector_t *v;
    svalue_t *svp;

    /* Determine the depth of the call stack */
    depth = caller_stack_depth();

    /* Allocate and fill in the result array */
    v = allocate_uninit_array(depth + (sp->u.number ? 1 : 0));
    p = csp;
    for (i = 0, svp = v->item, done = MY_FALSE; i < depth; i++, svp++)
    {
        object_t *prev;
        do {
            if (p == CONTROL_STACK)
            {
                done = MY_TRUE;
                break;
            }
        } while ( !(--p)[1].extern_call);

        /* Break if end of stack */
        if (done)
            break;

        /* Get 'the' calling object */
        if (p[1].extern_call & CS_PRETEND)
            prev = p[1].pretend_to_be;
        else
            prev = p[1].ob;

        /* Enter it into the array */
        if (prev == NULL || prev->flags & O_DESTRUCTED)
            put_number(svp, 0);
        else
            put_ref_object(svp, prev, "caller_stack");
    }

#ifdef DEBUG
    if (i < depth)
    {
        errorf("Computed stack depth to %d, but found only %d objects\n"
             , depth, i);
        /* NOTREACHED */
        return sp;
    }
#endif

    /* If so desired, add the interactive object */
    if (sp->u.number)
    {
        if ( current_interactive
         && !(current_interactive->flags & O_DESTRUCTED))
        {
            put_ref_object(svp, current_interactive, "caller_stack");
        }
        else
            put_number(svp, 0);
    }

    /* Assign the result and return */
    put_array(sp, v);

    return sp;
} /* f_caller_stack() */

/*-------------------------------------------------------------------------*/
svalue_t *
f_previous_object (svalue_t *sp)

/* EFUN previous_object()
 *
 *   object previous_object(int i)
 *
 * Follow back the last <i> call_other()s and return the calling
 * object (i.e. previous_object(2) returns the caller of the
 * caller). It must hold 1 <= i < caller_stack_depth().
 * Any value of i < 1 is treated as i == 1.
 *
 * There is an important special case: in functions called by the
 * gamedriver in reaction to some external event (e.g. commands
 * added by add_action), previous_object() will return
 * this_object(), but previous_object(1) will return 0.
 */

{
    int i;
    struct control_stack *p;
    object_t *prev_ob;

    /* Test the arguments */
    i = sp->u.number;
    if (i > MAX_TRACE) {
        sp->u.number = 0;
        return sp;
    }

    /* Set p back to the <i>th extern call */
    p = csp;
    do {
        do {
            if (p == CONTROL_STACK) {
                sp->u.number = 0;
                return sp;
            }
        } while ( !(--p)[1].extern_call );
    } while (--i >= 0);

    /* Determine the object and push it */
    if (p[1].extern_call & CS_PRETEND)
        prev_ob = p[1].pretend_to_be;
    else
        prev_ob = p[1].ob;

    if (!prev_ob || prev_ob->flags & O_DESTRUCTED)
        sp->u.number = 0;
    else
        put_ref_object(sp, prev_ob, "previous_object");

    return sp;
} /* f_previous_object() */



#ifdef DEBUG

/*-------------------------------------------------------------------------*/
void
count_inherits (program_t *progp)

/* Check Refcounts: Increment the extra_ref of all programs inherited
 * by <progp>. If one of those programs has not been visited yet,
 * its extra_ref is set to 1 and this function is called recursively.
 *
 * If check_..._search_prog is set and equal to one of the inherited
 * programs, a notice is printed.
 */

{
    int i;
    program_t *progp2;

    /* Clones will not add to the ref count of inherited progs */
    for (i = 0; i < progp->num_inherited; i++)
    {
        progp2 = progp->inherit[i].prog;
        progp2->extra_ref++;
        if (progp2 == check_a_lot_ref_counts_search_prog)
            printf("%s Found prog, inherited by %s, new total ref %"
                   PRIdPINT"\n",
                   time_stamp(), get_txt(progp->name), progp2->ref);
        if (NULL == register_pointer(ptable, progp2))
        {
            continue;
        }
        progp2->extra_ref = 1;
        if (progp2->blueprint)
        {
            count_extra_ref_in_object(progp2->blueprint);
        }
        count_inherits(progp2);
    }
} /* count_inherits() */

/*-------------------------------------------------------------------------*/
static void
count_extra_ref_in_mapping_filter ( svalue_t *key, svalue_t *data
                                  , void * extra)

/* Count the extra refs for <key> and the associated <data>. <extra>
 * is a mp_int giving the number of data values.
 */

{
    count_extra_ref_in_vector(key, 1);
    count_extra_ref_in_vector(data, (size_t)extra);
}

/*-------------------------------------------------------------------------*/
static void
check_extra_ref_in_mapping_filter (svalue_t *key, svalue_t *data
                                  , void * extra)

/* Check the extra refs for <key> and the associated <data>. <extra>
 * is a mp_int giving the number of data values.
 */

{
    check_extra_ref_in_vector(key, 1);
    check_extra_ref_in_vector(data, (size_t)extra);
}

static void
count_extra_ref_in_prog (program_t *prog)
/* Count extra refs for <prog>.
 */
{
    if (NULL != register_pointer(ptable, prog))
    {
        prog->extra_ref = 1;
        if (prog->blueprint)
        {
            count_extra_ref_in_object(prog->blueprint);
        }
        count_inherits(prog);
    }
}

/*-------------------------------------------------------------------------*/
void
count_extra_ref_in_object (object_t *ob)

/* Count the extra refs for object <ob>. If the object has been visited
 * before, extra_ref is just incremented. Otherwise, extra_ref is
 * set to 1 and all depending refs are counted.
 *
 * If check_..._search_prog is set and matches the objects program,
 * a notice is printed.
 */

{
    int was_swapped = MY_FALSE;

    ob->extra_ref++;
    if ( NULL == register_pointer(ptable, ob) )
    {
        return;
    }

    ob->extra_ref = 1;
    if ( !O_PROG_SWAPPED(ob) )
    {
        ob->prog->extra_ref++;
        if (ob->prog == check_a_lot_ref_counts_search_prog)
            printf("%s Found program for object %s\n", time_stamp()
                  , get_txt(ob->name));
    }

    /* Clones will not add to the ref count of inherited progs */
    if (O_PROG_SWAPPED(ob))
    {
         if (load_ob_from_swap(ob) < 0)
            debug_message( "%s check-refcounts: Program for '%s' can't be "
                           "swapped in - extra refcounts may be wrong.\n"
                         , time_stamp(), get_txt(ob->name));
         else
             was_swapped = MY_TRUE;
    }

    if (!O_PROG_SWAPPED(ob))
    {
        count_extra_ref_in_prog(ob->prog);
    }

    if (was_swapped)
        swap_program(ob);
} /* count_extra_ref_in_object() */

/*-------------------------------------------------------------------------*/
static void
count_extra_ref_in_closure (lambda_t *l, ph_int type)

/* Count the extra refs in the closure <l> of type <type>.
 */

{
    if (CLOSURE_HAS_CODE(type))
    {
        /* We need to count the extra_refs in the constant values. */

        mp_int num_values;
        svalue_t *svp;

        svp = (svalue_t *)l;
        if ( (num_values = EXTRACT_UCHAR(l->function.code)) == 0xff)
            num_values = svp[-0x100].u.number;
        svp -= num_values;
        count_extra_ref_in_vector(svp, (size_t)num_values);
    }
    else
    {
        /* Count the referenced closures and objects */
        if (type == CLOSURE_BOUND_LAMBDA)
        {
            lambda_t *l2 = l->function.lambda;

            if (NULL != register_pointer(ptable, l2) )
                count_extra_ref_in_closure(l2, CLOSURE_UNBOUND_LAMBDA);
        }
        else if (type == CLOSURE_LFUN)
        {
            count_extra_ref_in_object(l->function.lfun.ob);
            if (l->function.lfun.inhProg)
            {
                l->function.lfun.inhProg->extra_ref++;
                count_extra_ref_in_prog(l->function.lfun.inhProg);
            }
        }
    }

    if (type != CLOSURE_UNBOUND_LAMBDA)
    {
        count_extra_ref_in_object(l->ob);
    }

    if (l->prog_ob)
    {
        count_extra_ref_in_object(l->prog_ob);
    }
} /* count_extra_ref_in_closure() */

/*-------------------------------------------------------------------------*/
void
count_extra_ref_in_vector (svalue_t *svp, size_t num)

/* Count the extra_refs of all <num> values starting at <svp>.
 */

{
    svalue_t *p;

    if (!svp)
        return;

    for (p = svp; p < svp+num; p++)
    {
        switch(p->type)
        {

        case T_CLOSURE:
            if (CLOSURE_MALLOCED(p->x.closure_type))
            {
                lambda_t *l;

                l = p->u.lambda;
                if ( NULL == register_pointer(ptable, l) )
                    continue;
                count_extra_ref_in_closure(l, p->x.closure_type);
                continue;
            }
            /* FALLTHROUGH */

        case T_OBJECT:
          {
            count_extra_ref_in_object(p->u.ob);
            continue;
          }

        case T_QUOTED_ARRAY:
        case T_POINTER:
            p->u.vec->extra_ref++;
            if (NULL == register_pointer(ptable, p->u.vec) )
                continue;
            p->u.vec->extra_ref = 1;
            count_extra_ref_in_vector(&p->u.vec->item[0], VEC_SIZE(p->u.vec));
            continue;

#ifdef USE_STRUCTS
        case T_STRUCT:
            if (NULL == register_pointer(ptable, p->u.strct) )
                continue;
            count_extra_ref_in_vector(&p->u.strct->member[0], struct_size(p->u.strct));
            continue;
#endif /* USE_STRUCTS */

        case T_MAPPING:
            if (NULL == register_pointer(ptable, p->u.map) ) continue;
            walk_mapping(
              p->u.map,
              count_extra_ref_in_mapping_filter,
              (void *)p->u.map->num_values
            );
            continue; /* no extra ref count implemented */
        }
    }
} /* count_extra_ref_in_vector() */

/*-------------------------------------------------------------------------*/
static void
check_extra_ref_in_vector (svalue_t *svp, size_t num)

/* Check the extra_refs of the <num> values starting at <svp>
 */

{
    svalue_t *p;

    if (!svp)
        return;

    for (p = svp; p < svp+num; p++)
    {
        switch(p->type)
        {
        case T_QUOTED_ARRAY:
        case T_POINTER:
            if (NULL == register_pointer(ptable, p->u.vec) )
                continue;
            check_extra_ref_in_vector(&p->u.vec->item[0], VEC_SIZE(p->u.vec));
            p->u.vec->extra_ref = 0;
            continue;

#ifdef USE_STRUCTS
        case T_STRUCT:
            if (NULL == register_pointer(ptable, p->u.strct) )
                continue;
            check_extra_ref_in_vector(&p->u.strct->member[0], struct_size(p->u.strct));
            p->u.vec->extra_ref = 0;
            continue;
#endif /* USE_STRUCTS */

        case T_MAPPING:
            if (NULL == register_pointer(ptable, p->u.map) ) continue;
            walk_mapping(
              p->u.map,
              check_extra_ref_in_mapping_filter,
              (void *)((p_int)p->u.map->num_values)
            );
            continue; /* no extra ref count implemented */
        }
    }
} /* check_extra_ref_in_vector() */

/*-------------------------------------------------------------------------*/
void
check_a_lot_ref_counts (program_t *search_prog)

/* Loop through every object and variable in the game and check all
 * reference counts. This will surely take some time and should be
 * used only for debugging.
 *
 * If <search_prog> is set, the function will just count the references
 * and print the information for the given program, if found.
 *
 * The function must be called after removing all destructed objects.
 *
 * TODO: No extra_refs implemented in mappings.
 * TODO: Put this code somewhere else.
 */

{
    object_t *ob;

    check_a_lot_ref_counts_search_prog = search_prog;

    /* Pass 1: Compute the ref counts.
     *
     * The pointer table keeps track of objects already visited,
     * eliminating the need for a separate pass to clear the
     * ref counts.
     */
    ptable = new_pointer_table();
    if (!ptable)
    {
        debug_message("%s Out of memory while checking all refcounts.\n"
                     , time_stamp());
        return;
    }

    /* List of all objects.
     */
    for (ob = obj_list; ob; ob = ob->next_all)
    {
        if (ob->flags & O_DESTRUCTED)
        {
            /* This shouldn't happen
             * TODO: remove check? enclose in #ifdef DEBUG? */
            debug_message("%s Found destructed object '%s' where it shouldn't "
                          "be.\n", time_stamp(), get_txt(ob->name));
            continue;
        }
        if (O_VAR_SWAPPED(ob))
            load_ob_from_swap(ob);
        count_extra_ref_in_vector(ob->variables, (size_t)ob->extra_num_variables);
        count_extra_ref_in_object(ob);
    }

    if (master_ob)
        master_ob->extra_ref++;

    if (d_flag > 3)
    {
        debug_message("%s obj_list evaluated\n", time_stamp());
    }

    /* The current stack.
     */
    count_extra_ref_in_vector(VALUE_STACK, (size_t)(inter_sp - VALUE_STACK + 1));
    if (d_flag > 3)
    {
        debug_message("%s stack evaluated\n", time_stamp());
    }


    /* Other variables and lists.
     */
    count_extra_ref_from_call_outs();
    count_extra_ref_from_wiz_list();
    count_simul_efun_extra_refs(ptable);
    count_comm_extra_refs();

#ifdef TRACE_CODE
    {
        int j;

        for (j = TOTAL_TRACE_LENGTH; --j >= 0; )
        {
            if ( NULL != (ob = previous_objects[j]) )
            {
                count_extra_ref_in_object(ob);
            }
        }
    }
#endif

    count_extra_ref_in_vector(&indexing_quickfix, 1);
    count_extra_ref_in_vector(&last_indexing_protector, 1);
    null_vector.extra_ref++;
    count_extra_ref_in_vector(driver_hook, NUM_DRIVER_HOOKS);

    /* Done with the counting */
    free_pointer_table(ptable);

    /* Was that all for this time? */
    if (search_prog)
        return;

    /* Pass 3: Check the ref counts.
     *
     * The (new) pointer table is used as before.
     */
    ptable = new_pointer_table();
    if (!ptable)
    {
        debug_message("%s Out of memory while checking all refcounts.\n"
                     , time_stamp());
        return;
    }

    for (ob = obj_list; ob; ob = ob->next_all) {
        if (ob->flags & O_DESTRUCTED)  /* shouldn't happen */
            continue;

        if (ob->ref != ob->extra_ref)
        {
             debug_message("%s Bad ref count in object %s: listed %"
                           PRIdPINT" - counted %"PRIdPINT"\n"
                          , time_stamp(), get_txt(ob->name)
                          , ob->ref, ob->extra_ref);
        }
        else if ( !(ob->flags & O_SWAPPED) )
        {
            if (ob->prog->ref != ob->prog->extra_ref)
            {
                /* an inheriting file might be swapped */
                if (time_to_swap + 1 > 0
                 && ob->prog->ref > ob->prog->extra_ref)
                {
                    debug_message("%s high ref count in prog %s: "
                                  "listed %"PRIdPINT" - counted %"PRIdPINT"\n"
                                 , time_stamp()
                                 , get_txt(ob->prog->name), ob->prog->ref
                                 , ob->prog->extra_ref);
                }
                else
                {
                    check_a_lot_ref_counts(ob->prog);
                    debug_message("%s Bad ref count in prog %s: "
                                  "listed %"PRIdPINT" - counted %"PRIdPINT"\n"
                                 , time_stamp()
                                 , get_txt(ob->prog->name)
                                 , ob->prog->ref, ob->prog->extra_ref);
                }
            }
        } /* !SWAPPED */
        check_extra_ref_in_vector(ob->variables, ob->extra_num_variables);
    } /* for */

    check_extra_ref_in_vector(VALUE_STACK, (size_t)(inter_sp - VALUE_STACK + 1));

    free_pointer_table(ptable);
} /* check_a_lot_of_ref_counts() */

/*-------------------------------------------------------------------------*/

#endif /* DEBUG */


/*=========================================================================*/

/*                             E F U N S                                   */

/*-------------------------------------------------------------------------*/
/* (Re)define a couple a macros for the efuns below
 */

#undef ERROR
#define ERROR(s) {inter_sp = sp; errorf(s);}

/*-------------------------------------------------------------------------*/
svalue_t *
v_apply (svalue_t *sp, int num_arg)

/* EFUN apply()
 *
 *     mixed apply(mixed|closure cl, ...)
 *
 * Call the closure <cl> and pass it all the extra arguments
 * given in the call. If the last argument is an array, it
 * is flattened, ie. passed as a bunch of single arguments.
 * TODO: Use the MudOS-Notation '(*f)(...)' as alternative.
 */

{
    svalue_t *args;

    args = sp -num_arg +1;

    if (args->type != T_CLOSURE)
    {
        /* Not a closure: pop the excess args and return <cl>
         * as result.
         */

        while (--num_arg)
            free_svalue(sp--);
        return sp;
    }

    if (sp->type == T_POINTER)
    {
        /* The last argument is an array: flatten it */

        vector_t *vec;  /* the array */
        svalue_t *svp;  /* pointer into the array */
        long i;              /* (remaining) vector size */

        vec = sp->u.vec;
        i = (long)VEC_SIZE(vec);
        num_arg += i - 1;

        /* Check if the target closure can handle
         * all the arguments without overflowing the stack.
         */
        switch( (sp - num_arg + i)->x.closure_type )
        {
        default:
            if ((sp - num_arg + i)->x.closure_type >= 0)
                errorf("Uncallable closure in apply().\n");
            /* else: operator/sefun/efun closure: FALLTHROUGH */
        case CLOSURE_LFUN:
        case CLOSURE_LAMBDA:
        case CLOSURE_BOUND_LAMBDA:
            if (num_arg + (sp - VALUE_STACK) < EVALUATOR_STACK_SIZE)
                break;
            errorf("VM Stack overflow: %zu too high.\n",
                 (size_t)(num_arg + (sp - VALUE_STACK) - EVALUATOR_STACK_SIZE) );
            break;
        }

        /* Push the array elements onto the stack, overwriting the
         * array value itself.
         */
        if (deref_array(vec))
        {
            for (svp = vec->item; --i >= 0; )
            {
                if (destructed_object_ref(svp))
                {
                    put_number(sp, 0);
                    sp++;
                    svp++;
                }
                else
                    assign_svalue_no_free(sp++, svp++);
            }
        }
        else
        {
            /* The array will be freed, so use a faster function */
            for (svp = vec->item; --i >= 0; ) {
                if (destructed_object_ref(svp))
                {
                    put_number(sp, 0);
                    sp++;
                    svp++;
                }
                else
                    transfer_svalue_no_free(sp++, svp++);
            }
            free_empty_vector(vec);
        }

        sp--; /* undo the last extraneous sp++ */
    }

    /* Prepare to call the closure */

    args = sp -num_arg +1;

    /* No external calls may be done when this object is
     * destructed.
     */
    if (current_object->flags & O_DESTRUCTED)
    {
        sp = _pop_n_elems(num_arg, sp);
        push_number(sp, 0);
        inter_sp = sp;
        warnf("Call from destructed object '%s' ignored.\n"
             , get_txt(current_object->name));
        return sp;
    }

    inter_sp = sp;


    /* Call the closure and push the result.
     * Note that the closure might destruct itself.
     */
    call_lambda(args, num_arg - 1);
    sp = args;
    free_svalue(sp);
    *sp = sp[1];

    return sp;
} /* v_apply() */

/*-------------------------------------------------------------------------*/
svalue_t *
v_funcall (svalue_t *sp, int num_arg)

/* EFUN funcall()
 *
 *   mixed funcall(mixed|closure cl, mixed arg ...)
 *
 * Evaluates the closure. The extra args will be passed as args
 * to the closure. If cl is not a closure, it will simply be
 * returned.
 */

{
    svalue_t *args;

    args = sp -num_arg +1;

    if (args->type == T_CLOSURE)
    {
        /* No external calls may be done when this object is
         * destructed.
         */
        if (current_object->flags & O_DESTRUCTED) {
            sp = _pop_n_elems(num_arg, sp);
            push_number(sp, 0);
            inter_sp = sp;
            warnf("Call from destructed object '%s' ignored.\n"
                 , get_txt(current_object->name));
            return sp;
        }

        /* Call the closure and push the result.
         * Note that the closure might destruct itself.
         */
        call_lambda(args, num_arg - 1);
        sp = args;
        free_svalue(sp);
        *sp = sp[1];
    }
    else
    {
        /* Not a closure: pop the excess args and return <cl>
         * as result.
         */

        while (--num_arg)
            free_svalue(sp--);
    }

    return sp;
} /* v_funcall() */

/*-------------------------------------------------------------------------*/
static svalue_t *
int_call_resolved (Bool b_use_default, svalue_t *sp, int num_arg)

/* EFUN call_resolved(), call_direct_resolved()
 *
 *   int call_resolved(mixed & result, object ob, string func, ...)
 *   int call_direct_resolved(mixed & result, object ob, string func, ...)
 *
 * Similar to call_other(_direct)(). If ob->func() is defined and publicly
 * accessible, any of the optional extra arguments are passed to
 * ob->func(...). The result of that function call is stored in
 * result, which must be passed by reference.
 *
 * If the current object is already destructed, or the ob does not
 * exist, or ob does not define a public accessible function named
 * func, call_direct_resolved() returns 0 as failure code, else 1 for
 * success.
 *
 * If the current object is already destructed, or the ob does not
 * exist, or ob does not define a public accessible function named
 * func and no default method is available, call_resolved() returns 0.
 * If the call succeeded, the efun returns 1; if the call succeeded
 * through a default method, the efun returns -1.
 *
 * ob can also be a file_name. If a string is passed for ob, and
 * no object with that name does exist, an error occurs.
 */

{
    svalue_t *arg;
    object_t *ob;
    int rc;

    arg = sp - num_arg + 1;

    /* Test the arguments */
    if (arg[1].type == T_NUMBER)
        ob = NULL;
    else if (arg[1].type == T_OBJECT)
        ob = arg[1].u.ob;
    else /* it's a string */
    {
        ob = get_object(arg[1].u.str);
        if (!ob)
            errorf("call_resolved() failed: can't get object '%s'.\n"
                 , get_txt(arg[1].u.str));
    }

    /* No external calls may be done when this object is
     * destructed.
     * Similar, don't do calls if the target object is destructed.
     */
    if (current_object->flags & O_DESTRUCTED
     || NULL == ob)
    {
        sp = _pop_n_elems(num_arg, sp);
        push_number(sp, 0);
        inter_sp = sp;
        warnf("Call from destructed object '%s' ignored.\n"
             , get_txt(current_object->name));
        return sp;
    }

    /* Handle traceing. */
    if (TRACEP(TRACE_CALL_OTHER) && TRACE_IS_INTERACTIVE())
    {
        if (!++traceing_recursion)
        {
            inter_sp = sp;
            do_trace("Call other ", get_txt(arg[2].u.str), "\n");
        }
        traceing_recursion--;
    }

    /* Send the remaining arguments to the function.
     */
    if (ob == master_ob)
        b_use_default = MY_FALSE;
    rc = int_apply(arg[2].u.str, ob, num_arg-3, MY_FALSE, b_use_default);
    if (rc == APPLY_NOT_FOUND)
    {
        /* Function not found */
        if (b_use_default)
            sp -= num_arg-3;
        else
            sp = _pop_n_elems(num_arg-3, sp);
        sp = _pop_n_elems(2, sp);
        free_svalue(sp);
        put_number(sp, 0);
        return sp;
    }

    /* The result of the function call is on the stack. But, so
     * is the function name and object that was called.
     * These have to be removed.
     */
    sp = inter_sp;
    transfer_svalue(arg, sp--);  /* Copy the function call result */
    sp = _pop_n_elems(2, sp);     /* Remove old arguments to call_solved */
    free_svalue(sp);             /* Free the lvalue */
    put_number(sp, rc == APPLY_FOUND ? 1 : -1);

    return sp;
} /* f_call_resolved() */

/*-------------------------------------------------------------------------*/
svalue_t *
v_call_resolved (svalue_t *sp, int num_arg)

/* EFUN call_resolved()
 *
 * This is just a wrapper around the real implementation.
 */

{
    return int_call_resolved(MY_TRUE, sp, num_arg);
} /* v_call_resolved() */

/*-------------------------------------------------------------------------*/
svalue_t *
v_call_direct_resolved (svalue_t *sp, int num_arg)

/* EFUN call_direct_resolved()
 *
 * This is just a wrapper around the real implementation.
 */

{
    return int_call_resolved(MY_FALSE, sp, num_arg);
} /* v_call_direct_resolved() */

/*-------------------------------------------------------------------------*/
svalue_t *
f_get_eval_cost (svalue_t *sp)

/* EFUN get_eval_cost()
 *
 *   int get_eval_cost()
 *
 * Returns the remaining evaluation cost the current
 * execution (the current command) may use up.
 *
 * It starts at a driver given high value (__MAX_EVAL_COST__) and
 * is reduced with each executed statement.
 */

{
    push_number(sp, (max_eval_cost ? max_eval_cost : PINT_MAX) - eval_cost);

    return sp;
} /* f_get_eval_cost() */

/*-------------------------------------------------------------------------*/
svalue_t *
f_set_this_object (svalue_t *sp)

/* EFUN set_this_object()
 *
 *   void set_this_object(object object_to_pretend_to_be);
 *
 * Set this_object() to <object_to_pretend_to_be>. A privilege
 * violation ("set_this_object", this_object(), object_to_be)
 * occurs.
 *
 * It changes the result of this_object() in the using function, and
 * the result of previous_object() in functions called in other
 * objects by call_other(). Its effect will remain till there is a
 * return of an external function call, or another call of
 * set_this_object(). While executing code in the master
 * object's program or the primary simul_efun object's program,
 * set_this_object() is granted even if this_object() is altered by
 * set_this_object(). This does not apply to functions inherited from
 * other programs.
 *
 * Use it with extreme care to avoid inconsistencies.  After a call of
 * set_this_object(), some LPC-constructs might behave in an odd
 * manner, or even crash the system. In particular, using global
 * variables or calling local functions (except by call_other) is
 * illegal.
 *
 * With the current implementation, global variables can be accessed,
 * but this is not guaranteed to work in subsequent versions.
 *
 * Allowed are call_other, map functions, access of local variables
 * (which might hold array pointers to a global array), simple
 * arithmetic and the assignment operators.
 */

{

    if (sp->u.ob != current_object)
    {
        if ((master_ob != NULL && current_variables == master_ob->variables)
         || (simul_efun_object != NULL && current_variables == simul_efun_object->variables)
         || privilege_violation(STR_SET_THIS_OBJECT, sp, sp))
        {
            struct control_stack *p;

            /* Find the 'extern_call' entry in the call stack which
             * determined the current this_object().
             */
            for (p = csp; !p->extern_call; p--) NOOP;

            p->extern_call |= CS_PRETEND;
            p->pretend_to_be = current_object = sp->u.ob;
        }
    }

    free_svalue(sp);
    sp--;
    return sp;
} /* f_set_this_object() */

/*-------------------------------------------------------------------------*/
svalue_t *
f_trace (svalue_t *sp)

/* EFUN trace()
 *
 *   int trace(int traceflags)
 *
 * Sets the trace flags and returns the old trace flags. When
 * tracing is on, a lot of information is printed during
 * execution and too much output can crash your connection or
 * even the whole driver.
 *
 * Tracing is done on a per-connection basis: each interactive(!)
 * user may specifiy its own tracelevel and -prefix. Each gets the
 * traceoutput for just the code executed during the evaluation
 * of the commands he entered.
 *
 * The trace bits are:
 *
 *   TRACE_NOTHING     (  0): stop tracing.
 *
 *   TRACE_CALL        (  1): trace all calls to lfuns.
 *   TRACE_CALL_OTHER  (  2): trace call_others()s.
 *   TRACE_RETURN      (  4): trace function returns.
 *   TRACE_ARGS        (  8): print function arguments and results.
 *   TRACE_EXEC        ( 16): trace all executed instructions.
 *   TRACE_HEART_BEAT  ( 32): trace heartbeat code.
 *   TRACE_APPLY       ( 64): trace driver applies.
 *   TRACE_OBJNAME     (128): print the object names.
 *
 * TRACE_EXEC and TRACE_HEART_BEAT should be avoided as they cause massive
 * output! TRACE_OBJNAME should be avoided when you know what you trace.
 *
 * The master-lfun valid_trace() is called to verify the
 * usage of this efun.
 */

{
    int ot;
    interactive_t *ip;

    ot = -1;

    /* If the command_giver is allowed to do so... */
    if (command_giver
     && O_SET_INTERACTIVE(ip, command_giver))
    {
        svalue_t *arg;

        assign_eval_cost_inl();
        inter_sp = sp;
        push_ref_string(inter_sp, STR_TRACE);
        push_number(inter_sp, sp->u.number);
        arg = apply_master(STR_VALID_TRACE, 2);
        if (arg)
        {
            /* ... then set the new tracelevel */
            if (arg->type != T_NUMBER || arg->u.number != 0)
            {
                ot = ip->trace_level;
                trace_level |=
                  ip->trace_level = sp->u.number;
            }
        }
    }

    /* Return the old level */
    sp->u.number = ot;
    SET_TRACE_EXEC;
    return sp;
} /* f_trace() */

/*-------------------------------------------------------------------------*/
svalue_t *
f_traceprefix (svalue_t *sp)

/* EFUN traceprefix()
 *
 *   string traceprefix(string prefix)
 *   string traceprefix(int dummy)
 *
 * If called with a string, only objects matching this prefix will be traced.
 * The string must not contain a leading "/" because the object names are
 * stored internally without it. If called with a number, the traceprefix will
 * be ignored and all objects will be traced. Returns the last traceprefix or
 * 0 if there wasn't any.
 *
 * The master-lfun valid_trace() is called to verify the usage of this
 * efun.
 */

{
    string_t *old;
    interactive_t *ip;

    old = NULL;

    /* If the command_giver is allowed to do that... */
    if (command_giver
     && O_SET_INTERACTIVE(ip, command_giver))
    {
        svalue_t *arg;

        inter_sp = sp;
        push_ref_string(inter_sp, STR_TRACEPREFIX);
        inter_sp++; assign_svalue_no_free(inter_sp, sp);
        assign_eval_cost_inl();
        arg = apply_master(STR_VALID_TRACE,2);
        if (arg)
        {
            /* ... then so shall it be */
            if (arg && (arg->type != T_NUMBER || arg->u.number))
            {
                old = ip->trace_prefix;
                if (sp->type == T_STRING)
                {
                    ip->trace_prefix = make_tabled_from(sp->u.str);
                      /* tabled for faster comparisons */
                }
                else
                    ip->trace_prefix = NULL;
            }
        }
    }

    free_svalue(sp);

    /* Return the old prefix */
    if (old)
        put_string(sp, old);
    else
        put_number(sp, 0);
    return sp;
} /* f_traceprefix() */

/***************************************************************************/