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

symbol.c

/*  

    YABASIC ---  a simple Basic Interpreter
    written by Marc-Oliver Ihm 1995-2005
    homepage: www.yabasic.de
    
    symbol.c --- code for control structures, symbol and stack management
    
    This file is part of yabasic and may be copied only 
    under the terms of either the Artistic License or 
    the GNU General Public License (GPL), both of which 
    can be found at www.yabasic.de

*/

/* ------------- includes ---------------- */

#ifndef YABASIC_INCLUDED
#include "yabasic.h"          /* all prototypes and structures */
#endif


/* ------------- external references ---------------- */

extern int yylineno;          /* current line number */
extern int yyparse ();        /* call bison parser */


/* ------------- local defines ---------------- */
struct switch_id
{
  int id;
  int depth;
  struct switch_id *next;
  struct switch_id *prev;
};


/* ------------- local functions ---------------- */

static struct symbol *create_symbol (int, char *);    /* create a new symbol */
static void link_label (struct command *);      /* link label into list of labels */
static int count_args (int);  /* count number of arguments on stack */
static void stackdesc (int, char *);      /* give back string describing stackentry */
static void freesym (struct symbol *);    /* free contents of symbol */
static int ind_to_off (int *, int *);     /* convert array of indices to single offset */
static void off_to_ind (int, int *, int *);     /* convert a single offset to an array of indices */


/* ------------- global variables ---------------- */

static struct symstack *symroot = NULL;   /* first element in symbol list */
static struct symstack *symhead = NULL;   /* last element ind symbol list */
struct stackentry *stackroot; /* lowest element in stack */
struct stackentry *stackhead; /* topmost element in stack */
static struct command *labelroot = NULL;  /* first label among commands */
static struct command *labelhead = NULL;  /* last label seen so far */
extern char *current_function;      /* name of currently defined function */
struct command *lastref;      /* last command in UDS referencing a symbol */
struct command *firstref;     /* first command in UDS referencing a symbol */
int labelcount = 0;           /* count self-generated labels */
int in_switch = 0;            /* true, if in switch (at compile-time) */
struct switch_id *switch_id_stackhead = NULL;   /* topmost (and valid) element of switch_id stack */
struct switch_id *switch_id_stackroot = NULL;   /* bottommost element of switch_id stack */


/* ------------- subroutines ---------------- */


void
pushsymlist (void)            /* push a new list of symbols on symbol stack */
{
  struct symstack *new;

  new = my_malloc (sizeof (struct symstack));
  if (symhead)
    symhead->next_in_stack = new;
  else
    symroot = new;            /* first time called */
  new->prev_in_stack = symhead;
  new->next_in_stack = NULL;
  new->next_in_list = NULL;
  symhead = new;
}


void
popsymlist (void)       /* pop list of symbols and free symbol contents */
{
  struct symstack *prevstack;
  struct symbol *currsym, *nextsym;
  int count = 0;

  currsym = symhead->next_in_list;
  while (currsym)
    {                   /* loop through symbol list */
      freesym (currsym);
      count++;
      nextsym = currsym->next_in_list;
      my_free (currsym);
      currsym = nextsym;
    }
  if (infolevel >= DEBUG)
    {
      sprintf (string, "removed symbol list with %d symbols", count);
      error (DEBUG, string);
    }
  prevstack = symhead->prev_in_stack;
  my_free (symhead);
  prevstack->next_in_stack = NULL;
  symhead = prevstack;
}


static void
freesym (struct symbol *s)    /* free contents of symbol */
{
  int i;
  int total;

  struct array *ar;
  if (s->link)
    {                   /* it's a link, don't remove memory */
      sprintf (string, "removing linked symbol '%s'", s->name);
      error (DEBUG, string);
      my_free (s->name);
      return;
    }
  if (s->type == sySTRING)
    {
      if (infolevel >= DEBUG)
      {
        sprintf (string, "removing string symbol '%s'", s->name);
        error (DEBUG, string);
      }
      my_free (s->pointer);
    }
  else if (s->type == syARRAY)
    {
      if (infolevel >= DEBUG)
      {
        sprintf (string, "removing array symbol '%s()'", s->name);
        error (DEBUG, string);
      }
      ar = s->pointer;
      if (ar->dimension > 0)
      {
        /* count total amount of memory */
        total = 1;
        for (i = 0; i < ar->dimension; i++)
          total *= (ar->bounds)[i];
        if (ar->type == 's')
          {             /* string array */
            for (i = 0; i < total; i++)
            my_free (*((char **) ar->pointer + i));
          }
        my_free (ar->pointer);
      }
      my_free (ar);
    }
  else if (s->type == syNUMBER)
    {
      if (infolevel >= DEBUG)
      {
        sprintf (string, "removing numeric symbol '%s'", s->name);
        error (DEBUG, string);
      }
    }
  my_free (s->name);
  return;
}


void
clearrefs (struct command *cmd)     /* clear references for commands within function */
{
  struct command *curr;
  int n = 0;

  curr = cmd->nextref;
  while (curr)
    {
      n++;
      curr->symbol = NULL;
      curr = curr->nextref;
    }
  sprintf (string, "removed references from %d symbols", n);
  error (DEBUG, string);
}


struct symbol *
get_sym (char *name, int type, int add)
/* get the value of a symbol, or create it with given type */
{
  struct symstack *currstack;
  struct symbol **currsym;
  struct symbol *prelink;
  struct symbol *new;
  int stackcount = 0;
  int symbolcount = 0;
  int linked = FALSE;

  if (!name)
    return NULL;
  /* go through all lists */
  currstack = symhead;        /* start with symhead */
  if (add == amSEARCH_PRE && symhead->prev_in_stack)
    currstack = symhead->prev_in_stack;
  while (TRUE)
    {
      stackcount++;
      currsym = &(currstack->next_in_list);
      while (*currsym)
      {
        prelink = *currsym;
        symbolcount++;
        if ((*currsym)->type == type && !strcmp (name, (*currsym)->name))
          {             /* do the types and names match ? */
            if ((*currsym)->link)
            {
              currsym = &((*currsym)->link);
              linked = TRUE;
            }
            if (infolevel >= DEBUG)
            {
              if (linked)
                sprintf (string,
                       "found symbol '%s%s', linked to %s after searching %d symbol(s) in %d stack(s)",
                       name, (type == syARRAY) ? "()" : "",
                       (*currsym)->name, symbolcount, stackcount);
              else
                sprintf (string,
                       "found symbol '%s%s' after searching %d symbol(s) in %d stack(s)",
                       name, (type == syARRAY) ? "()" : "",
                       symbolcount, stackcount);
              error (DEBUG, string);
            }
            return *currsym;  /* give back address */
          }
        currsym = &((*currsym)->next_in_list);  /* try next entry */
      }
      /* not found in first list */
      if (add == amSEARCH_VERY_LOCAL)
      return NULL;
      if (add == amADD_LOCAL)
      {
        new = create_symbol (type, name);
        (*currsym) = new;
        if (infolevel >= DEBUG)
          {
            sprintf (string, "created local symbol %s%s", name,
                   (type == syARRAY) ? "()" : "");
            error (DEBUG, string);
          }
        return new;
      }
      if (currstack != symroot)
      currstack = symroot;
      else
      break;
    }
  if (add == amADD_GLOBAL)
    {
      new = create_symbol (type, name);
      (*currsym) = new;
      if (infolevel >= DEBUG)
      {
        sprintf (string, "created global symbol %s%s", name,
               (type == syARRAY) ? "()" : "");
        error (DEBUG, string);
      }
      return new;
    }
  return NULL;
}


void
link_symbols (struct symbol *from, struct symbol *to)
{                       /* link one symbol to the other */
  from->link = to;
  if (infolevel >= DEBUG)
    {
      sprintf (string, "linking symbol '%s' to '%s'", from->name,
             to->name);
      error (DEBUG, string);
    }
}


void
create_retval (int is, int should)  /* create command 'cRETVAL' */
{
  struct command *cmd;

  cmd = add_command (cRETVAL, NULL);
  cmd->args = is;
  cmd->tag = should;
}


void
retval (struct command *cmd)  /* check return value of function */
{
  int is, should;
  struct stackentry *s;

  is = cmd->args;
  should = cmd->tag;
  if (is == should)
    {
      /* okay, function returns expected type */
    }
  else if (is == ftNONE)
    {                   /* no element on stack, create one */
      s = push ();
      if (should == ftNUMBER)
      {
        s->type = stNUMBER;
        s->value = 0.0;
      }
      else
      {
        s->type = stSTRING;
        s->pointer = my_strdup ("");
      }
    }
  else
    {
      sprintf (string, "subroutine returns %s but should return %s",
             (is == ftSTRING) ? "a string" : "a number",
             (should == ftSTRING) ? "a string" : "a number");
      error (ERROR, string);
    }
  if (infolevel >= DEBUG)
    {
      s = stackhead->prev;
      if (s->type == stNUMBER)
      sprintf (string, "subroutine returns number %g", s->value);
      else if (s->type == stSTRING)
      sprintf (string, "subroutine returns string '%s'",
             (char *) s->pointer);
      else
      sprintf (string, "subroutine returns something strange (%d)",
             s->type);
      error (DEBUG, string);
    }
  swap ();
}


void
create_endfunction (void)     /* create command cEND_FUNCTION */
{
  struct command *cmd;

  cmd = add_command (cEND_FUNCTION, NULL);
  link_label (cmd);
}


void
dump_sym (void)               /* dump the stack of lists of symbols */
{
  struct symstack *currstack;
  struct symbol **currsym;

  /* go through all lists */
  error (DUMP, "head of symbol stack");
  currstack = symhead;
  while (currstack)
    {                   /* search 'til last element of stack */
      currsym = &(currstack->next_in_list);
      string[0] = '\0';
      while (*currsym)
      {
        switch ((*currsym)->type)
          {
          case sySTRING:
            strcat (string, " STRING:");
            break;
          case syNUMBER:
            strcat (string, " NUMBER:");
            break;
          case syFREE:
            strcat (string, " FREE:");
            break;
          case syARRAY:
            strcat (string, " ARRAY:");
            break;
          default:
            sprintf (string, " UNKNOWN:");
            break;
          }
        strcat (string, (*currsym)->name);

        currsym = &((*currsym)->next_in_list);  /* try next entry */
      }
      error (DUMP, string);
      currstack = currstack->prev_in_stack;
    }
  error (DUMP, "root of symbol stack");
  return;
}


void
dump_sub (int short_dump)     /* dump the stack of subroutine calls */
{
  struct stackentry *st = stackhead;
  struct command *cmd;
  int first = TRUE;
  do
    {
      if (st->type == stRETADDCALL)
      {
        cmd = st->pointer;
        if (cmd->type == cCALL || cmd->type == cQCALL)
          {
            char *dot;
            dot = strchr (cmd->pointer, '.');
            if (first && !short_dump)
            error (DUMP, "Executing in:");
            sprintf (string, "sub %s() called in %s,%d",
                   dot ? (dot + 1) : cmd->pointer, cmd->lib->l,
                   cmd->line);
            error (DUMP, string);
            first = FALSE;
          }
      }
      st = st->prev;
    }
  while (st && st != stackroot);
  if (first && !short_dump)
    {
      if (!short_dump)
      error (DUMP, "Executing in:");
    }
  if (!short_dump)
    error (DUMP, "main program");

  return;
}


static struct symbol *
create_symbol (int type, char *name)      /* create a new symbol */
{
  struct symbol *new;

  new = my_malloc (sizeof (struct symbol));
  new->type = type;
  new->next_in_list = NULL;
  new->name = my_strdup (name);
  new->pointer = NULL;
  new->args = NULL;
  new->value = 0.0;
  new->link = NULL;

  return new;
}


void
function_or_array (struct command *cmd)   /* decide whether to perform function or array */
{
  struct command *fu;

  fu = search_label (cmd->name, smSUB | smLINK);
  if (fu)
    {
      cmd->type = cCALL;
      cmd->pointer = cmd->name;
      cmd->name = NULL;
      error (DEBUG, "converting FUNCTION_OR_ARRAY to FUNCTION");
    }
  else
    {
      if (cmd->type == cFUNCTION_OR_ARRAY)
      cmd->tag = CALLARRAY;
      else
      cmd->tag = CALLSTRINGARRAY;
      cmd->type = cDOARRAY;
      cmd->args = -1;
      error (DEBUG, "converting FUNCTION_OR_ARRAY to ARRAY");
    }
}


void
swap ()                       /* swap topmost elements on stack */
{
  struct stackentry *a, *b;

  if ((a = stackhead->prev) == NULL || (b = a->prev) == NULL)
    {
      error (ERROR, "Nothing to swap on stack !");
      return;
    }
  a->prev = b->prev;
  b->next = a->next;          /* just swap the pointers */
  a->next = b;
  b->prev = a;
  stackhead->prev = b;
  (a->prev)->next = a;
}


struct stackentry *
push ()
/* push element on stack and enlarge stack it */
{
  struct stackentry *new;

  if (!stackhead->next)
    {                   /* no next element */
      /* create new element */
      new = (struct stackentry *) my_malloc (sizeof (struct stackentry));
      /* and initialize it */
      new->next = NULL;
      new->value = 0.0;
      new->type = stFREE;
      new->prev = stackhead;
      new->pointer = NULL;
      stackhead->next = new;
    }
  else if (stackhead->pointer != NULL
         && (stackhead->type == stSTRING
             || stackhead->type == stSTRINGARRAYREF
             || stackhead->type == stNUMBERARRAYREF
             || stackhead->type == stLABEL))
    {
      /* any content is set free */
      my_free (stackhead->pointer);
      stackhead->pointer = NULL;
    }
  stackhead = stackhead->next;      /* advance head */
  return stackhead->prev;
}


struct stackentry *
pop (int etype)
/* pops element to memory and looks for pop-error */
{
  static char expected[50];
  static char found[50];
  int ftype;
  struct stackentry *s;

  /* test if there is something on the stack */
  if (stackhead == stackroot)
    {
      error (FATAL, "Popped too much.");
      return stackhead;
    }
  stackhead = stackhead->prev;      /* move down in stack */
  ftype = stackhead->type;
  if (etype == ftype || etype == stANY ||
      (etype == stSTRING_OR_NUMBER
       && (ftype == stNUMBER || ftype == stSTRING))
      || (etype == stSTRING_OR_NUMBER_ARRAYREF
        && (ftype == stSTRINGARRAYREF || ftype == stNUMBERARRAYREF)))
    return stackhead;         /* this is your value; use it quickly ! */

  /* expected and found don't match */
  stackdesc (etype, expected);
  stackdesc (ftype, found);
  sprintf (string, "expected %s but found %s", expected, found);
  if (etype == stNUMBER || etype == stSTRING
      || etype == stSTRING_OR_NUMBER)
    {
      s = push ();
      if (etype == stNUMBER)
      {
        s->type = stNUMBER;
        s->value = 0.0;
      }
      else
      {
        s->type = stSTRING;
        s->pointer = my_strdup ("");
      }
      error (ERROR, string);
      return s;
    }
  else
    {
      error (FATAL, string);
    }
  return stackhead;
}


static void
stackdesc (int type, char *desc)    /* give back string describing stackentry */
{
  switch (type)
    {
    case stGOTO:
      strcpy (desc, "a goto");
      break;
    case stSTRING:
      strcpy (desc, "a string");
      break;
    case stSTRINGARRAYREF:
      strcpy (desc, "a reference to a string array");
      break;
    case stNUMBER:
      strcpy (desc, "a number");
      break;
    case stNUMBERARRAYREF:
      strcpy (desc, "a reference to a numeric array");
      break;
    case stLABEL:
      strcpy (desc, "a label");
      break;
    case stRETADD:
      strcpy (desc, "a return address for gosub");
      break;
    case stRETADDCALL:
      strcpy (desc, "a return address for a subroutine");
      break;
    case stFREE:
      strcpy (desc, "nothing");
      break;
    case stROOT:
      strcpy (desc, "the root of the stack");
      break;
    case stANY:
      strcpy (desc, "anything");
      break;
    case stSTRING_OR_NUMBER:
      strcpy (desc, "a string or a number");
      break;
    case stSTRING_OR_NUMBER_ARRAYREF:
      strcpy (desc, "reference to a string or an array");
      break;
    case stSWITCH_STRING:
      strcpy (desc, "number for switch");
      break;
    case stSWITCH_NUMBER:
      strcpy (desc, "string for switch");
      break;
    default:
      sprintf (desc, "type %d", type);
      break;
    }
}


void
pushname (char *name)         /* bison: push a name on stack */
{
  struct stackentry *s;

  s = push ();
  s->pointer = my_strdup (name);
  s->type = stSTRING;
}


void
pushlabel ()                  /* bison: generate goto and push label on stack */
{
  char *st;
  struct stackentry *en;

  st = (char *) my_malloc (sizeof (char) * 20);
  sprintf (st, "***%d", labelcount);
  labelcount++;
  create_goto (st);
  en = push ();
  en->type = stLABEL;
  en->pointer = st;
}


void
poplabel ()             /* bison: pops a label and generates the matching command */
{
  create_label (pop (stLABEL)->pointer, cLABEL);      /* and create it */
}


void
pushgoto ()             /* bison: generate label and push goto on stack */
{
  char *st;
  struct stackentry *en;

  st = (char *) my_malloc (sizeof (char) * 20);
  sprintf (st, "***%d", labelcount);
  labelcount++;
  create_label (st, cLABEL);
  en = push ();
  en->type = stGOTO;
  en->pointer = st;
}


void
popgoto ()              /* bison: pops a goto and generates the matching command */
{
  create_goto (pop (stGOTO)->pointer);    /* and create it */
}


void
storelabel ()                 /* bison: push label on stack */
{
  char *st;
  struct stackentry *en;

  st = (char *) my_malloc (sizeof (char) * 20);
  sprintf (st, "***%d", labelcount);
  labelcount++;
  en = push ();
  en->type = stLABEL;
  en->pointer = st;
}


void
matchgoto ()                  /* bison: generate goto matching label on stack */
{
  create_goto (stackhead->prev->pointer);
}


void
create_pushdbl (double value) /* create command 'cPUSHDBL' */
{
  struct command *cmd;

  cmd = add_command (cPUSHDBL, NULL);
  cmd->pointer = my_malloc (sizeof (double));
  *(double *) (cmd->pointer) = value;
}


void
pushdbl (struct command *cmd)
{
  /* push double onto stack */
  struct stackentry *p;

  p = push ();
  p->value = *(double *) cmd->pointer;
  p->type = stNUMBER;
}


void
pushdblsym (struct command *cmd)
{
  /* push double symbol onto stack */
  struct stackentry *p;

  p = push ();
  if (!cmd->name)
    error (WARNING, "invalid pushdblsym");

  if (!cmd->symbol)
    cmd->symbol = &(get_sym (cmd->name, syNUMBER, amADD_GLOBAL)->value);
  p->value = *(double *) cmd->symbol;
  p->type = stNUMBER;
}


void
popdblsym (struct command *cmd)     /* pop double from stack */
{
  double d;

  d = pop (stNUMBER)->value;
  if (!cmd->symbol)
    cmd->symbol = &(get_sym (cmd->name, syNUMBER, amADD_GLOBAL)->value);
  *(double *) (cmd->symbol) = d;
}


void
create_makelocal (char *name, int type)   /* create command 'cMAKELOCAL' */
{
  struct command *cmd;

  cmd = add_command (cMAKELOCAL, name);
  cmd->args = type;
}


void
makelocal (struct command *cmd)     /* makes symbol local */
{
  if (get_sym (cmd->name, cmd->args, amSEARCH_VERY_LOCAL))
    {
      sprintf (string,
             "local variable '%s' already defined within this subroutine",
             strip (cmd->name));
      error (ERROR, string);
      return;
    }
  get_sym (cmd->name, cmd->args, amADD_LOCAL);
}


void
create_numparam (void)        /* create command 'cNUMPARAM' */
{
  struct command *cmd;

  /* dotifying numparams at compiletime (as opposed to runtime) is essential, 
     because the function name is not known at runtime */
  cmd = add_command (cNUMPARAM, dotify ("numparams", FALSE));
}


void
numparam (struct command *cmd)      /* count number of function parameters */
{
  struct symbol *sym;

  sym = get_sym (cmd->name, syNUMBER, amADD_LOCAL);
  sym->value = abs (count_args (FALSE));
}


void
create_makestatic (char *name, int type)  /* create command 'cMAKESTATIC' */
{
  struct command *cmd;

  cmd = add_command (cMAKESTATIC, name);
  cmd->args = type;
}


void
makestatic (struct command *cmd)    /* makes symbol static */
{
  struct symbol *l, *g;
  char *at = NULL;


  /* mask function name */
  if ((at = strchr (cmd->name, '@')) != NULL)
    *at = '\0';

  if (get_sym (cmd->name, cmd->args, amSEARCH_VERY_LOCAL))
    {
      sprintf (string,
             "static variable '%s' already defined within this subroutine",
             strip (cmd->name));
      error (ERROR, string);
      return;
    }

  /* create global variable with unique name */
  if (at)
    *at = '@';
  g = get_sym (cmd->name, cmd->args, amADD_GLOBAL);
  if (at)
    *at = '\0';

  /* create local variable */
  l = get_sym (cmd->name, cmd->args, amADD_LOCAL);
  if (at)
    *at = '@';
  /* link those two together */
  link_symbols (l, g);
}


void
create_arraylink (char *name, int type)   /* create command 'cARRAYLINK' */
{
  struct command *cmd;

  cmd = add_command (cARRAYLINK, name);
  cmd->pointer = current_function;
  cmd->args = type;
}


void
arraylink (struct command *cmd)     /* link a local symbol to a global array */
{
  struct symbol *l, *g;
  struct array *ar;

  if (get_sym (cmd->name, cmd->args, amSEARCH_VERY_LOCAL))
    {
      sprintf (string, "'%s()' already defined within this subroutine",
             strip (cmd->name));
      error (ERROR, string);
      return;
    }
  /* get globally defined array */
  g = get_sym (pop (cmd->args)->pointer, syARRAY, amSEARCH_PRE);
  /* create local array */
  l = get_sym (cmd->name, syARRAY, amADD_LOCAL);
  if (!l)
    return;
  if (!g || !g->pointer)
    {                   /* no global array supplied, create one */
      error (DEBUG, "creating dummy array");
      ar = create_array ((cmd->args == stNUMBERARRAYREF) ? 'd' : 's', 0);
      l->pointer = ar;
      if (infolevel >= DEBUG)
      {
        sprintf (string, "creating 0-dimensional dummy array '%s()'",
               cmd->name);
        error (DEBUG, string);
      }
    }
  else
    {
      /* link those two together */
      link_symbols (l, g);
    }
}


void
create_pusharrayref (char *name, int type)      /* create command 'cPUSHARRAYREF' */
{
  struct command *cmd;

  cmd = add_command (cPUSHARRAYREF, name);
  cmd->args = type;
}


void
pusharrayref (struct command *cmd)  /* push an array reference onto stack */
{
  struct stackentry *s;
  s = push ();
  s->type = cmd->args;
  s->pointer = my_strdup (cmd->name);
}


void
create_require (int type)     /* create command 'cREQUIRE' */
{
  struct command *cmd;

  cmd = add_command (cREQUIRE, NULL);
  cmd->args = type;
}


void
require (struct command *cmd) /* check, that item on stack has right type */
{
  char *expected, *supplied;
  struct stackentry *s;

  if (stackhead->prev->type == cmd->args)
    return;             /* okay, they match */

  if (stackhead->prev->type == stFREE)
    {                   /* no argument supplied, create it */
      s = push ();
      if (cmd->args == stSTRING)
      {
        s->type = stSTRING;
        s->pointer = my_strdup ("");
        return;
      }
      else if (cmd->args == stNUMBER)
      {
        s->type = stNUMBER;
        s->value = 0.0;
        return;
      }
      else
      {
        /* create array */
        s->type = cmd->args;
        s->pointer = NULL;
        return;
      }
    }

  s = stackhead->prev;
  if (s->type == stSTRING)
    supplied = "string";
  else if (s->type == stNUMBER)
    supplied = "number";
  else if (s->type == stSTRINGARRAYREF)
    supplied = "string array";
  else if (s->type == stNUMBERARRAYREF)
    supplied = "numeric array";
  else if (s->type == stFREE)
    supplied = "nothing";
  else
    supplied = "something strange";

  if (cmd->args == stSTRING)
    expected = "string";
  else if (cmd->args == stNUMBER)
    expected = "number";
  else if (cmd->args == stSTRINGARRAYREF)
    expected = "string array";
  else if (cmd->args == stNUMBERARRAYREF)
    expected = "numeric array";
  else if (cmd->args == stFREE)
    expected = "nothing";
  else
    expected = "something strange";

  sprintf (string, "invalid subroutine call: %s expected, %s supplied",
         expected, supplied);
  error (ERROR, string);
}


void
create_dblbin (char c)        /* create command for binary double operation */
{
  switch (c)
    {
    case '+':
      add_command (cDBLADD, NULL);
      break;
    case '-':
      add_command (cDBLMIN, NULL);
      break;
    case '*':
      add_command (cDBLMUL, NULL);
      break;
    case '/':
      add_command (cDBLDIV, NULL);
      break;
    case '^':
      add_command (cDBLPOW, NULL);
      break;
    }
  /* no specific information needed */
}


void
dblbin (struct command *cmd)  /* compute with two numbers from stack */
{
  struct stackentry *d;
  double a, b, c;

  b = pop (stNUMBER)->value;
  a = pop (stNUMBER)->value;
  d = push ();
  switch (cmd->type)
    {
    case (cDBLADD):
      c = a + b;
      break;
    case (cDBLMIN):
      c = a - b;
      break;
    case (cDBLMUL):
      c = a * b;
      break;
    case (cDBLDIV):
      if (fabs (b) < DBL_MIN)
      {
        sprintf (string, "Division by zero, set to %g", DBL_MAX);
        error (NOTE, string);
        c = DBL_MAX;
      }
      else
      c = a / b;
      break;
    case (cDBLPOW):
      if ((a == 0 && b <= 0) || (a < 0 && b != (int) b))
      {
        error (ERROR, "result is not a real number");
        return;
      }
      else
      {
        c = pow (a, b);
      }
      break;
    }
  d->value = c;
  d->type = stNUMBER;
}


void
negate ()               /* negates top of stack */
{
  stackhead->prev->value = -stackhead->prev->value;
}


void
pushstrptr (struct command *cmd)    /* push string-pointer onto stack */
{
  struct stackentry *p;

  p = push ();
  if (!cmd->symbol)
    cmd->symbol = &(get_sym (cmd->name, sySTRING, amADD_GLOBAL)->pointer);
  p->pointer = *(char **) cmd->symbol;
  if (!p->pointer)
    p->pointer = my_strdup ("");
  p->type = stSTRING;
}


void
pushstrsym (struct command *cmd)    /* push string-symbol onto stack */
{
  struct stackentry *p;

  p = push ();
  if (!cmd->symbol)
    cmd->symbol = &(get_sym (cmd->name, sySTRING, amADD_GLOBAL)->pointer);
  p->pointer = my_strdup (*(char **) cmd->symbol);
  p->type = stSTRING;
}


void
popstrsym (struct command *cmd)     /* pop string from stack */
{
  if (!cmd->name)
    return;
  if (!cmd->symbol)
    cmd->symbol = &(get_sym (cmd->name, sySTRING, amADD_GLOBAL)->pointer);
  if (*(char **) cmd->symbol != NULL)
    my_free (*(char **) cmd->symbol);
  *(char **) cmd->symbol = my_strdup (pop (stSTRING)->pointer);
}


void
create_pushstr (char *s)      /* creates command pushstr */
{
  struct command *cmd;

  cmd = add_command (cPUSHSTR, NULL);
  cmd->pointer = my_strdup (s);     /* store string */
}


void
pushstr (struct command *cmd)
{
  /* push string onto stack */
  struct stackentry *p;

  p = push ();
  p->pointer = my_strdup ((char *) cmd->pointer);
  p->type = stSTRING;
}


void
duplicate (void)        /* duplicate topmost element of stack */
{
  struct stackentry *s;
  double actual;

  actual = stackhead->prev->value;
  s = push ();
  s->type = stNUMBER;
  s->value = actual;
}


void
create_goto (char *label)     /* creates command goto */
{
  struct command *cmd;

  cmd = add_command (cGOTO, NULL);
  /* specific info */
  cmd->pointer = my_strdup (label);
}


void
create_gosub (char *label)    /* creates command gosub */
{
  struct command *cmd;

  cmd = add_command (cGOSUB, NULL);
  /* specific info */
  cmd->pointer = my_strdup (label);
}


void
create_call (char *label)     /* creates command function call */
{
  struct command *cmd;

  cmd = add_command (cCALL, NULL);
  /* specific info */
  cmd->pointer = my_strdup (label);
}


static void
link_label (struct command *cmd)    /* link label into list of labels */
{
  if (!labelroot)
    labelroot = cmd;
  else
    labelhead->nextassoc = cmd;
  labelhead = cmd;
}


struct command *
search_label (char *name, int type) /* search label */
{
  struct command *curr;
  char *at = NULL;

  curr = labelroot;
  if (type & smGLOBAL)
    {
      at = strchr (name, '@');
      if (at)
      *at = '\0';
    }
  while (curr)
    {
      if ((type & smSUB) && curr->type == cUSER_FUNCTION
        && !strcmp (curr->pointer, name))
      {
        if (at)
          *at = '@';
        return curr;
      }
      if ((type & smLINK) && curr->type == cSUBLINK
        && !strcmp (curr->pointer, name))
      {
        if (at)
          *at = '@';
        return curr->next;
      }
      if ((type & smLABEL) && curr->type == cLABEL
        && !strcmp (curr->pointer, name))
      {
        if (at)
          *at = '@';
        return curr;
      }
      curr = curr->nextassoc;
    }
  return NULL;
}


void
jump (struct command *cmd)
/* jump to specific Label; used as goto, gosub or function call */
{
  struct command *label;
  struct stackentry *ret;
  int type;
  char *dot;

  type = cmd->type;
  if (type == cGOSUB || type == cQGOSUB || type == cCALL || type == cQCALL)
    {
      /* leave return address for return */
      ret = push ();
      ret->pointer = current;
      if (type == cGOSUB || type == cQGOSUB)
      {
        ret->type = stRETADD;
      }
      else
      {
        ret->type = stRETADDCALL;
        reshufflestack (ret);
      }
    }

  if (type == cQGOSUB || type == cQGOTO || type == cQCALL)
    {
      current = (struct command *) cmd->jump;   /* use remembered address */
      return;
    }
  label = search_label (cmd->pointer, smSUB | smLINK | smLABEL);
  if (!label && type == cCALL && (dot = strchr (cmd->pointer, '.')))
    {
      strcpy (string, "main");
      strcat (string, dot);
      label = search_label (string, smLINK);
    }
  if (label)
    {
      /* found right label */
      current = label;        /* jump to new location */
      /* use the address instead of the name next time */
      cmd->jump = label;
      switch (cmd->type)
      {
      case cGOTO:
        cmd->type = cQGOTO;
        break;
      case cGOSUB:
        cmd->type = cQGOSUB;
        break;
      case cCALL:
        cmd->type = cQCALL;
        break;
      }
    }
  else
    {
      /* label not found */
      sprintf (string, "can't find %s '%s'",
             (type == cCALL) ? "subroutine" : "label",
             strip ((char *) cmd->pointer));
      if (strchr (cmd->pointer, '@'))
      strcat (string, " (not in this sub)");
      error (ERROR, string);
    }

  /* check, if goto enters or leaves a switch_statement */
  if (cmd->type == cQGOTO)
    {
      if (label->switch_id && !cmd->switch_id)
      error (ERROR, "cannot jump into switch-statement");
      else if (!label->switch_id && cmd->switch_id)
      error (ERROR, "cannot jump out of switch-statement");
      else if (label->switch_id != cmd->switch_id)
      error (ERROR, "cannot jump between switch statements");
    }
}


void
reshufflestack (struct stackentry *ret)   /* reorganize stack for function call */
{
  struct stackentry *a, *b, *c;
  struct stackentry *top, *bot;
  struct stackentry *ttop, *bbot;
  int args;


  /* this is a function call; revert stack and shuffle return address to bottom */
  /* push address below parameters */
  args = 0;
  top = a = ret->prev;
  while (a->type != stFREE)
    {
      a = a->prev;
      args++;
    }
  bot = a->next;
  b = a->prev;
  /* remove ret */
  ret->prev->next = ret->next;
  ret->next->prev = ret->prev;
  /* squeeze ret between a and b */
  ret->next = a;
  a->prev = ret;
  b->next = ret;
  ret->prev = b;
  /* revert stack between top and bot */
  if (args > 1)
    {
      a = bot;
      b = a->next;
      bbot = bot->prev;
      ttop = top->next;
      for (; args > 1; args--)
      {
        a->prev = b;
        c = b->next;
        b->next = a;
        a = b;
        b = c;
      }
      bot->next = ttop;
      bot->next->prev = bot;
      top->prev = bbot;
      top->prev->next = top;
    }
}


void
myreturn (struct command *cmd)      /* return from gosub of function call */
{
  struct stackentry *address;

  address = pop (stANY);
  if (cmd->type == cRET_FROM_FUN)
    {
      if (address->type != stRETADDCALL)
      {
        error (ERROR, "RETURN from a subroutine without CALL");
        return;
      }
    }
  else
    {
      if (address->type != stRETADD)
      {
        error (ERROR, "RETURN without GOSUB");
        return;
      }
    }
  current = (struct command *) address->pointer;
  return;
}


void
create_label (char *label, int type)      /* creates command label */
{
  struct command *cmd;

  /* check, if label is duplicate */
  if (search_label (label, smSUB | smLINK | smLABEL))
    {
      sprintf (string, "duplicate %s '%s'",
             (type == cLABEL) ? "label" : "subroutine", strip (label));
      error (ERROR, string);
      return;
    }

  cmd = add_command (type, NULL);
  /* store label */
  cmd->pointer = my_strdup (label);
  link_label (cmd);
}


void
create_sublink (char *label)  /* create link to subroutine */
{
  char global[200];
  char *dot;
  struct command *cmd;

  if (!inlib)
    return;
  dot = strchr (label, '.');
  strcpy (global, "main");
  strcat (global, dot);

  /* check, if label is duplicate */
  if (search_label (global, smSUB | smLINK | smLABEL))
    {
      sprintf (string, "duplicate subroutine '%s'", strip (global));
      error (ERROR, string);
      return;
    }

  cmd = add_command (cSUBLINK, NULL);
  /* store label */
  cmd->pointer = my_strdup (global);
  link_label (cmd);
}


void
decide ()               /*  skips next command, if not 0 on stack */
{
  if (pop (stNUMBER)->value != 0)
    current = current->next;  /* skip one command */
}


void
create_dim (char *name, char type)  /* create command 'dim' */
/* type can be 's'=string or 'd'=double Array */
{
  struct command *cmd;

  cmd = add_command (cDIM, name);
  cmd->tag = type;            /* type: string or double */
  cmd->args = -1;
}


void
dim (struct command *cmd)     /* get room for array */
{
  struct array *nar, *oar;
  char *nul;
  int ntotal, ototal, esize, i, j;
  int ind[10], nbounds[10], larger;
  struct symbol *s;
  int local;

  local = ((cmd->tag == tolower (cmd->tag)) ? TRUE : FALSE);
  if (cmd->args < 0)
    cmd->args = count_args (FALSE);
  if (cmd->args < 0)
    {
      error (ERROR, "only numerical indices allowed for arrays");
      return;
    }
  s = get_sym (cmd->name, syARRAY, local ? amADD_LOCAL : amADD_GLOBAL);
  if (search_label (cmd->name, smSUB | smLINK))
    {
      sprintf (string, "array '%s()' conflicts with user subroutine",
             strip (cmd->name));
      error (ERROR, string);
      return;
    }

  /* check for dimensions */
  if (cmd->args > 10)
    {
      error (ERROR, "more than 10 indices");
      return;
    }
  oar = s->pointer;
  if (oar)
    {
      /* check, if old and new array are compatible */
      if (cmd->args != oar->dimension)
      {
        sprintf (string,
               "cannot change dimension of '%s()' from %d to %d",
               strip (cmd->name), oar->dimension, cmd->args);
        error (ERROR, string);
      }
    }
  /* check, if redim is actually needed */
  for (i = 0; i < 10; i++)
    nbounds[i] = 0;
  larger = FALSE;
  for (i = 0; i < cmd->args; i++)
    {
      nbounds[i] = 1 + (int) pop (stNUMBER)->value;
      if (nbounds[i] <= 1)
      {
        sprintf (string, "array index %d is less or equal zero",
               cmd->args - i);
        error (ERROR, string);
        return;
      }
      if (oar)
      {
        if (nbounds[i] > oar->bounds[i])
          larger = TRUE;
        else
          nbounds[i] = oar->bounds[i];
      }
    }
  pop (stFREE);               /* remove left over stFREE */
  if (oar && !larger)
    return;             /* new array won't be larger than old one */

  /* create array */
  nar = create_array (tolower (cmd->tag), cmd->args);

  /* count needed memory */
  ntotal = 1;
  for (i = 0; i < nar->dimension; i++)
    {
      (nar->bounds)[i] = nbounds[i];
      ntotal *= nbounds[i];
    }
  esize = (nar->type == 's') ? sizeof (char *) : sizeof (double); /* size of one array element */
  nar->pointer = my_malloc (ntotal * esize);

  if (oar)
    {                   /* array already exists, get its size */
      ototal = 1;
      for (i = 0; i < oar->dimension; i++)
      ototal *= (oar->bounds)[i];
    }

  /* initialize Array */
  for (i = 0; i < ntotal; i++)
    {
      if (nar->type == 's')
      {
        nul = my_malloc (sizeof (char));
        *nul = '\0';
        ((char **) nar->pointer)[i] = nul;
      }
      else
      {
        ((double *) nar->pointer)[i] = 0.0;
      }
    }

  if (oar)
    {                   /* copy contents of old array onto new */
      for (i = 0; i < ototal; i++)
      {
        off_to_ind (i, oar->bounds, ind);
        j = ind_to_off (ind, nar->bounds);
        if (nar->type == 's')
          {
            my_free (((char **) nar->pointer)[j]);
            ((char **) nar->pointer)[j] = ((char **) oar->pointer)[i];
          }
        else
          {
            ((double *) nar->pointer)[j] = ((double *) oar->pointer)[i];
          }
      }
      my_free (oar->pointer);
      my_free (oar);
    }

  s->pointer = nar;
  cmd->symbol = nar;
}


static int
ind_to_off (int *ind, int *bound)   /* convert array of indices to single offset */
{
  int i;
  int cur, off;

  off = 0;
  cur = 1;
  for (i = 0; i < 10 && bound[i]; i++)
    {
      off += ind[i] * cur;
      cur *= bound[i];
    }
  return off;
}


static void
off_to_ind (int off, int *bound, int *ind)      /* convert a single offset to an array of indices */
{
  int i;
  int cur;

  cur = 1;
  for (i = 0; i < 10; i++)
    {
      if (bound[i])
      cur *= bound[i];
      ind[i] = 0;
    }
  for (i = 9; i >= 0; i--)
    {
      if (bound[i])
      {
        cur /= bound[i];
        ind[i] = off / cur;
        off -= ind[i] * cur;
      }
      else
      {
        ind[i] = 0;
      }
    }
}


void
query_array (struct command *cmd)   /* query array */
{
  int index;
  struct stackentry *s;
  struct array *ar;
  struct symbol *sym;

  if (cmd->type == cARSIZE)
    index = (int) pop (stNUMBER)->value;

  s = pop (stSTRING_OR_NUMBER_ARRAYREF);

  if (!cmd->symbol)
    {
      sym = get_sym (s->pointer, syARRAY, amSEARCH);
      if (!sym || !sym->pointer)
      {
        sprintf (string, "array '%s()' is not defined",
               strip (s->pointer));
        error (ERROR, string);
        return;
      }
      cmd->symbol = sym;
    }

  ar = ((struct symbol *) cmd->symbol)->pointer;

  if (cmd->type == cARSIZE && (index < 1 || index > ar->dimension))
    {
      sprintf (string, "only indices between 1 and %d allowed",
             ar->dimension);
      error (ERROR, string);
      return;
    }
  s = push ();
  s->type = stNUMBER;
  if (cmd->type == cARSIZE)
    s->value = ar->bounds[ar->dimension - index] - 1;
  else
    s->value = ar->dimension;

  return;
}


void
create_doarray (char *symbol, int command)      /* creates array-commands */
{
  struct command *cmd;

  cmd = add_command (cDOARRAY, symbol);
  cmd->tag = command;         /* operation to perform */
  cmd->args = -1;
}


void
doarray (struct command *cmd) /* call an array */
{
  struct array *ar;
  struct stackentry *stack;
  struct symbol *sym;
  void *p;
  char **str;
  double *dbl;
  int i, j, bnd, index, cur, rval;


  if (!cmd->symbol)
    {
      sym = get_sym (cmd->name, syARRAY, amSEARCH);
      if (!sym || !sym->pointer)
      {
        sprintf (string, "'%s()' is neither array nor subroutine",
               strip (cmd->name));
        error (ERROR, string);
        return;
      }
      cmd->symbol = sym;
    }
  rval = (current->tag == CALLARRAY || current->tag == CALLSTRINGARRAY
        || current->tag == GETSTRINGPOINTER);
  if (cmd->args < 0)
    cmd->args = count_args (!rval);
  if (cmd->args < 0)
    {
      error (ERROR, "only numerical indices allowed for arrays");
      return;
    }
  cmd->args = abs (cmd->args);
  if (!cmd->args)
    {                   /* no indizes supplied, create a reference to an array */
      pop (stFREE);           /* remove left over stFREE */
      stack = push ();
      if (cmd->tag == CALLARRAY)
      stack->type = stNUMBERARRAYREF;
      else
      stack->type = stSTRINGARRAYREF;
      stack->pointer = my_strdup (cmd->name);
      return;
    }

  ar = ((struct symbol *) cmd->symbol)->pointer;

  if (!ar->dimension)
    {
      sprintf (string, "array parameter '%s()' has not been supplied",
             strip (cmd->name));
      error (ERROR, string);
      return;
    }
  if (cmd->args != ar->dimension)
    {
      sprintf (string, "%d indices supplied, %d expected for '%s()'",
             cmd->args, ar->dimension, strip (cmd->name));
      error (ERROR, string);
      return;
    }

  if (!rval)
    stack = pop (stSTRING_OR_NUMBER);
  index = 0;
  cur = 1;
  for (i = 0; i < ar->dimension; i++)
    {
      bnd = (ar->bounds[i]);
      j = (int) pop (stNUMBER)->value;
      if (j < 0 || j >= bnd)
      {
        sprintf (string, "index %d (=%d) out of range",
               ar->dimension - i, j);
        error (ERROR, string);
        return;
      }
      index += j * cur;
      cur *= bnd;
    }

  pop (stFREE);               /* remove left over stFREE */
  if (rval)
    stack = push ();

  p = ar->pointer;
  switch (current->tag)
    {
    case CALLARRAY:
      dbl = (double *) p + index;
      stack->value = *dbl;
      stack->type = stNUMBER;
      break;
    case ASSIGNARRAY:
      dbl = (double *) p + index;
      *dbl = stack->value;
      break;
    case CALLSTRINGARRAY:
      str = ((char **) p + index);
      stack->pointer = my_strdup (*str);
      stack->type = stSTRING;
      break;
    case ASSIGNSTRINGARRAY:
      str = ((char **) p + index);
      if (*str != NULL)
      my_free (*str);
      *str = my_strdup (stack->pointer);
      break;
    case GETSTRINGPOINTER:
      str = ((char **) p + index);
      stack->pointer = *str;
      stack->type = stSTRING;
      break;
    }
}


struct array *
create_array (int type, int dimension)    /* create an array */
{
  int i;
  struct array *ar;

  ar = my_malloc (sizeof (struct array));
  ar->type = type;
  ar->dimension = dimension;
  ar->pointer = NULL;
  for (i = 0; i < 10; i++)
    ar->bounds[i] = 0;

  return ar;
}


static int
count_args (int skipfirst)    /* count number of numeric arguments on stack */
{
  int i = 0;
  int sign = 1;
  struct stackentry *curr;

  curr = stackhead->prev;
  if (skipfirst)
    curr = curr->prev;
  while (curr)
    {
      if (curr->type == stFREE)
      return i * sign;
      if (curr->type != stNUMBER)
      sign = -1;
      curr = curr->prev;
      i++;
    }
  return -1;
}


void
skipper ()
/* used for on_goto/gosub, skip specified number of commands */
{
  int i, len;
  struct command *ahead;      /* command to follow */

  len = (int) pop (stNUMBER)->value;
  i = 1;
  current = current->next;    /* advance to first goto/gosub */
  for (i = 1; i < len; i++)
    {
      ahead = current->next->next;  /* skip interleaving findnop statement */
      if (ahead->type == cNOP)
      break;
      else
      current = ahead;
    }
}


void
skiponce (struct command *cmd)      /* skip next command exectly once */
{
  if (cmd->tag)
    current = current->next;
  cmd->tag = 0;
}


void
resetskiponce (struct command *cmd) /* find and reset next skip */
{
  struct command *c;

  c = cmd;
  while (c->type != cSKIPONCE)
    c = c->next;
  c->tag = 1;
}

void
create_break_mark (int minor, int major)  /* create marks for break */
{
  struct command *cmd;

  in_loop += major;
  cmd = add_command (cBREAK_MARK, NULL);
  cmd->tag = (major + 2) * 16 + minor + 2;
}


void
next_case (void)        /* go to next case in switch statement */
{
  if (stackhead->prev->type == stSTRING
      || stackhead->prev->type == stSWITCH_STRING)
    stackhead->prev->type = stSWITCH_STRING;
  else
    stackhead->prev->type = stSWITCH_NUMBER;
}


void
push_switch_id (void)         /* generate a new switch id */
{
  static int max_switch_id = 0;
  static int switch_stack_depth = 1;

  struct switch_id *new_id;
  if (switch_id_stackhead == NULL || switch_id_stackhead->next == NULL)
    {
      if (switch_id_stackroot && switch_id_stackhead == NULL)
      {
        new_id = switch_id_stackroot;
      }
      else
      {
        new_id = my_malloc (sizeof (struct switch_id));
        new_id->next = NULL;
        new_id->depth = switch_stack_depth++;
      }
    }
  else
    {
      new_id = switch_id_stackhead->next;
    }
  max_switch_id++;
  new_id->id = max_switch_id;
  if (switch_id_stackhead == NULL)
    {
      switch_id_stackhead = new_id;
      switch_id_stackhead->prev = NULL;
    }
  else
    {
      switch_id_stackhead->next = new_id;
      new_id->prev = switch_id_stackhead;
      switch_id_stackhead = new_id;
    }
}


void
pop_switch_id (void)          /* get previous switch id */
{
  if (switch_id_stackhead)
    switch_id_stackhead = switch_id_stackhead->prev;
}


int
get_switch_id (void)          /* get current switch id */
{
  return switch_id_stackhead ? switch_id_stackhead->id : 0;
}


int
get_switch_depth (void)       /* get current depth of switch id stack */
{
  return switch_id_stackhead ? switch_id_stackhead->depth : 0;
}


void
push_switch_mark (void)       /* push a switch mark */
{
  push ()->type = stSWITCH_MARK;
}


void
create_clean_switch_mark (int keep, int ret)    /* add command clean_switch_mark */
{
  struct command *cmd;

  cmd = add_command (cCLEAN_SWITCH_MARK, NULL);
  cmd->args = keep;
  cmd->tag = ret;
}


void
clean_switch_mark (struct command *cmd)   /* pop everything up to (and including) first switch_mark from stack */
{
  struct stackentry *t, *tt, *b, *bb, *s;
  int keep, k, ret;

  k = keep = cmd->args;
  ret = cmd->tag;
  s = stackhead->prev;
  while (k && s != stackroot)
    {
      k--;
      s = s->prev;
    }
  t = s;
  tt = s->next;
  while (((ret && s->type != stRETADDCALL)
        || (!ret && s->type != stSWITCH_MARK)) && s != stackroot)
    {
      s = s->prev;
    }
  if (ret)
    {
      bb = s;
      b = s->next;
    }
  else
    {
      b = s;
      bb = s->prev;
    }

  /* cut part between (and including) b and t out of stack */
  bb->next = tt;
  tt->prev = bb;
  /* insert cut-out part between stackhead and stackhead->prev */
  stackhead->prev->next = b;
  b->prev = stackhead->prev;
  t->next = stackhead;
  stackhead->prev = t;
  if (keep)
    stackhead = tt->next;
  else
    stackhead = bb->next;
}


void
mybreak (struct command *cmd) /* find break_here statement */
{
  struct command *curr;
  int major, minor;
  int major_nesting = 0;
  int minor_nesting = 0;

  if (cmd->type == cBREAK)
    major_nesting = 1;
  else
    minor_nesting = 0;
  curr = cmd;
  while (curr->type != cBREAK_HERE || major_nesting || minor_nesting)
    {
      if (curr->type == cBREAK_MARK)
      {
        minor = (curr->tag & 15) - 2;
        major = ((curr->tag & 240) / 16) - 2;
        if (!major_nesting)
          minor_nesting += minor;
        major_nesting += major;
        if (infolevel >= DEBUG)
          {
            sprintf (string,
                   "searching break-mark: diff(%d,%d), total(%d,%d)",
                   minor, major, minor_nesting, major_nesting);
            error (DEBUG, string);
          }
      }
      curr = curr->next;
      if (!curr)
      error (FATAL, "break has left program");
    }
  cmd->type = cQGOTO;
  if (infolevel >= DEBUG)
    error (DEBUG, "converting cBREAK to cQGOTO");
  cmd->jump = current = curr;
}


void
mycontinue (struct command *cmd)    /* find continue_here statement */
{
  struct command *curr;
  int major;
  int major_nesting = -1;

  curr = cmd;
  while (curr->type != cCONTINUE_HERE || major_nesting)
    {
      if (curr->type == cBREAK_MARK)
      {
        major = ((curr->tag & 240) >> 4) - 2;
        major_nesting += major;
      }
      if (curr->type == cCONTINUE_CORRECTION)
      major_nesting--;
      curr = curr->prev;
      if (!curr)
      error (FATAL, "continue has left program");
    }
  cmd->type = cQGOTO;
  if (infolevel >= DEBUG)
    error (DEBUG, "converting cCONTINUE to cQGOTO");
  cmd->jump = current = curr;
}


void
findnop ()
/* used for on_gosub, find trailing nop command */
{
  while (current->type != cNOP)
    {
      current = current->next;      /* next label */
    }
}


void
forcheck (void)               /* check, if for-loop is done */
{
  double start, bound, step, val;

  val = pop (stNUMBER)->value;
  step = pop (stNUMBER)->value;
  bound = pop (stNUMBER)->value;
  start = stackhead->prev->value;
  if ((val <= bound && val >= start && step >= 0)
      || (val <= start && val >= bound && step <= 0))
    stackhead->prev->value = 1.;
  else
    stackhead->prev->value = 0.;
}


void
forincrement (void)           /* increment value on stack */
{
/* expecting on stack: BOUND,STEP,VAL,stackhead
  where for VAL=START to BOUND step STEP */
  stackhead->prev->value += stackhead->prev->prev->value;
}


void
startfor (void)               /* compute initial value of for-variable */
{
  struct stackentry *p;

  p = push ();
  p->value =
      stackhead->prev->prev->prev->prev->value -
      stackhead->prev->prev->value;
  p->type = stNUMBER;

  return;
}

Generated by  Doxygen 1.6.0   Back to index