Logo Search packages:      
Sourcecode: ecl version File versions  Download package

interpreter.d

/*
    interpreter.c -- Bytecode interpreter.
*/
/*
    Copyright (c) 2001, Juan Jose Garcia Ripoll.

    ECL is free software; you can redistribute it and/or
    modify it under the terms of the GNU Library General Public
    License as published by the Free Software Foundation; either
    version 2 of the License, or (at your option) any later version.

    See file '../Copyright' for full details.
*/

#include <ecl/ecl.h>
#include <string.h>
#include <ecl/ecl-inl.h>
#include <ecl/bytecodes.h>

#undef frs_pop
#define frs_pop() { \
      cl_env.stack_top = cl_env.stack + cl_env.frs_top->frs_sp; \
      cl_env.frs_top--; }

/* -------------------- INTERPRETER STACK -------------------- */

void
cl_stack_set_size(cl_index new_size)
{
      cl_index top = cl_env.stack_top - cl_env.stack;
      cl_object *new_stack;

      /*printf("*+*+*+\n");*/

      if (top > new_size)
            FEerror("Internal error: cannot shrink stack that much.",0);

      start_critical_section();

      new_stack = (cl_object *)cl_alloc_atomic(new_size * sizeof(cl_object));
      memcpy(new_stack, cl_env.stack, cl_env.stack_size * sizeof(cl_object));

#ifdef BOEHM_GBC
      GC_free(cl_env.stack);
#else
      cl_dealloc(cl_env.stack, cl_env.stack_size);
#endif
      cl_env.stack_size = new_size;
      cl_env.stack = new_stack;
      cl_env.stack_top = cl_env.stack + top;
      cl_env.stack_limit = cl_env.stack + (new_size - 2);

      end_critical_section();
}

static void
cl_stack_grow(void)
{
      cl_stack_set_size(cl_env.stack_size + LISP_PAGESIZE);
}

void
cl_stack_push(cl_object x) {
      if (cl_env.stack_top >= cl_env.stack_limit)
            cl_stack_grow();
      *(cl_env.stack_top++) = x;
}

cl_object
cl_stack_pop() {
      if (cl_env.stack_top == cl_env.stack)
            FEerror("Internal error: stack underflow.",0);
      return *(--cl_env.stack_top);
}

cl_index
cl_stack_index() {
      return cl_env.stack_top - cl_env.stack;
}

void
cl_stack_set_index(cl_index index) {
      cl_object *new_top = cl_env.stack + index;
      if (new_top > cl_env.stack_top)
            FEerror("Internal error: tried to advance stack.",0);
      cl_env.stack_top = new_top;
}

void
cl_stack_insert(cl_index where, cl_index n) {
      if (cl_env.stack_top + n > cl_env.stack_limit) {
            cl_index delta = (n + (LISP_PAGESIZE-1))/LISP_PAGESIZE;
            cl_stack_set_size(cl_env.stack_size + delta * LISP_PAGESIZE);
      }
      cl_env.stack_top += n;
      memmove(&cl_env.stack[where+n], &cl_env.stack[where],
            (cl_env.stack_top - cl_env.stack) * sizeof(cl_object));
}

void
cl_stack_pop_n(cl_index index) {
      cl_object *new_top = cl_env.stack_top - index;
      if (new_top < cl_env.stack)
            FEerror("Internal error: stack underflow.",0);
      cl_env.stack_top = new_top;
}

cl_index
cl_stack_push_values(void) {
      cl_index i;
      for (i=0; i<NVALUES; i++)
            cl_stack_push(VALUES(i));
      return i;
}

void
cl_stack_pop_values(cl_index n) {
      NVALUES = n;
      while (n > 0)
            VALUES(--n) = cl_stack_pop();
}

cl_index
cl_stack_push_va_list(cl_va_list args) {
      cl_index sp;

      sp = cl_env.stack_top - cl_env.stack;
      while (cl_env.stack_top + args[0].narg > cl_env.stack_limit)
            cl_stack_grow();
      while (args[0].narg > 0) {
            *(cl_env.stack_top++) = cl_va_arg(args);
      }
      return sp;
}

cl_index
cl_stack_push_list(cl_object list)
{
      cl_index n;
      cl_object fast, slow;

      /* INV: A list's length always fits in a fixnum */
      fast = slow = list;
      for (n = 0; CONSP(fast); n++, fast = CDR(fast)) {
            *cl_env.stack_top = CAR(fast);
            if (++cl_env.stack_top >= cl_env.stack_limit)
                  cl_stack_grow();
            if (n & 1) {
                  /* Circular list? */
                  if (slow == fast) break;
                  slow = CDR(slow);
            }
      }
      if (fast != Cnil)
            FEtype_error_proper_list(list);
      return n;
}

/* ------------------------------ LEXICAL ENV. ------------------------------ */

#define bind_var(var, val) \
      (cl_env.lex_env = CONS(CONS(var, val), cl_env.lex_env))
#define bind_function(name, fun) \
      (cl_env.lex_env = CONS(CONS(fun, name), cl_env.lex_env))
#define bind_block(name, id) \
      (cl_env.lex_env = CONS(CONS(id, name), cl_env.lex_env))
#define bind_tagbody(id) \
      (cl_env.lex_env = CONS(CONS(id, MAKE_FIXNUM(0)), cl_env.lex_env))

static cl_object
ecl_lex_env_get_record(register int s) {
      cl_object x;
      for (x = cl_env.lex_env; s-- > 0; x = CDR(x));
      if (Null(x))
            FEerror("Internal error: local not found.", 0);
      return CAR(x);
}

#define ecl_lex_env_get_var(x) CDR(ecl_lex_env_get_record(x))
#define ecl_lex_env_set_var(x,v) (CDR(ecl_lex_env_get_record(x)) = (v))
#define ecl_lex_env_get_fun(x) CAR(ecl_lex_env_get_record(x))
#define ecl_lex_env_get_tag(x) CAR(ecl_lex_env_get_record(x))

/* -------------------- LAMBDA FUNCTIONS -------------------- */

static void
lambda_bind_var(cl_object var, cl_object val, cl_object specials)
{
      if (!member_eq(var, specials))
            bind_var(var, val);
      else
            bds_bind(var, val);
}

static void
lambda_bind(cl_narg narg, cl_object lambda, cl_index sp)
{
      cl_object *data = lambda->bytecodes.data;
      cl_object specials = lambda->bytecodes.specials;
      int i, n;
      bool check_remaining = TRUE;

      /* 1) REQUIRED ARGUMENTS:  N var1 ... varN */
      n = fix(*(data++));
      if (narg < n)
        FEwrong_num_arguments(lambda->bytecodes.name);
      for (; n; n--, narg--)
        lambda_bind_var(*(data++), cl_env.stack[sp++], specials);

      /* 2) OPTIONAL ARGUMENTS:  N var1 value1 flag1 ... varN valueN flagN */
      for (n = fix(*(data++)); n; n--, data+=3) {
        if (narg) {
          lambda_bind_var(data[0], cl_env.stack[sp], specials);
          sp++; narg--;
          if (!Null(data[2]))
            lambda_bind_var(data[2], Ct, specials);
        } else {
          cl_object defaults = data[1];
          if (FIXNUMP(defaults)) {
            interpret(lambda, (cl_opcode*)lambda->bytecodes.code + fix(defaults));
            defaults = VALUES(0);
          }
          lambda_bind_var(data[0], defaults, specials);
          if (!Null(data[2]))
            lambda_bind_var(data[2], Cnil, specials);
        }
      }

      /* 3) REST ARGUMENT: {rest-var | NIL} */
      if (!Null(data[0])) {
        cl_object rest = Cnil;
        check_remaining = FALSE;
        for (i=narg; i; )
          rest = CONS(cl_env.stack[sp+(--i)], rest);
        lambda_bind_var(data[0], rest, specials);
      }
      data++;

      /* 4) ALLOW-OTHER-KEYS: { T | NIL | 0} */
      if (data[0] == MAKE_FIXNUM(0)) {
        data++;
        if (narg && check_remaining)
          FEprogram_error("LAMBDA: Too many arguments to function ~S.", 1,
                      lambda->bytecodes.name);
      } else {
        /*
         * Only when ALLOW-OTHER-KEYS /= 0, we process this:
         * 5) KEYWORDS: N key1 var1 value1 flag1 ... keyN varN valueN flagN
         */
        bool allow_other_keys = !Null(*(data++));
        bool allow_other_keys_found = allow_other_keys;
        int n = fix(*(data++));
        cl_object *keys;
#ifdef __GNUC__
        cl_object spp[n];
#else
#define SPP_MAX 64
        cl_object spp[SPP_MAX];
#endif
        bool other_found = FALSE;
        void *unbound = spp; /* not a valid lisp object */
        if ((narg & 1) != 0)
          FEprogram_error("Function called with odd number of keyword arguments.", 0);
        for (i=0; i<n; i++)
#ifdef __GNUC__
          spp[i] = unbound;
#else
          if (i >= SPP_MAX)
            FEerror("lambda_bind: Too many keyword arguments, limited to ~A.", 1, MAKE_FIXNUM(SPP_MAX));
          else
          spp[i] = unbound;
#endif
        for (; narg; narg-=2) {
          cl_object key = cl_env.stack[sp++];
          cl_object value = cl_env.stack[sp++];
          if (!SYMBOLP(key))
            FEprogram_error("LAMBDA: Keyword expected, got ~S.", 1, key);
          keys = data;
          if (key == @':allow-other-keys') {
            if (!allow_other_keys_found) {
            allow_other_keys_found = TRUE;
            allow_other_keys = !Null(value);
            }
          }
          for (i = 0; i < n; i++, keys += 4) {
            if (key == keys[0]) {
            if (spp[i] == unbound)
              spp[i] = value;
            goto FOUND;
            }
          }
          if (key != @':allow-other-keys')
            other_found = TRUE;
        FOUND:
          (void)0;
        }
        if (other_found && !allow_other_keys)
          FEprogram_error("LAMBDA: Unknown keys found in function ~S.",
                      1, lambda->bytecodes.name);
        for (i=0; i<n; i++, data+=4) {
          if (spp[i] != unbound)
            lambda_bind_var(data[1],spp[i],specials);
          else {
            cl_object defaults = data[2];
            if (FIXNUMP(defaults)) {
                  interpret(lambda, (cl_opcode*)lambda->bytecodes.code + fix(defaults));
                  defaults = VALUES(0);
            }
            lambda_bind_var(data[1],defaults,specials);
          }
          if (!Null(data[3]))
            lambda_bind_var(data[3],(spp[i] != unbound)? Ct : Cnil,specials);
        }
      }
}

cl_object
lambda_apply(cl_narg narg, cl_object fun)
{
      cl_index args = cl_stack_index() - narg;
      cl_object name;
      bds_ptr old_bds_top;
      struct ihs_frame ihs;

      if (type_of(fun) != t_bytecodes)
            FEinvalid_function(fun);

      /* Save the lexical environment and set up a new one */
      ihs_push(&ihs, fun);
      cl_env.lex_env = fun->bytecodes.lex;
      old_bds_top = cl_env.bds_top;

      /* Establish bindings */
      lambda_bind(narg, fun, args);

      /* If it is a named lambda, set a block for RETURN-FROM */
      VALUES(0) = Cnil;
      NVALUES = 0;
      name = fun->bytecodes.name;
      interpret(fun, fun->bytecodes.code);
      bds_unwind(old_bds_top);
      ihs_pop();
      returnn(VALUES(0));
}


/* -------------------- AIDS TO THE INTERPRETER -------------------- */

static cl_object
search_global(register cl_object s) {
      cl_object x = SYM_VAL(s);
      if (x == OBJNULL)
            FEunbound_variable(s);
      return x;
}

/*
 * INTERPRET-FUNCALL is one of the few ways to "exit" the interpreted
 * environment and get into the C/lisp world. Since almost all data from the
 * interpreter is kept in local variables, and frame stacks, binding stacks,
 * etc, are already handled by the C core, only the lexical environment
 * (cl_env.lex_env) needs to be saved.
 */
static cl_object
interpret_funcall(cl_narg narg, cl_object fun) {
      cl_object lex_env = cl_env.lex_env;
      cl_object *args;
      cl_object x;
      args = cl_env.stack_top - narg;
      if (fun == OBJNULL || fun == Cnil)
            goto ERROR;
 AGAIN:
      switch (type_of(fun)) {
      case t_cfun: {
            struct ihs_frame ihs;
            ihs_push(&ihs, fun->cfun.name);
            if (fun->cfun.narg >= 0) {
                  if (narg != fun->cfun.narg)
                        FEwrong_num_arguments(fun);
                  x = APPLY_fixed(narg, (cl_objectfn_fixed)fun->cfun.entry, args);
            } else {
                  x = APPLY(narg, fun->cfun.entry, args);
            }
            ihs_pop();
            break;
      }
      case t_cclosure:{
            struct ihs_frame ihs;
            ihs_push(&ihs, fun);
            x = APPLY_closure(narg, fun->cclosure.entry, fun->cclosure.env, args);
            ihs_pop();
            break;
      }
#ifdef CLOS
      case t_instance:
            fun = compute_method(narg, fun, args);
            if (fun == NULL) {
                  x = VALUES(0);
                  break;
            }
            goto AGAIN;
#endif
      case t_bytecodes:
            x = lambda_apply(narg, fun);
            break;
      case t_symbol: {
            cl_object function = SYM_FUN(fun);
            if (function == Cnil || fun->symbol.mflag)
                  FEundefined_function(fun);
            fun = function;
            goto AGAIN;
      }
      default: ERROR:
            FEinvalid_function(fun);
      }
      cl_env.lex_env = lex_env;
      cl_stack_pop_n(narg);
      return x;
}

@(defun apply (fun lastarg &rest args)
      cl_index i;
@
      narg -= 2;
      for (i = 0; narg; i++,narg--) {
            cl_stack_push(lastarg);
            lastarg = cl_va_arg(args);
      }
      loop_for_in (lastarg) {
            if (i >= CALL_ARGUMENTS_LIMIT) {
                  cl_stack_pop_n(i);
                  FEprogram_error("CALL-ARGUMENTS-LIMIT exceeded",0);
            }
            cl_stack_push(CAR(lastarg));
            i++;
      } end_loop_for_in;
      returnn(interpret_funcall(i, fun));
@)

/* -------------------- THE INTERPRETER -------------------- */

static cl_object
close_around(cl_object fun, cl_object lex) {
      cl_object v = cl_alloc_object(t_bytecodes);
      v->bytecodes = fun->bytecodes;
      v->bytecodes.lex = lex;
      return v;
}

/* OP_FLET  nfun{arg}
   fun1{object}
   ...
   funn{object}
   ...
   OP_UNBIND n

      Executes the enclosed code in a lexical enviroment extended with
      the functions "fun1" ... "funn".
*/
static cl_opcode *
interpret_flet(cl_object bytecodes, cl_opcode *vector) {
      cl_index nfun = GET_OPARG(vector);

      /* 1) Copy the environment so that functions get it without references
            to themselves. */
      cl_object lex = cl_env.lex_env;

      /* 3) Add new closures to environment */
      while (nfun--) {
            cl_object fun = GET_DATA(vector, bytecodes);
            cl_object f = close_around(fun,lex);
            bind_function(f->bytecodes.name, f);
      }
      return vector;
}

/* OP_LABELS      nfun{arg}
   fun1{object}
   ...
   funn{object}
   ...
   OP_UNBIND n

      Executes the enclosed code in a lexical enviroment extended with
      the functions "fun1" ... "funn".
*/
static cl_opcode *
interpret_labels(cl_object bytecodes, cl_opcode *vector) {
      cl_index i, nfun = GET_OPARG(vector);
      cl_object l;

      /* 1) Build up a new environment with all functions */
      for (i=0; i<nfun; i++) {
            cl_object f = GET_DATA(vector, bytecodes);
            bind_function(f->bytecodes.name, f);
      }

      /* 2) Update the closures so that all functions can call each other */
      for (i=0, l=cl_env.lex_env; i<nfun; i++) {
            cl_object record = CAR(l);
            CAR(record) = close_around(CAR(record), cl_env.lex_env);
            l = CDR(l);
      }
      return vector;
}

/* OP_MSETQ n{arg}
   {fixnumn}
   ...
   {fixnum1}

      Sets N variables to the N values in VALUES(), filling with
      NIL when there are values missing. Local variables are denoted
      with an integer which points a position in the lexical environment,
      while special variables are denoted with a negative index X, which
      denotes the value -1-X in the table of constants.
*/
static cl_opcode *
interpret_msetq(cl_object bytecodes, cl_opcode *vector)
{
      cl_object value;
      cl_index i, n = GET_OPARG(vector);
      for (i=0; i<n; i++) {
            cl_fixnum var = GET_OPARG(vector);
            value = (i < NVALUES) ? VALUES(i) : Cnil;
            if (var >= 0)
                  ecl_lex_env_set_var(var, value);
            else {
                  cl_object name = bytecodes->bytecodes.data[-1-var];
                  if (name->symbol.stype == stp_constant)
                        FEassignment_to_constant(name);
                  else
                        ECL_SETQ(name, value);
            }
      }
      if (NVALUES == 0) {
            VALUES(0) = Cnil;
      }
      NVALUES = 1;
      return vector;
}

/* OP_PROGV bindings{list}
   ...
   OP_EXIT
      Execute the code enclosed with the special variables in BINDINGS
      set to the values in the list which was passed in VALUES(0).
*/
static cl_opcode *
interpret_progv(cl_object bytecodes, cl_opcode *vector) {
      cl_object values = VALUES(0);
      cl_object vars = cl_stack_pop();

      /* 1) Save current environment */
      bds_ptr old_bds_top = cl_env.bds_top;
      cl_object old_lex_env = cl_env.lex_env;

      /* 2) Add new bindings */
      while (!endp(vars)) {
            if (values == Cnil)
                  bds_bind(CAR(vars), OBJNULL);
            else {
                  bds_bind(CAR(vars), cl_car(values));
                  values = CDR(values);
            }
            vars = CDR(vars);
      }
      vector = interpret(bytecodes, vector);

      /* 3) Restore environment */
      cl_env.lex_env = old_lex_env;
      bds_unwind(old_bds_top);
      return vector;
}

void *
interpret(cl_object bytecodes, void *pc) {
      cl_opcode *vector = pc;
      cl_object reg0 = VALUES(0), reg1;
      static int i = 0;
      i++;
 BEGIN:
      switch (GET_OPCODE(vector)) {
      /* OP_QUOTE
            Sets REG0 to an immediate value.
      */
      case OP_QUOTE:
            reg0 = GET_DATA(vector, bytecodes);
            break;

      /* OP_VAR   n{arg}, var{symbol}
            Sets REG0 to the value of the n-th local.
            VAR is the name of the variable for readability purposes.
      */
      case OP_VAR: {
            int lex_env_index = GET_OPARG(vector);
            reg0 = ecl_lex_env_get_var(lex_env_index);
            break;
      }

      /* OP_VARS  var{symbol}
            Sets REG0 to the value of the symbol VAR.
            VAR should be either a special variable or a constant.
      */
      case OP_VARS: {
            cl_object var_name = GET_DATA(vector, bytecodes);
            reg0 = search_global(var_name);
            break;
      }

      /* OP_PUSH
            Pushes the object in VALUES(0).
      */
      case OP_PUSH:
            cl_stack_push(reg0);
            break;

      /* OP_PUSHV n{arg}
            Pushes the value of the n-th local onto the stack.
      */
      case OP_PUSHV: {
            int lex_env_index = GET_OPARG(vector);
            cl_stack_push(ecl_lex_env_get_var(lex_env_index));
            break;
      }

      /* OP_PUSHVS      var{symbol}
            Pushes the value of the symbol VAR onto the stack.
            VAR should be either a special variable or a constant.
      */
      case OP_PUSHVS: {
            cl_object var_name = GET_DATA(vector, bytecodes);
            cl_stack_push(search_global(var_name));
            break;
      }

      /* OP_PUSHQ value{object}
            Pushes "value" onto the stack.
      */
      case OP_PUSHQ:
            cl_stack_push(GET_DATA(vector, bytecodes));
            break;

      /* OP_CALL  n{arg}
            Calls the function in REG0 with N arguments which
            have been deposited in the stack. The output values
            are left in VALUES(...)
      */
      case OP_CALL: {
            cl_fixnum n = GET_OPARG(vector);
            VALUES(0) = reg0 = interpret_funcall(n, reg0);
            break;
      }

      /* OP_CALLG n{arg}, name{arg}
            Calls the function NAME with N arguments which have been
            deposited in the stack. The output values are left in VALUES.
      */
      case OP_CALLG: {
            cl_fixnum n = GET_OPARG(vector);
            cl_object f = GET_DATA(vector, bytecodes);
            VALUES(0) = reg0 = interpret_funcall(n, f);
            break;
      }

      /* OP_FCALL n{arg}
            Calls a function in the stack with N arguments which
            have been also deposited in the stack. The output values
            are left in VALUES(...)
      */
      case OP_FCALL: {
            cl_fixnum n = GET_OPARG(vector);
            cl_object fun = cl_env.stack_top[-n-1];
            VALUES(0) = reg0 = interpret_funcall(n, fun);
            cl_stack_pop();
            break;
      }

      /* OP_MCALL
            Similar to FCALL, but gets the number of arguments from
            the stack (They all have been deposited by OP_PUSHVALUES)
      */
      case OP_MCALL: {
            cl_fixnum n = fix(cl_stack_pop());
            cl_object fun = cl_env.stack_top[-n-1];
            VALUES(0) = reg0 = interpret_funcall(n, fun);
            cl_stack_pop();
            break;
      }

      /* OP_PCALL n{arg}
            Calls the function in REG0 with N arguments which
            have been deposited in the stack. The first output value
            is pushed on the stack.
      */
      case OP_PCALL: {
            cl_fixnum n = GET_OPARG(vector);
            cl_stack_push(interpret_funcall(n, reg0));
            break;
      }

      /* OP_PCALLG      n{arg}, name{arg}
            Calls the function NAME with N arguments which have been
            deposited in the stack. The first output value is pushed on
            the stack.
      */
      case OP_PCALLG: {
            cl_fixnum n = GET_OPARG(vector);
            cl_object f = GET_DATA(vector, bytecodes);
            cl_stack_push(interpret_funcall(n, f));
            break;
      }

      /* OP_PFCALL      n{arg}
            Calls the function in the stack with N arguments which
            have been also deposited in the stack. The first output value
            is pushed on the stack.
      */
      case OP_PFCALL: {
            cl_fixnum n = GET_OPARG(vector);
            cl_object fun = cl_env.stack_top[-n-1];
            cl_object reg0 = interpret_funcall(n, fun);
            cl_env.stack_top[-1] = reg0;
            break;
      }

      /* OP_EXIT
            Marks the end of a high level construct (BLOCK, CATCH...)
            or a function.
      */
      case OP_EXIT:
            return (char *)vector;

      case OP_FLET:
            vector = interpret_flet(bytecodes, vector);
            break;
      case OP_LABELS:
            vector = interpret_labels(bytecodes, vector);
            break;

      /* OP_LFUNCTION   n{arg}, function-name{symbol}
            Calls the local or global function with N arguments
            which have been deposited in the stack.
      */
      case OP_LFUNCTION: {
            int lex_env_index = GET_OPARG(vector);
            cl_object fun_record = ecl_lex_env_get_record(lex_env_index);
            reg0 = CAR(fun_record);
            break;
      }

      /* OP_FUNCTION    name{symbol}
            Extracts the function associated to a symbol. The function
            may be defined in the global environment or in the local
            environment. This last value takes precedence.
      */
      case OP_FUNCTION:
            reg0 = ecl_fdefinition(GET_DATA(vector, bytecodes));
            break;

      /* OP_CLOSE name{symbol}
            Extracts the function associated to a symbol. The function
            may be defined in the global environment or in the local
            environment. This last value takes precedence.
      */
      case OP_CLOSE: {
            cl_object function_object = GET_DATA(vector, bytecodes);
            reg0 = close_around(function_object, cl_env.lex_env);
            break;
      }
      /* OP_GO    n{arg}
         OP_QUOTE tag-name{symbol}
            Jumps to the tag which is defined at the n-th position in
            the lexical environment. TAG-NAME is kept for debugging
            purposes.
      */
      case OP_GO: {
            cl_object id = ecl_lex_env_get_tag(GET_OPARG(vector));
            cl_object tag_name = GET_DATA(vector, bytecodes);
            cl_go(id, tag_name);
            break;
      }
      /* OP_RETURN      n{arg}
            Returns from the block whose record in the lexical environment
            occuppies the n-th position.
      */
      case OP_RETURN: {
            int lex_env_index = GET_OPARG(vector);
            cl_object block_record = ecl_lex_env_get_record(lex_env_index);
            cl_object id = CAR(block_record);
            cl_object block_name = CDR(block_record);
            cl_return_from(id, block_name);
            break;
      }
      /* OP_THROW
            Jumps to an enclosing CATCH form whose tag matches the one
            of the THROW. The tag is taken from the stack, while the
            output values are left in VALUES(...).
      */
      case OP_THROW: {
            cl_object tag_name = cl_stack_pop();
            cl_throw(tag_name);
            break;
      }
      /* OP_JMP   label{arg}
         OP_JNIL  label{arg}
         OP_JT    label{arg}
         OP_JEQ   value{object}, label{arg}
         OP_JNEQ  value{object}, label{arg}
            Direct or conditional jumps. The conditional jumps are made
            comparing with the value of REG0.
      */
      case OP_JMP: {
            cl_oparg jump = GET_OPARG(vector);
            vector += jump - OPARG_SIZE;
            break;
      }
      case OP_JNIL: {
            cl_oparg jump = GET_OPARG(vector);
            NVALUES = 1;
            if (Null(VALUES(0)))
                  vector += jump - OPARG_SIZE;
            break;
      }
      case OP_JT: {
            cl_oparg jump = GET_OPARG(vector);
            NVALUES = 1;
            if (!Null(VALUES(0)))
                  vector += jump - OPARG_SIZE;
            break;
      }
      case OP_JEQL: {
            cl_oparg value = GET_OPARG(vector);
            cl_oparg jump = GET_OPARG(vector);
            if (eql(reg0, bytecodes->bytecodes.data[value]))
                  vector += jump - OPARG_SIZE;
            break;
      }
      case OP_JNEQL: {
            cl_oparg value = GET_OPARG(vector);
            cl_oparg jump = GET_OPARG(vector);
            if (!eql(reg0, bytecodes->bytecodes.data[value]))
                  vector += jump - OPARG_SIZE;
            break;
      }
      case OP_NOT:
            reg0 = (reg0 == Cnil)? Ct : Cnil;
            break;
      /* OP_UNBIND      n{arg}
            Undo "n" local bindings.
      */
      case OP_UNBIND: {
            cl_index n = GET_OPARG(vector);
            while (n--)
                  cl_env.lex_env = CDR(cl_env.lex_env);
            break;
      }
      /* OP_UNBINDS     n{arg}
            Undo "n" bindings of special variables.
      */
      case OP_UNBINDS: {
            cl_index n = GET_OPARG(vector);
            bds_unwind_n(n);
            break;
      }
      /* OP_BIND  name{symbol}
         OP_PBIND name{symbol}
         OP_BINDS name{symbol}
         OP_PBINDS      name{symbol}
            Binds a lexical or special variable to the either the
            value of REG0 or the first value of the stack.
      */
      case OP_BIND: {
            cl_object var_name = GET_DATA(vector, bytecodes);
            bind_var(var_name, reg0);
            break;
      }
      case OP_PBIND: {
            cl_object var_name = GET_DATA(vector, bytecodes);
            cl_object value = cl_stack_pop();
            bind_var(var_name, value);
            break;
      }
      case OP_VBIND: {
            cl_index n = GET_OPARG(vector);
            cl_object var_name = GET_DATA(vector, bytecodes);
            cl_object value = (n < NVALUES) ? VALUES(n) : Cnil;
            bind_var(var_name, value);
            break;
      }
      case OP_BINDS: {
            cl_object var_name = GET_DATA(vector, bytecodes);
            bds_bind(var_name, reg0);
            break;
      }
      case OP_PBINDS: {
            cl_object var_name = GET_DATA(vector, bytecodes);
            cl_object value = cl_stack_pop();
            bds_bind(var_name, value);
            break;
      }
      case OP_VBINDS: {
            cl_index n = GET_OPARG(vector);
            cl_object var_name = GET_DATA(vector, bytecodes);
            cl_object value = (n < NVALUES) ? VALUES(n) : Cnil;
            bds_bind(var_name, value);
            break;
      }
      /* OP_SETQ  n{arg}
         OP_PSETQ n{arg}
         OP_SETQS var-name{symbol}
         OP_PSETQS      var-name{symbol}
            Sets either the n-th local or a special variable VAR-NAME,
            to either the value in REG0 (OP_SETQ[S]) or to the 
            first value on the stack (OP_PSETQ[S]).
      */
      case OP_SETQ: {
            int lex_env_index = GET_OPARG(vector);
            ecl_lex_env_set_var(lex_env_index, reg0);
            break;
      }
      case OP_SETQS: {
            cl_object var = GET_DATA(vector, bytecodes);
            if (var->symbol.stype == stp_constant)
                  FEassignment_to_constant(var);
            ECL_SETQ(var, reg0);
            break;
      }
      case OP_PSETQ: {
            int lex_env_index = GET_OPARG(vector);
            ecl_lex_env_set_var(lex_env_index, cl_stack_pop());
            break;
      }
      case OP_PSETQS: {
            cl_object var = GET_DATA(vector, bytecodes);
            if (var->symbol.stype == stp_constant)
                  FEassignment_to_constant(var);
            ECL_SETQ(var, cl_stack_pop());
            break;
      }

      /* OP_BLOCK label{arg}
         ...
         OP_EXIT_FRAME
       label:

         Executes the enclosed code in a named block.
         LABEL points to the first instruction after OP_EXIT.
      */
      case OP_BLOCK:
            reg0 = GET_DATA(vector, bytecodes);
            reg1 = new_frame_id();
            goto DO_BLOCK;
      /* OP_CATCH label{arg}
         ...
         OP_EXIT_FRAME
         label:

         Sets a catch point using the tag in VALUES(0). LABEL points to the
         first instruction after the end (OP_EXIT) of the block
      */
      case OP_CATCH:
            reg1 = reg0;
            goto DO_BLOCK;
      /* OP_DO    label
           ...    ; code executed within a NIL block
         OP_EXIT_FRAME
         label:

         High level construct for the DO and BLOCK forms.
      */
      case OP_DO:
            reg0 = Cnil;
            reg1 = new_frame_id();
      DO_BLOCK: {
            cl_opcode *exit;
            GET_LABEL(exit, vector);
            cl_stack_push((cl_object)exit);
            if (frs_push(reg1) == 0) {
                  cl_env.lex_env = CONS(CONS(reg1, reg0), cl_env.lex_env);
            } else {
                  reg0 = VALUES(0);
                  cl_env.lex_env = cl_env.frs_top->frs_lex;
                  frs_pop();
                  vector = (cl_opcode *)cl_stack_pop(); /* FIXME! */
            }
            break;
            }
      case OP_EXIT_FRAME:
            bds_unwind(cl_env.frs_top->frs_bds_top);
            cl_env.lex_env = cl_env.frs_top->frs_lex;
            frs_pop();
            cl_stack_pop();
            break;
      /* OP_TAGBODY     n{arg}
           label1
           ...
           labeln
         label1:
           ...
         labeln:
           ...
         OP_EXIT_TAGBODY

         High level construct for the TAGBODY form.
      */
      case OP_TAGBODY: {
            cl_object id = new_frame_id();
            int n = GET_OPARG(vector);
            /* Here we save the location of the jump table */
            cl_stack_push((cl_object)vector); /* FIXME! */
            bind_tagbody(id);
            if (frs_push(id) == 0) {
                  /* The first time, we "name" the tagbody and
                   * skip the jump table */
                  vector += n * OPARG_SIZE;
            } else {
                  /* Wait here for gotos. Each goto sets
                     VALUES(0) to an integer which ranges from 0
                     to ntags-1, depending on the tag. These
                     numbers are indices into the jump table and
                     are computed at compile time. */
                  cl_opcode *table = (cl_opcode *)cl_env.stack_top[-1];
                  table = table + fix(VALUES(0)) * OPARG_SIZE;
                  vector = table + *(cl_oparg *)table;
                  cl_env.lex_env = cl_env.frs_top->frs_lex;
            }
            break;
      }
      case OP_EXIT_TAGBODY:
            cl_env.lex_env = CDR(cl_env.frs_top->frs_lex);
            frs_pop();
            cl_stack_pop();
      case OP_NIL:
            reg0 = Cnil;
            break;
      case OP_PUSHNIL:
            cl_stack_push(Cnil);
            break;
      case OP_VALUEREG0:
            VALUES(0) = reg0;
            NVALUES = 1;
            break;
      case OP_NOP:
            VALUES(0) = reg0 = Cnil;
            NVALUES = 0;
            break;
      case OP_MSETQ:
            vector = interpret_msetq(bytecodes, vector);
            reg0 = VALUES(0);
            break;
      case OP_PROGV:
            vector = interpret_progv(bytecodes, vector);
            reg0 = VALUES(0);
            break;
      /* OP_PUSHVALUES
            Pushes the values output by the last form, plus the number
            of values.
      */
      PUSH_VALUES:
      case OP_PUSHVALUES: {
            cl_index i;
            for (i=0; i<NVALUES; i++)
                  cl_stack_push(VALUES(i));
            cl_stack_push(MAKE_FIXNUM(NVALUES));
            break;
      }
      /* OP_PUSHMOREVALUES
            Adds more values to the ones pushed by OP_PUSHVALUES.
      */
      case OP_PUSHMOREVALUES: {
            cl_index i, n = fix(cl_stack_pop());
            for (i=0; i<NVALUES; i++)
                  cl_stack_push(VALUES(i));
            cl_stack_push(MAKE_FIXNUM(n + NVALUES));
            break;
      }
      /* OP_POP
            Pops a singe value pushed by a OP_PUSH* operator.
      */
      case OP_POP:
            VALUES(0) = reg0 = cl_stack_pop();
            NVALUES = 1;
            break;
      /* OP_POPVALUES
            Pops all values pushed by a OP_PUSHVALUES operator.
      */
      case OP_POPVALUES: {
            int n = NVALUES = fix(cl_stack_pop());
            if (n == 0) {
                  VALUES(0) = Cnil;
            } else do {
                  VALUES(--n) = cl_stack_pop();
            } while (n);
            reg0 = VALUES(0);
            break;
      }
      /* OP_VALUES      n{arg}
            Pop N values from the stack and store them in VALUES(...)
      */
      case OP_VALUES: {
            cl_fixnum n = GET_OPARG(vector);
            NVALUES = n;
            while (--n)
                  VALUES(n) = cl_stack_pop();
            VALUES(0) = reg0 = cl_stack_pop();
            break;
      }
      /* OP_NTHVAL
            Set VALUES(0) to the N-th value of the VALUES(...) list.
            The index N-th is extracted from the top of the stack.
      */
      case OP_NTHVAL: {
            cl_fixnum n = fix(cl_stack_pop());
            if (n < 0) {
                  FEerror("Wrong index passed to NTH-VAL", 1, MAKE_FIXNUM(n));
            } else if ((cl_index)n >= NVALUES) {
                  VALUES(0) = reg0 = Cnil;
            } else {
                  VALUES(0) = reg0 = VALUES(n);
            }
            NVALUES = 1;
            break;
      }
      /* OP_PROTECT     label
           ...    ; code to be protected and whose value is output
         OP_PROTECT_NORMAL
         label:
           ...    ; code executed at exit
         OP_PROTECT_EXIT

        High level construct for UNWIND-PROTECT. The first piece of code is
        executed and its output value is saved. Then the second piece of code
        is executed and the output values restored. The second piece of code
        is always executed, even if a THROW, RETURN or GO happen within the
        first piece of code.
      */
      case OP_PROTECT: {
            cl_opcode *exit;
            GET_LABEL(exit, vector);
            cl_stack_push((cl_object)exit);
            if (frs_push(ECL_PROTECT_TAG) != 0) {
                  cl_env.lex_env = cl_env.frs_top->frs_lex;
                  frs_pop();
                  vector = (cl_opcode *)cl_stack_pop();
                  cl_stack_push(MAKE_FIXNUM(cl_env.nlj_fr - cl_env.frs_top));
                  goto PUSH_VALUES;
            }
            break;
      }
      case OP_PROTECT_NORMAL:
            bds_unwind(cl_env.frs_top->frs_bds_top);
            cl_env.lex_env = cl_env.frs_top->frs_lex;
            frs_pop();
            cl_stack_pop();
            cl_stack_push(MAKE_FIXNUM(1));
            goto PUSH_VALUES;
      case OP_PROTECT_EXIT: {
            volatile cl_fixnum n = NVALUES = fix(cl_stack_pop());
            while (n--)
                  VALUES(n) = cl_stack_pop();
            reg0 = VALUES(0);
            n = fix(cl_stack_pop());
            if (n <= 0)
                  unwind(cl_env.frs_top + n);
            break;
      }
      case OP_STEPIN: {
            cl_object form = GET_DATA(vector, bytecodes);
            cl_object a = SYM_VAL(@'si::*step-action*');
            cl_index n = cl_stack_push_values();
            if (a == Ct) {
                  /* We are stepping in, but must first ask the user
                   * what to do. */
                  ECL_SETQ(@'si::*step-level*',
                         cl_1P(SYM_VAL(@'si::*step-level*')));
                  cl_stack_push(form);
                  interpret_funcall(1, @'si::stepper');
            } else if (a != Cnil) {
                  /* The user told us to step over. *step-level* contains
                   * an integer number that, when it becomes 0, means
                   * that we have finished stepping over. */
                  ECL_SETQ(@'si::*step-action*', cl_1P(a));
            } else {
                  /* We are not inside a STEP form. This should
                   * actually never happen. */
            }
            cl_stack_pop_values(n);
            break;
      }
      case OP_STEPCALL: {
            /* We are going to call a function. However, we would
             * like to step _in_ the function. STEPPER takes care of
             * that. */
            cl_fixnum n = GET_OPARG(vector);
            if (SYM_VAL(@'si::*step-action*') == Ct) {
                  cl_stack_push(reg0);
                  reg0 = interpret_funcall(1, @'si::stepper');
            }
            reg0 = interpret_funcall(n, reg0);
      }
      case OP_STEPOUT: {
            cl_object a = SYM_VAL(@'si::*step-action*');
            cl_index n = cl_stack_push_values();
            if (a == Ct) {
                  /* We exit one stepping level */
                  ECL_SETQ(@'si::*step-level*',
                         cl_1M(SYM_VAL(@'si::*step-level*')));
            } else if (a == MAKE_FIXNUM(0)) {
                  /* We are back to the level in which the user
                   * selected to step over. */
                  ECL_SETQ(@'si::*step-action*', Ct);
            } else if (a != Cnil) {
                  ECL_SETQ(@'si::*step-action*', cl_1M(a));
            } else {
                  /* Not stepping, nothing to be done. */
            }
            cl_stack_pop_values(n);
            break;
      }
      default:
            FEerror("Internal error: Unknown code ~S",
                  1, MAKE_FIXNUM(*(vector-1)));
      }
      goto BEGIN;
}

@(defun si::interpreter_stack ()
@
      @(return Cnil)
@)

Generated by  Doxygen 1.6.0   Back to index