path: root/apps/interpreters/bas/bas.c

/****************************************************************************
 * apps/examples/interpreters/bas/bas.c
 *
 *   Copyright (c) 1999-2014 Michael Haardt
 *
 * Permission is hereby granted, free of charge, to any person obtaining a
 * copy of this software and associated documentation files (the "Software"),
 * to deal in the Software without restriction, including without limitation
 * the rights to use, copy, modify, merge, publish, distribute, sublicense,
 * and/or sell copies of the Software, and to permit persons to whom the
 * Software is furnished to do so, subject to the following conditions:
 *
 * The above copyright notice and this permission notice shall be included in
 * all copies or substantial portions of the Software.
 *
 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
 * OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
 * THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
 * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
 * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
 * DEALINGS IN THE SOFTWARE.
 *
 * Adapted to NuttX and re-released under a 3-clause BSD license:
 *
 *   Copyright (C) 2014 Gregory Nutt. All rights reserved.
 *   Authors: Alan Carvalho de Assis <Alan Carvalho de Assis>
 *            Gregory Nutt <gnutt@nuttx.org>
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 *
 * 1. Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in
 *    the documentation and/or other materials provided with the
 *    distribution.
 * 3. Neither the name NuttX nor the names of its contributors may be
 *    used to endorse or promote products derived from this software
 *    without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
 * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
 * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
 * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 * POSSIBILITY OF SUCH DAMAGE.
 *
 ****************************************************************************/

/****************************************************************************
 * Included Files
 ****************************************************************************/

#include <nuttx/config.h>

#include <sys/stat.h>
#include <sys/types.h>
#include <sys/wait.h>
#include <assert.h>
#include <ctype.h>
#include <errno.h>
#include <fcntl.h>
#include <limits.h>
#include <math.h>
#include <string.h>
#include <stdlib.h>
#include <stdio.h>
#include <time.h>
#include <unistd.h>

#include "auto.h"
#include "bas.h"
#include "error.h"
#include "fs.h"
#include "global.h"
#include "program.h"
#include "value.h"
#include "var.h"

/****************************************************************************
 * Pre-processor Definitions
 ****************************************************************************/

#define DIRECTMODE (pc.line== -1)
#define _(String) String

/****************************************************************************
 * Private Types
 ****************************************************************************/

enum LabelType
  {
    L_IF = 1,
    L_ELSE,
    L_DO,
    L_DOcondition,
    L_FOR,
    L_FOR_VAR,
    L_FOR_LIMIT,
    L_FOR_BODY,
    L_REPEAT,
    L_SELECTCASE,
    L_WHILE,
    L_FUNC
  };

struct LabelStack
  {
    enum LabelType type;
    struct Pc patch;
  };

/****************************************************************************
 * Private Data
 ****************************************************************************/

static unsigned int labelStackPointer, labelStackCapacity;
static struct LabelStack *labelStack;
static struct Pc *lastdata;
static struct Pc curdata;
static struct Pc nextdata;

static enum
  {
    DECLARE,
    COMPILE,
    INTERPRET
  } pass;

static int stopped;
static int optionbase;
static struct Pc pc;
static struct Auto stack;
static struct Program program;
static struct Global globals;
static int run_restricted;

/****************************************************************************
 * Public Data
 ****************************************************************************/

int bas_argc;
char *bas_argv0;
char **bas_argv;
int bas_end;

/****************************************************************************
 * Private Function Prototypes
 ****************************************************************************/

static struct Value *statements(struct Value *value);
static struct Value *compileProgram(struct Value *v, int clearGlobals);
static struct Value *eval(struct Value *value, const char *desc);

/****************************************************************************
 * Private Functions
 ****************************************************************************/

static int cat(const char *filename)
{
  int fd;
  char buf[4096];
  ssize_t l;
  int err;

  if ((fd = open(filename, O_RDONLY)) == -1)
    {
      return -1;
    }

  while ((l = read(fd, buf, sizeof(buf))) > 0)
    {
      ssize_t off, w;

      off = 0;
      while (off < l)
        {
          if ((w = write(1, buf + off, l - off)) == -1)
            {
              err = errno;
              close(fd);
              errno = err;
              return -1;
            }

          off += w;
        }
    }

  if (l == -1)
    {
      err = errno;
      close(fd);
      errno = err;
      return -1;
    }

  close(fd);
  return 0;
}

static struct Value *lvalue(struct Value *value)
{
  struct Symbol *sym;
  struct Pc lvpc = pc;

  sym = pc.token->u.identifier->sym;
  assert(pass == DECLARE || sym->type == GLOBALVAR || sym->type == GLOBALARRAY
         || sym->type == LOCALVAR);

  if ((pc.token + 1)->type == T_OP)
    {
      struct Pc idxpc;
      unsigned int dim, capacity;
      int *idx;

      pc.token += 2;
      dim = 0;
      capacity = 0;
      idx = (int *)0;
      while (1)
        {
          if (dim == capacity && pass == INTERPRET)     /* enlarge idx */
            {
              int *more;

              more =
                realloc(idx,
                        sizeof(unsigned int) *
                        (capacity ? (capacity *= 2) : (capacity = 3)));
              if (!more)
                {
                  if (capacity)
                    free(idx);
                  return Value_new_ERROR(value, OUTOFMEMORY);
                }

              idx = more;
            }

          idxpc = pc;
          if (eval(value, _("index"))->type == V_ERROR ||
              VALUE_RETYPE(value, V_INTEGER)->type == V_ERROR)
            {
              if (capacity)
                {
                  free(idx);
                }

              pc = idxpc;
              return value;
            }

          if (pass == INTERPRET)
            {
              idx[dim] = value->u.integer;
              ++dim;
            }

          Value_destroy(value);
          if (pc.token->type == T_COMMA)
            {
              ++pc.token;
            }
          else
            {
              break;
            }
        }

      if (pc.token->type != T_CP)
        {
          assert(pass != INTERPRET);
          return Value_new_ERROR(value, MISSINGCP);
        }
      else
        {
          ++pc.token;
        }

      switch (pass)
        {
        case INTERPRET:
          {
            if ((value =
                 Var_value(&(sym->u.var), dim, idx, value))->type == V_ERROR)
              {
                pc = lvpc;
              }

            free(idx);
            return value;
          }

        case DECLARE:
          {
            return Value_nullValue(V_INTEGER);
          }

        case COMPILE:
          {
            return Value_nullValue(sym->type ==
                                   GLOBALARRAY ? sym->u.
                                   var.type : Auto_varType(&stack, sym));
          }

        default:
          assert(0);
        }

      return (struct Value *)0;
    }
  else
    {
      ++pc.token;
      switch (pass)
        {
        case INTERPRET:
          return VAR_SCALAR_VALUE(sym->type ==
                                  GLOBALVAR ? &(sym->u.var) : Auto_local(&stack,
                                                                         sym->
                                                                         u.local.offset));

        case DECLARE:
          return Value_nullValue(V_INTEGER);

        case COMPILE:
          return Value_nullValue(sym->type ==
                                 GLOBALVAR ? sym->u.
                                 var.type : Auto_varType(&stack, sym));

        default:
          assert(0);
        }

      return (struct Value *)0;
    }
}

static struct Value *func(struct Value *value)
{
  struct Identifier *ident;
  struct Pc funcpc = pc;
  int firstslot = -99;
  int args = 0;
  struct Symbol *sym;

  assert(pc.token->type == T_IDENTIFIER);

  /* Evaluating a function in direct mode may start a program, so it needs to
   * be compiled.  If in direct mode, programs will be compiled after the
   * direct mode pass DECLARE, but errors are ignored at that point, because
   * the program may not be needed.  If the program is fine, its symbols will
   * be available during the compile phase already.  If not and we need it at
   * this point, compile it again to get the error and abort.
   */

  if (DIRECTMODE && !program.runnable && pass != DECLARE)
    {
      if (compileProgram(value, 0)->type == V_ERROR)
        {
          return value;
        }

      Value_destroy(value);
    }

  ident = pc.token->u.identifier;
  assert(pass == DECLARE || ident->sym->type == BUILTINFUNCTION ||
         ident->sym->type == USERFUNCTION);
  ++pc.token;
  if (pass != DECLARE)
    {
      firstslot = stack.stackPointer;
      if (ident->sym->type == USERFUNCTION &&
          ident->sym->u.sub.retType != V_VOID)
        {
          struct Var *v = Auto_pushArg(&stack);
          Var_new(v, ident->sym->u.sub.retType, 0, (const unsigned int *)0, 0);
        }
    }

  if (pc.token->type == T_OP)   /* push arguments to stack */
    {
      ++pc.token;
      if (pc.token->type != T_CP)
        {
          while (1)
            {
              if (pass == DECLARE)
                {
                  if (eval(value, _("actual parameter"))->type == V_ERROR)
                    {
                      return value;
                    }

                  Value_destroy(value);
                }
              else
                {
                  struct Var *v = Auto_pushArg(&stack);

                  Var_new_scalar(v);
                  if (eval(v->value, (const char *)0)->type == V_ERROR)
                    {
                      Value_clone(value, v->value);
                      while (stack.stackPointer > firstslot)
                        {
                          Var_destroy(&stack.slot[--stack.stackPointer].var);
                        }

                      return value;
                    }

                  v->type = v->value->type;
                }

              ++args;
              if (pc.token->type == T_COMMA)
                {
                  ++pc.token;
                }
              else
                {
                  break;
                }
            }

          if (pc.token->type != T_CP)
            {
              if (pass != DECLARE)
                {
                  while (stack.stackPointer > firstslot)
                    {
                      Var_destroy(&stack.slot[--stack.stackPointer].var);
                    }
                }

              return Value_new_ERROR(value, MISSINGCP);
            }

          ++pc.token;
        }
    }

  if (pass == DECLARE)
    {
      Value_new_null(value, ident->defaultType);
    }
  else
    {
      int i;
      int nomore;
      int argerr;
      int overloaded;

      if (pass == INTERPRET && ident->sym->type == USERFUNCTION)
        {
          for (i = 0; i < ident->sym->u.sub.u.def.localLength; ++i)
            {
              struct Var *v = Auto_pushArg(&stack);
              Var_new(v, ident->sym->u.sub.u.def.localTypes[i], 0,
                      (const unsigned int *)0, 0);
            }
        }

      Auto_pushFuncRet(&stack, firstslot, &pc);

      sym = ident->sym;
      overloaded = (pass == COMPILE && sym->type == BUILTINFUNCTION &&
                    sym->u.sub.u.bltin.next);
      do
        {
          nomore = (pass == COMPILE &&
                    !(sym->type == BUILTINFUNCTION && sym->u.sub.u.bltin.next));
          argerr = 0;
          if (args < sym->u.sub.argLength)
            {
              if (nomore)
                {
                  Value_new_ERROR(value, TOOFEW);
                }

              argerr = 1;
            }

          else if (args > sym->u.sub.argLength)
            {
              if (nomore)
                {
                  Value_new_ERROR(value, TOOMANY);
                }

              argerr = 1;
            }
          else
            {
              for (i = 0; i < args; ++i)
                {
                  struct Value *arg =
                    Var_value(Auto_local(&stack, i), 0, (int *)0, value);

                  assert(arg->type != V_ERROR);
                  if (overloaded)
                    {
                      if (arg->type != sym->u.sub.argTypes[i])
                        {
                          if (nomore)
                            {
                              Value_new_ERROR(value, TYPEMISMATCH2, i + 1);
                            }

                          argerr = 1;
                          break;
                        }
                    }
                  else if (Value_retype(arg, sym->u.sub.argTypes[i])->type ==
                           V_ERROR)
                    {
                      if (nomore)
                        {
                          Value_new_ERROR(value, TYPEMISMATCH3,
                                          arg->u.error.msg, i + 1);
                        }

                      argerr = 1;
                      break;
                    }
                }
            }

          if (argerr)
            {
              if (nomore)
                {
                  Auto_funcReturn(&stack, (struct Pc *)0);
                  pc = funcpc;
                  return value;
                }
              else
                {
                  sym = sym->u.sub.u.bltin.next;
                }
            }
        }
      while (argerr);

      ident->sym = sym;
      if (sym->type == BUILTINFUNCTION)
        {
          if (pass == INTERPRET)
            {
              if (sym->u.sub.u.bltin.call(value, &stack)->type == V_ERROR)
                {
                  pc = funcpc;
                }
            }
          else
            {
              Value_new_null(value, sym->u.sub.retType);
            }
        }
      else if (sym->type == USERFUNCTION)
        {
          if (pass == INTERPRET)
            {
              int r = 1;

              pc = sym->u.sub.u.def.scope.start;
              if (pc.token->type == T_COLON)
                {
                  ++pc.token;
                }
              else
                {
                  Program_skipEOL(&program, &pc, STDCHANNEL, 1);
                }

              do
                {
                  if (statements(value)->type == V_ERROR)
                    {
                      if (strchr(value->u.error.msg, '\n') == (char *)0)
                        {
                          Auto_setError(&stack,
                                        Program_lineNumber(&program, &pc), &pc,
                                        value);
                          Program_PCtoError(&program, &pc, value);
                        }

                      if (stack.onerror.line != -1)
                        {
                          stack.resumeable = 1;
                          pc = stack.onerror;
                        }
                      else
                        {
                          Auto_frameToError(&stack, &program, value);
                          break;
                        }
                    }
                  else if (value->type != V_NIL)
                    {
                      break;
                    }

                  Value_destroy(value);
                }
              while ((r = Program_skipEOL(&program, &pc, STDCHANNEL, 1)));

              if (!r)
                {
                  Value_new_VOID(value);
                }
            }
          else
            {
              Value_new_null(value, sym->u.sub.retType);
            }
        }

      Auto_funcReturn(&stack, pass == INTERPRET &&
                      value->type != V_ERROR ? &pc : (struct Pc *)0);
    }

  return value;
}

#ifdef CONFIG_INTERPRETER_BAS_USE_LR0

/* Grammar with LR(0) sets */

/* Grammar:
 *
 *   1 EV -> E
 *   2 E  -> E op E
 *   3 E  -> op E
 *   4 E  -> ( E )
 *   5 E  -> value
 *
 *   i0:
 *   EV -> . E                goto(0,E)=5
 *   E  -> . E op E           goto(0,E)=5
 *   E  -> . op E      +,-    shift 2
 *   E  -> . ( E )     (      shift 3
 *   E  -> . value     value  shift 4
 *
 *   i5:
 *   EV -> E .         else   accept
 *   E  -> E . op E    op     shift 1
 *
 *   i2:
 *   E  -> op . E             goto(2,E)=6
 *   E  -> . E op E           goto(2,E)=6
 *   E  -> . op E      +,-    shift 2
 *   E  -> . ( E )     (      shift 3
 *   E  -> . value     value  shift 4
 *
 *   i3:
 *   E  -> ( . E )            goto(3,E)=7
 *   E  -> . E op E           goto(3,E)=7
 *   E  -> . op E      +,-    shift 2
 *   E  -> . ( E )     (      shift 3
 *   E  -> . value     value  shift 4
 *
 *   i4:
 *   E  -> value .            reduce 5
 *
 *   i1:
 *   E  -> E op . E           goto(1,E)=8
 *   E  -> . E op E           goto(1,E)=8
 *   E  -> . op E      +,-    shift 2
 *   E  -> . ( E )     (      shift 3
 *   E  -> . value     value  shift 4
 *
 *   i6:
 *   E  -> op E .             reduce 3
 *   E  -> E . op E    op*    shift 1 *=if stack[-2] contains op of unary lower priority
 *
 *   i7:
 *   E  -> ( E . )     )      shift 9
 *   E  -> E . op E    op     shift 1
 *
 *   i8:
 *   E  -> E op E .           reduce 2
 *   E  -> E . op E    op*    shift 1 *=if stack[-2] contains op of lower priority or if
 *                                      if it is of equal priority and right associative
 *   i9:
 *   E  -> ( E ) .            reduce 4
 */

static struct Value *eval(struct Value *value, const char *desc)
{
  /* Variables */

  static const int gotoState[10] = { 5, 8, 6, 7, -1, -1, -1, -1, -1, -1 };
  int capacity = 10;
  struct Pdastack
    {
      union
        {
          enum TokenType token;
          struct Value value;
        } u;
      char state;
    };
  struct Pdastack *pdastack = malloc(capacity * sizeof(struct Pdastack));
  struct Pdastack *sp = pdastack;
  struct Pdastack *stackEnd = pdastack + capacity - 1;
  enum TokenType ip;

  sp->state = 0;
  while (1)
    {
      if (sp == stackEnd)
        {
          pdastack =
            realloc(pdastack, (capacity + 10) * sizeof(struct Pdastack));
          sp = pdastack + capacity - 1;
          capacity += 10;
          stackEnd = pdastack + capacity - 1;
        }

      ip = pc.token->type;
      switch (sp->state)
        {
        case 0:
        case 1:
        case 2:
        case 3:                /* including 4 */
          {
            if (ip == T_IDENTIFIER)
              {
                /* printf("state %d: shift 4\n",sp->state); */
                /* printf("state 4: reduce E -> value\n"); */

                ++sp;
                sp->state = gotoState[(sp - 1)->state];
                if (pass == COMPILE)
                  {
                    if (((pc.token + 1)->type == T_OP ||
                         Auto_find(&stack, pc.token->u.identifier) == 0) &&
                        Global_find(&globals, pc.token->u.identifier,
                                    (pc.token + 1)->type == T_OP) == 0)
                      {
                        Value_new_ERROR(value, UNDECLARED);
                        goto error;
                      }
                  }

                if (pass != DECLARE &&
                    (pc.token->u.identifier->sym->type == GLOBALVAR ||
                     pc.token->u.identifier->sym->type == GLOBALARRAY ||
                     pc.token->u.identifier->sym->type == LOCALVAR))
                  {
                    struct Value *l;

                    if ((l = lvalue(value))->type == V_ERROR)
                      goto error;
                    Value_clone(&sp->u.value, l);
                  }
                else
                  {
                    struct Pc var = pc;

                    func(&sp->u.value);
                    if (sp->u.value.type == V_VOID)
                      {
                        pc = var;
                        Value_new_ERROR(value, VOIDVALUE);
                        goto error;
                      }
                  }
              }
            else if (ip == T_INTEGER)
              {
                /* printf("state %d: shift 4\n",sp->state); */
                /* printf("state 4: reduce E -> value\n"); */

                ++sp;
                sp->state = gotoState[(sp - 1)->state];
                VALUE_NEW_INTEGER(&sp->u.value, pc.token->u.integer);
                ++pc.token;
              }
            else if (ip == T_REAL)
              {
                /* printf("state %d: shift 4\n",sp->state); */
                /* printf("state 4: reduce E -> value\n"); */

                ++sp;
                sp->state = gotoState[(sp - 1)->state];
                VALUE_NEW_REAL(&sp->u.value, pc.token->u.real);
                ++pc.token;
              }
            else if (TOKEN_ISUNARYOPERATOR(ip))
              {
                /* printf("state %d: shift 2\n",sp->state); */

                ++sp;
                sp->state = 2;
                sp->u.token = ip;
                ++pc.token;
              }
            else if (ip == T_HEXINTEGER)
              {
                /* printf("state %d: shift 4\n",sp->state); */
                /* printf("state 4: reduce E -> value\n"); */

                ++sp;
                sp->state = gotoState[(sp - 1)->state];
                VALUE_NEW_INTEGER(&sp->u.value, pc.token->u.hexinteger);
                ++pc.token;
              }
            else if (ip == T_OCTINTEGER)
              {
                /* printf("state %d: shift 4\n",sp->state); */
                /* printf("state 4: reduce E -> value\n"); */

                ++sp;
                sp->state = gotoState[(sp - 1)->state];
                VALUE_NEW_INTEGER(&sp->u.value, pc.token->u.octinteger);
                ++pc.token;
              }
            else if (ip == T_OP)
              {
                /* printf("state %d: shift 3\n",sp->state); */

                ++sp;
                sp->state = 3;
                sp->u.token = T_OP;
                ++pc.token;
              }
            else if (ip == T_STRING)
              {
                /* printf("state %d: shift 4\n",sp->state); */
                /* printf("state 4: reduce E -> value\n"); */

                ++sp;
                sp->state = gotoState[(sp - 1)->state];
                Value_new_STRING(&sp->u.value);
                String_destroy(&sp->u.value.u.string);
                String_clone(&sp->u.value.u.string, pc.token->u.string);
                ++pc.token;
              }
            else
              {
                char state = sp->state;

                if (state == 0)
                  {
                    if (desc)
                      {
                        Value_new_ERROR(value, MISSINGEXPR, desc);
                      }
                    else
                      {
                        value = (struct Value *)0;
                      }
                  }
                else
                  {
                    Value_new_ERROR(value, MISSINGEXPR, _("operand"));
                  }

                goto error;
              }

            break;
          }

        case 5:
          {
            if (TOKEN_ISBINARYOPERATOR(ip))
              {
                /* printf("state %d: shift 1\n",sp->state); */

                ++sp;
                sp->state = 1;
                sp->u.token = ip;
                ++pc.token;
                break;
              }
            else
              {
                assert(sp == pdastack + 1);
                *value = sp->u.value;
                free(pdastack);
                return value;
              }

            break;
          }

        case 6:
          {
            if (TOKEN_ISBINARYOPERATOR(ip) &&
                TOKEN_UNARYPRIORITY((sp - 1)->u.token) <
                TOKEN_BINARYPRIORITY(ip))
              {
                assert(TOKEN_ISUNARYOPERATOR((sp - 1)->u.token));

                /* printf("state %d: shift 1 (not reducing E -> op E)\n", sp->state); */

                ++sp;
                sp->state = 1;
                sp->u.token = ip;
                ++pc.token;
              }
            else
              {
                enum TokenType op;

                /* printf("reduce E -> op E\n"); */

                --sp;
                op = sp->u.token;
                sp->u.value = (sp + 1)->u.value;
                switch (op)
                  {
                  case T_PLUS:
                    break;

                  case T_MINUS:
                    Value_uneg(&sp->u.value, pass == INTERPRET);
                    break;

                  case T_NOT:
                    Value_unot(&sp->u.value, pass == INTERPRET);
                    break;

                  default:
                    assert(0);
                  }

                sp->state = gotoState[(sp - 1)->state];
                if (sp->u.value.type == V_ERROR)
                  {
                    *value = sp->u.value;
                    --sp;
                    goto error;
                  }
              }

            break;
          }

        case 7:                /* including 9 */
          {
            if (TOKEN_ISBINARYOPERATOR(ip))
              {
                /* printf("state %d: shift 1\n"sp->state); */

                ++sp;
                sp->state = 1;
                sp->u.token = ip;
                ++pc.token;
              }
            else if (ip == T_CP)
              {
                /* printf("state %d: shift 9\n",sp->state); */
                /* printf("state 9: reduce E -> ( E )\n"); */

                --sp;
                sp->state = gotoState[(sp - 1)->state];
                sp->u.value = (sp + 1)->u.value;
                ++pc.token;
              }
            else
              {
                Value_new_ERROR(value, MISSINGCP);
                goto error;
              }

            break;
          }

        case 8:
          {
            int p1, p2;

            if (TOKEN_ISBINARYOPERATOR(ip)
                &&
                (((p1 = TOKEN_BINARYPRIORITY((sp - 1)->u.token)) < (p2 =
                                                                    TOKEN_BINARYPRIORITY
                                                                    (ip))) ||
                 (p1 == p2 && TOKEN_ISRIGHTASSOCIATIVE((sp - 1)->u.token))))
              {
                /* printf("state %d: shift 1\n",sp->state); */

                ++sp;
                sp->state = 1;
                sp->u.token = ip;
                ++pc.token;
              }
            else
              {
                /* printf("state %d: reduce E -> E op E\n",sp->state); */

                if (Value_commonType[(sp - 2)->u.value.type][sp->u.value.type]
                    == V_ERROR)
                  {
                    Value_destroy(&sp->u.value);
                    sp -= 2;
                    Value_destroy(&sp->u.value);
                    Value_new_ERROR(value, INVALIDOPERAND);
                    --sp;
                    goto error;
                  }
                else
                  {
                    switch ((sp - 1)->u.token)
                      {
                      case T_LT:
                        Value_lt(&(sp - 2)->u.value, &sp->u.value,
                                 pass == INTERPRET);
                        break;

                      case T_LE:
                        Value_le(&(sp - 2)->u.value, &sp->u.value,
                                 pass == INTERPRET);
                        break;

                      case T_EQ:
                        Value_eq(&(sp - 2)->u.value, &sp->u.value,
                                 pass == INTERPRET);
                        break;

                      case T_GE:
                        Value_ge(&(sp - 2)->u.value, &sp->u.value,
                                 pass == INTERPRET);
                        break;

                      case T_GT:
                        Value_gt(&(sp - 2)->u.value, &sp->u.value,
                                 pass == INTERPRET);
                        break;

                      case T_NE:
                        Value_ne(&(sp - 2)->u.value, &sp->u.value,
                                 pass == INTERPRET);
                        break;

                      case T_PLUS:
                        Value_add(&(sp - 2)->u.value, &sp->u.value,
                                  pass == INTERPRET);
                        break;
                      case T_MINUS:
                        Value_sub(&(sp - 2)->u.value, &sp->u.value,
                                  pass == INTERPRET);
                        break;

                      case T_MULT:
                        Value_mult(&(sp - 2)->u.value, &sp->u.value,
                                   pass == INTERPRET);
                        break;

                      case T_DIV:
                        Value_div(&(sp - 2)->u.value, &sp->u.value,
                                  pass == INTERPRET);
                        break;

                      case T_IDIV:
                        Value_idiv(&(sp - 2)->u.value, &sp->u.value,
                                   pass == INTERPRET);
                        break;

                      case T_MOD:
                        Value_mod(&(sp - 2)->u.value, &sp->u.value,
                                  pass == INTERPRET);
                        break;

                      case T_POW:
                        Value_pow(&(sp - 2)->u.value, &sp->u.value,
                                  pass == INTERPRET);
                        break;

                      case T_AND:
                        Value_and(&(sp - 2)->u.value, &sp->u.value,
                                  pass == INTERPRET);
                        break;

                      case T_OR:
                        Value_or(&(sp - 2)->u.value, &sp->u.value,
                                 pass == INTERPRET);
                        break;

                      case T_XOR:
                        Value_xor(&(sp - 2)->u.value, &sp->u.value,
                                  pass == INTERPRET);
                        break;

                      case T_EQV:
                        Value_eqv(&(sp - 2)->u.value, &sp->u.value,
                                  pass == INTERPRET);
                        break;

                      case T_IMP:
                        Value_imp(&(sp - 2)->u.value, &sp->u.value,
                                  pass == INTERPRET);
                        break;

                      default:
                        assert(0);
                      }
                  }

                Value_destroy(&sp->u.value);
                sp -= 2;
                sp->state = gotoState[(sp - 1)->state];
                if (sp->u.value.type == V_ERROR)
                  {
                    *value = sp->u.value;
                    --sp;
                    goto error;
                  }
              }

            break;
          }
        }
    }

error:
  while (sp > pdastack)
    {
      switch (sp->state)
        {
        case 5:
        case 6:
        case 7:
        case 8:
          Value_destroy(&sp->u.value);
        }
      --sp;
    }

  free(pdastack);
  return value;
}

#else
static inline struct Value *binarydown(struct Value *value,
                                       struct Value *(level) (struct Value *
                                                              value),
                                       const int prio)
{
  enum TokenType op;
  struct Pc oppc;

  if (level(value) == (struct Value *)0)
    {
      return (struct Value *)0;
    }

  if (value->type == V_ERROR)
    {
      return value;
    }

  do
    {
      struct Value x;

      op = pc.token->type;
      if (!TOKEN_ISBINARYOPERATOR(op) || TOKEN_BINARYPRIORITY(op) != prio)
        {
          return value;
        }

      oppc = pc;
      ++pc.token;
      if (level(&x) == (struct Value *)0)
        {
          Value_destroy(value);
          return Value_new_ERROR(value, MISSINGEXPR, _("binary operand"));
        }

      if (x.type == V_ERROR)
        {
          Value_destroy(value);
          *value = x;
          return value;
        }

      if (Value_commonType[value->type][x.type] == V_ERROR)
        {
          Value_destroy(value);
          Value_destroy(&x);
          return Value_new_ERROR(value, INVALIDOPERAND);
        }
      else
        {
          switch (op)
            {
            case T_LT:
              Value_lt(value, &x, pass == INTERPRET);
              break;

            case T_LE:
              Value_le(value, &x, pass == INTERPRET);
              break;

            case T_EQ:
              Value_eq(value, &x, pass == INTERPRET);
              break;

            case T_GE:
              Value_ge(value, &x, pass == INTERPRET);
              break;

            case T_GT:
              Value_gt(value, &x, pass == INTERPRET);
              break;

            case T_NE:
              Value_ne(value, &x, pass == INTERPRET);
              break;

            case T_PLUS:
              Value_add(value, &x, pass == INTERPRET);
              break;

            case T_MINUS:
              Value_sub(value, &x, pass == INTERPRET);
              break;

            case T_MULT:
              Value_mult(value, &x, pass == INTERPRET);
              break;

            case T_DIV:
              Value_div(value, &x, pass == INTERPRET);
              break;

            case T_IDIV:
              Value_idiv(value, &x, pass == INTERPRET);
              break;

            case T_MOD:
              Value_mod(value, &x, pass == INTERPRET);
              break;

            case T_POW:
              Value_pow(value, &x, pass == INTERPRET);
              break;

            case T_AND:
              Value_and(value, &x, pass == INTERPRET);
              break;

            case T_OR:
              Value_or(value, &x, pass == INTERPRET);
              break;

            case T_XOR:
              Value_xor(value, &x, pass == INTERPRET);
              break;

            case T_EQV:
              Value_eqv(value, &x, pass == INTERPRET);
              break;

            case T_IMP:
              Value_imp(value, &x, pass == INTERPRET);
              break;

            default:
              assert(0);
            }
        }

      Value_destroy(&x);
    }
  while (value->type != V_ERROR);

  if (value->type == V_ERROR)
    {
      pc = oppc;
    }

  return value;
}

static inline struct Value *unarydown(struct Value *value,
                                      struct Value *(level) (struct Value *
                                                             value),
                                      const int prio)
{
  enum TokenType op;
  struct Pc oppc;

  op = pc.token->type;
  if (!TOKEN_ISUNARYOPERATOR(op) || TOKEN_UNARYPRIORITY(op) != prio)
    {
      return level(value);
    }

  oppc = pc;
  ++pc.token;
  if (unarydown(value, level, prio) == (struct Value *)0)
    {
      return Value_new_ERROR(value, MISSINGEXPR, _("unary operand"));
    }

  if (value->type == V_ERROR)
    {
      return value;
    }

  switch (op)
    {
    case T_PLUS:
      Value_uplus(value, pass == INTERPRET);
      break;

    case T_MINUS:
      Value_uneg(value, pass == INTERPRET);
      break;

    case T_NOT:
      Value_unot(value, pass == INTERPRET);
      break;

    default:
      assert(0);
    }

  if (value->type == V_ERROR)
    {
      pc = oppc;
    }

  return value;
}

static struct Value *eval8(struct Value *value)
{
  switch (pc.token->type)
    {
    case T_IDENTIFIER:
      {
        struct Pc var;
        struct Value *l;

        var = pc;
        if (pass == COMPILE)
          {
            if (((pc.token + 1)->type == T_OP ||
                 Auto_find(&stack, pc.token->u.identifier) == 0) &&
                Global_find(&globals, pc.token->u.identifier,
                            (pc.token + 1)->type == T_OP) == 0)
              return Value_new_ERROR(value, UNDECLARED);
          }

        assert(pass == DECLARE || pc.token->u.identifier->sym);
        if (pass != DECLARE &&
            (pc.token->u.identifier->sym->type == GLOBALVAR ||
             pc.token->u.identifier->sym->type == GLOBALARRAY ||
             pc.token->u.identifier->sym->type == LOCALVAR))
          {
            if ((l = lvalue(value))->type == V_ERROR)
              {
                return value;
              }

            Value_clone(value, l);
          }
        else
          {
            func(value);
            if (value->type == V_VOID)
              {
                Value_destroy(value);
                pc = var;
                return Value_new_ERROR(value, VOIDVALUE);
              }
          }

        break;
      }

    case T_INTEGER:
      {
        VALUE_NEW_INTEGER(value, pc.token->u.integer);
        ++pc.token;
        break;
      }

    case T_REAL:
      {
        VALUE_NEW_REAL(value, pc.token->u.real);
        ++pc.token;
        break;
      }

    case T_STRING:
      {
        Value_new_STRING(value);
        String_destroy(&value->u.string);
        String_clone(&value->u.string, pc.token->u.string);
        ++pc.token;
        break;
      }

    case T_HEXINTEGER:
      {
        VALUE_NEW_INTEGER(value, pc.token->u.hexinteger);
        ++pc.token;
        break;
      }

    case T_OCTINTEGER:
      {
        VALUE_NEW_INTEGER(value, pc.token->u.octinteger);
        ++pc.token;
        break;
      }

    case T_OP:
      {
        ++pc.token;
        if (eval(value, _("parenthetic"))->type == V_ERROR)
          {
            return value;
          }

        if (pc.token->type != T_CP)
          {
            Value_destroy(value);
            return Value_new_ERROR(value, MISSINGCP);
          }

        ++pc.token;
        break;
      }

    default:
      {
        return (struct Value *)0;
      }
    }

  return value;
}

static struct Value *eval7(struct Value *value)
{
  return binarydown(value, eval8, 7);
}

static struct Value *eval6(struct Value *value)
{
  return unarydown(value, eval7, 6);
}

static struct Value *eval5(struct Value *value)
{
  return binarydown(value, eval6, 5);
}

static struct Value *eval4(struct Value *value)
{
  return binarydown(value, eval5, 4);
}

static struct Value *eval3(struct Value *value)
{
  return binarydown(value, eval4, 3);
}

static struct Value *eval2(struct Value *value)
{
  return unarydown(value, eval3, 2);
}

static struct Value *eval1(struct Value *value)
{
  return binarydown(value, eval2, 1);
}

static struct Value *eval(struct Value *value, const char *desc)
{
  /* Avoid function calls for atomic expression */

  switch (pc.token->type)
    {
    case T_STRING:
    case T_REAL:
    case T_INTEGER:
    case T_HEXINTEGER:
    case T_OCTINTEGER:
    case T_IDENTIFIER:
      if (!TOKEN_ISBINARYOPERATOR((pc.token + 1)->type) &&
          (pc.token + 1)->type != T_OP)
        {
          return eval7(value);
        }

    default:
      break;
    }

  if (binarydown(value, eval1, 0) == (struct Value *)0)
    {
      if (desc)
        {
          return Value_new_ERROR(value, MISSINGEXPR, desc);
        }
      else
        {
          return (struct Value *)0;
        }
    }
  else
    {
      return value;
    }
}
#endif

static void new(void)
{
  Global_destroy(&globals);
  Global_new(&globals);
  Auto_destroy(&stack);
  Auto_new(&stack);
  Program_destroy(&program);
  Program_new(&program);
  FS_closefiles();
  optionbase = 0;
}

static void pushLabel(enum LabelType type, struct Pc *patch)
{
  if (labelStackPointer == labelStackCapacity)
    {
      struct LabelStack *more;

      more =
        realloc(labelStack,
                sizeof(struct LabelStack) *
                (labelStackCapacity ? (labelStackCapacity *= 2) : (32)));
      labelStack = more;
    }

  labelStack[labelStackPointer].type = type;
  labelStack[labelStackPointer].patch = *patch;
  ++labelStackPointer;
}

static struct Pc *popLabel(enum LabelType type)
{
  if (labelStackPointer == 0 || labelStack[labelStackPointer - 1].type != type)
    {
      return (struct Pc *)0;
    }
  else
    {
      return &labelStack[--labelStackPointer].patch;
    }
}

static struct Pc *findLabel(enum LabelType type)
{
  int i;

  for (i = labelStackPointer - 1; i >= 0; --i)
    {
      if (labelStack[i].type == type)
        {
          return &labelStack[i].patch;
        }
    }

  return (struct Pc *)0;
}

static void labelStackError(struct Value *v)
{
  assert(labelStackPointer);
  pc = labelStack[labelStackPointer - 1].patch;
  switch (labelStack[labelStackPointer - 1].type)
    {
    case L_IF:
      Value_new_ERROR(v, STRAYIF);
      break;

    case L_DO:
      Value_new_ERROR(v, STRAYDO);
      break;

    case L_DOcondition:
      Value_new_ERROR(v, STRAYDOcondition);
      break;

    case L_ELSE:
      Value_new_ERROR(v, STRAYELSE2);
      break;

    case L_FOR_BODY:
      {
        Value_new_ERROR(v, STRAYFOR);
        pc = *findLabel(L_FOR);
        break;
      }

    case L_WHILE:
      Value_new_ERROR(v, STRAYWHILE);
      break;

    case L_REPEAT:
      Value_new_ERROR(v, STRAYREPEAT);
      break;

    case L_SELECTCASE:
      Value_new_ERROR(v, STRAYSELECTCASE);
      break;

    case L_FUNC:
      Value_new_ERROR(v, STRAYFUNC);
      break;

    default:
      assert(0);
    }
}

static const char *topLabelDescription(void)
{
  if (labelStackPointer == 0)
    {
      return _("program");
    }

  switch (labelStack[labelStackPointer - 1].type)
    {
    case L_IF:
      return _("`if' branch");

    case L_DO:
      return _("`do' loop");

    case L_DOcondition:
      return _("`do while' or `do until' loop");

    case L_ELSE:
      return _("`else' branch");

    case L_FOR_BODY:
      return _("`for' loop");

    case L_WHILE:
      return _("`while' loop");

    case L_REPEAT:
      return _("`repeat' loop");

    case L_SELECTCASE:
      return _("`select case' control structure");

    case L_FUNC:
      return _("function or procedure");

    default:
      assert(0);
    }

  /* NOTREACHED */

  return (const char *)0;
}

static struct Value *assign(struct Value *value)
{
  struct Pc expr;

  if (strcasecmp(pc.token->u.identifier->name, "mid$") == 0)
    {
      long int n, m;
      struct Value *l;

      ++pc.token;
      if (pc.token->type != T_OP)
        {
          return Value_new_ERROR(value, MISSINGOP);
        }

      ++pc.token;
      if (pc.token->type != T_IDENTIFIER)
        {
          return Value_new_ERROR(value, MISSINGSTRIDENT);
        }

      if (pass == DECLARE)
        {
          if (((pc.token + 1)->type == T_OP ||
               Auto_find(&stack, pc.token->u.identifier) == 0) &&
              Global_variable(&globals, pc.token->u.identifier,
                              pc.token->u.identifier->defaultType,
                              (pc.token + 1)->type ==
                              T_OP ? GLOBALARRAY : GLOBALVAR, 0) == 0)
            {
              return Value_new_ERROR(value, REDECLARATION);
            }
        }

      if ((l = lvalue(value))->type == V_ERROR)
        {
          return value;
        }

      if (pass == COMPILE && l->type != V_STRING)
        {
          return Value_new_ERROR(value, TYPEMISMATCH4);
        }

      if (pc.token->type != T_COMMA)
        {
          return Value_new_ERROR(value, MISSINGCOMMA);
        }

      ++pc.token;
      if (eval(value, _("position"))->type == V_ERROR ||
          Value_retype(value, V_INTEGER)->type == V_ERROR)
        {
          return value;
        }

      n = value->u.integer;
      Value_destroy(value);
      if (pass == INTERPRET && n < 1)
        {
          return Value_new_ERROR(value, OUTOFRANGE, "position");
        }

      if (pc.token->type == T_COMMA)
        {
          ++pc.token;
          if (eval(value, _("length"))->type == V_ERROR ||
              Value_retype(value, V_INTEGER)->type == V_ERROR)
            {
              return value;
            }

          m = value->u.integer;
          if (pass == INTERPRET && m < 0)
            {
              return Value_new_ERROR(value, OUTOFRANGE, _("length"));
            }

          Value_destroy(value);
        }
      else
        {
          m = -1;
        }

      if (pc.token->type != T_CP)
        {
          return Value_new_ERROR(value, MISSINGCP);
        }

      ++pc.token;
      if (pc.token->type != T_EQ)
        {
          return Value_new_ERROR(value, MISSINGEQ);
        }

      ++pc.token;
      if (eval(value, _("rhs"))->type == V_ERROR ||
          Value_retype(value, V_STRING)->type == V_ERROR)
        {
          return value;
        }

      if (pass == INTERPRET)
        {
          if (m == -1)
            {
              m = value->u.string.length;
            }

          String_set(&l->u.string, n - 1, &value->u.string, m);
        }
    }
  else
    {
      struct Value **l = (struct Value **)0;
      int i, used = 0, capacity = 0;
      struct Value retyped_value;

      for (;;)
        {
          if (used == capacity)
            {
              struct Value **more;

              capacity = capacity ? 2 * capacity : 2;
              more = realloc(l, capacity * sizeof(*l));
              l = more;
            }

          if (pass == DECLARE)
            {
              if (((pc.token + 1)->type == T_OP ||
                   Auto_find(&stack, pc.token->u.identifier) == 0) &&
                  Global_variable(&globals, pc.token->u.identifier,
                                  pc.token->u.identifier->defaultType,
                                  (pc.token + 1)->type ==
                                  T_OP ? GLOBALARRAY : GLOBALVAR, 0) == 0)
                {
                  if (capacity)
                    {
                      free(l);
                    }

                  return Value_new_ERROR(value, REDECLARATION);
                }
            }

          if ((l[used] = lvalue(value))->type == V_ERROR)
            {
              return value;
            }

          ++used;
          if (pc.token->type == T_COMMA)
            {
              ++pc.token;
            }
          else
            {
              break;
            }
        }

      if (pc.token->type != T_EQ)
        {
          return Value_new_ERROR(value, MISSINGEQ);
        }

      ++pc.token;
      expr = pc;
      if (eval(value, _("rhs"))->type == V_ERROR)
        {
          return value;
        }

      for (i = 0; i < used; ++i)
        {
          Value_clone(&retyped_value, value);
          if (pass != DECLARE &&
              VALUE_RETYPE(&retyped_value, (l[i])->type)->type == V_ERROR)
            {
              pc = expr;
              free(l);
              Value_destroy(value);
              *value = retyped_value;
              return value;
            }

          if (pass == INTERPRET)
            {
              Value_destroy(l[i]);
              *(l[i]) = retyped_value;
            }
        }

      free(l);
      Value_destroy(value);
      *value = retyped_value;   /* for status only */
    }

  return value;
}

static struct Value *compileProgram(struct Value *v, int clearGlobals)
{
  struct Pc begin;

  stack.resumeable = 0;
  if (clearGlobals)
    {
      Global_destroy(&globals);
      Global_new(&globals);
    }
  else
    {
      Global_clearFunctions(&globals);
    }

  if (Program_beginning(&program, &begin))
    {
      struct Pc savepc;
      int savepass;

      savepc = pc;
      savepass = pass;
      Program_norun(&program);
      for (pass = DECLARE; pass != INTERPRET; ++pass)
        {
          if (pass == DECLARE)
            {
              stack.begindata.line = -1;
              lastdata = &stack.begindata;
            }

          optionbase = 0;
          stopped = 0;
          program.runnable = 1;
          pc = begin;
          while (1)
            {
              statements(v);
              if (v->type == V_ERROR)
                {
                  break;
                }

              Value_destroy(v);
              if (!Program_skipEOL(&program, &pc, 0, 0))
                {
                  Value_new_NIL(v);
                  break;
                }
            }

          if (v->type != V_ERROR && labelStackPointer > 0)
            {
              Value_destroy(v);
              labelStackError(v);
            }

          if (v->type == V_ERROR)
            {
              labelStackPointer = 0;
              Program_norun(&program);
              if (stack.cur)
                {
                  Auto_funcEnd(&stack); /* Always correct? */
                }

              pass = savepass;
              return v;
            }
        }

      pc = begin;
      if (Program_analyse(&program, &pc, v))
        {
          labelStackPointer = 0;
          Program_norun(&program);
          if (stack.cur)
            {
              Auto_funcEnd(&stack);     /* Always correct? */
            }

          pass = savepass;
          return v;
        }

      curdata = stack.begindata;
      pc = savepc;
      pass = savepass;
    }

  return Value_new_NIL(v);
}

static void runline(struct Token *line)
{
  struct Value value;

  FS_flush(STDCHANNEL);
  for (pass = DECLARE; pass != INTERPRET; ++pass)
    {
      curdata.line = -1;
      pc.line = -1;
      pc.token = line;
      optionbase = 0;
      stopped = 0;
      statements(&value);
      if (value.type != V_ERROR && pc.token->type != T_EOL)
        {
          Value_destroy(&value);
          Value_new_ERROR(&value, SYNTAX);
        }

      if (value.type != V_ERROR && labelStackPointer > 0)
        {
          Value_destroy(&value);
          labelStackError(&value);
        }

      if (value.type == V_ERROR)
        {
          struct String s;

          Auto_setError(&stack, Program_lineNumber(&program, &pc), &pc, &value);
          Program_PCtoError(&program, &pc, &value);
          labelStackPointer = 0;
          FS_putChars(STDCHANNEL, _("Error: "));
          String_new(&s);
          Value_toString(&value, &s, ' ', -1, 0, 0, 0, 0, -1, 0, 0);
          Value_destroy(&value);
          FS_putString(STDCHANNEL, &s);
          String_destroy(&s);
          return;
        }

      if (!program.runnable && pass == COMPILE)
        {
          Value_destroy(&value);
          (void)compileProgram(&value, 0);
        }
    }

  pc.line = -1;
  pc.token = line;
  optionbase = 0;
  curdata = stack.begindata;
  nextdata.line = -1;
  Value_destroy(&value);
  pass = INTERPRET;

  do
    {
      assert(pass == INTERPRET);
      statements(&value);
      assert(pass == INTERPRET);
      if (value.type == V_ERROR)
        {
          if (strchr(value.u.error.msg, '\n') == (char *)0)
            {
              Auto_setError(&stack, Program_lineNumber(&program, &pc), &pc,
                            &value);
              Program_PCtoError(&program, &pc, &value);
            }

          if (stack.onerror.line != -1)
            {
              stack.resumeable = 1;
              pc = stack.onerror;
            }
          else
            {
              struct String s;

              String_new(&s);
              if (!stopped)
                {
                  stopped = 0;
                  FS_putChars(STDCHANNEL, _("Error: "));
                }

              Auto_frameToError(&stack, &program, &value);
              Value_toString(&value, &s, ' ', -1, 0, 0, 0, 0, -1, 0, 0);
              while (Auto_gosubReturn(&stack, (struct Pc *)0));
              FS_putString(STDCHANNEL, &s);
              String_destroy(&s);
              Value_destroy(&value);
              break;
            }
        }

      Value_destroy(&value);
    }
  while (pc.token->type != T_EOL ||
         Program_skipEOL(&program, &pc, STDCHANNEL, 1));
}

static struct Value *evalGeometry(struct Value *value, unsigned int *dim,
                                  unsigned int geometry[])
{
  struct Pc exprpc = pc;

  if (eval(value, _("dimension"))->type == V_ERROR ||
      (pass != DECLARE && Value_retype(value, V_INTEGER)->type == V_ERROR))
    {
      return value;
    }

  if (pass == INTERPRET && value->u.integer < optionbase)
    {
      Value_destroy(value);
      pc = exprpc;
      return Value_new_ERROR(value, OUTOFRANGE, _("dimension"));
    }

  geometry[0] = value->u.integer - optionbase + 1;
  Value_destroy(value);
  if (pc.token->type == T_COMMA)
    {
      ++pc.token;
      exprpc = pc;
      if (eval(value, _("dimension"))->type == V_ERROR ||
          (pass != DECLARE && Value_retype(value, V_INTEGER)->type == V_ERROR))
        {
          return value;
        }

      if (pass == INTERPRET && value->u.integer < optionbase)
        {
          Value_destroy(value);
          pc = exprpc;
          return Value_new_ERROR(value, OUTOFRANGE, _("dimension"));
        }

      geometry[1] = value->u.integer - optionbase + 1;
      Value_destroy(value);
      *dim = 2;
    }
  else
    {
      *dim = 1;
    }

  if (pc.token->type == T_CP)
    {
      ++pc.token;
    }
  else
    {
      return Value_new_ERROR(value, MISSINGCP);
    }

  return (struct Value *)0;
}

static struct Value *convert(struct Value *value, struct Value *l,
                             struct Token *t)
{
  switch (l->type)
    {
    case V_INTEGER:
      {
        char *datainput;
        char *end;
        long int v;
        int overflow;

        if (t->type != T_DATAINPUT)
          {
            return Value_new_ERROR(value, BADCONVERSION, _("integer"));
          }

        datainput = t->u.datainput;
        v = Value_vali(datainput, &end, &overflow);
        if (end == datainput || (*end != '\0' && *end != ' ' && *end != '\t'))
          {
            return Value_new_ERROR(value, BADCONVERSION, _("integer"));
          }

        if (overflow)
          {
            return Value_new_ERROR(value, OUTOFRANGE, _("converted value"));
          }

        Value_destroy(l);
        VALUE_NEW_INTEGER(l, v);
        break;
      }

    case V_REAL:
      {
        char *datainput;
        char *end;
        double v;
        int overflow;

        if (t->type != T_DATAINPUT)
          {
            return Value_new_ERROR(value, BADCONVERSION, _("real"));
          }

        datainput = t->u.datainput;
        v = Value_vald(datainput, &end, &overflow);
        if (end == datainput || (*end != '\0' && *end != ' ' && *end != '\t'))
          {
            return Value_new_ERROR(value, BADCONVERSION, _("real"));
          }

        if (overflow)
          {
            return Value_new_ERROR(value, OUTOFRANGE, _("converted value"));
          }

        Value_destroy(l);
        VALUE_NEW_REAL(l, v);
        break;
      }
    case V_STRING:
      {
        Value_destroy(l);
        Value_new_STRING(l);
        if (t->type == T_STRING)
          {
            String_appendString(&l->u.string, t->u.string);
          }
        else
          {
            String_appendChars(&l->u.string, t->u.datainput);
          }

        break;
      }

    default:
      assert(0);
    }

  return (struct Value *)0;
}

static struct Value *dataread(struct Value *value, struct Value *l)
{
  if (curdata.line == -1)
    {
      return Value_new_ERROR(value, ENDOFDATA);
    }

  if (curdata.token->type == T_DATA)
    {
      nextdata = curdata.token->u.nextdata;
      ++curdata.token;
    }

  if (convert(value, l, curdata.token))
    {
      return value;
    }

  ++curdata.token;
  if (curdata.token->type == T_COMMA)
    {
      ++curdata.token;
    }
  else
    {
      curdata = nextdata;
    }

  return (struct Value *)0;
}

static struct Value more_statements;
#include "statement.c"
static struct Value *statements(struct Value *value)
{
more:
  if (pc.token->statement)
    {
      struct Value *v;

      if ((v = pc.token->statement(value)))
        {
          if (v == &more_statements)
            {
              goto more;
            }
          else
            {
              return value;
            }
        }
    }
  else
    {
      return Value_new_ERROR(value, MISSINGSTATEMENT);
    }

  if (pc.token->type == T_COLON && (pc.token + 1)->type == T_ELSE)
    {
      ++pc.token;
    }
  else if ((pc.token->type == T_COLON && (pc.token + 1)->type != T_ELSE) ||
           pc.token->type == T_QUOTE)
    {
      ++pc.token;
      goto more;
    }
  else if ((pass == DECLARE || pass == COMPILE) && pc.token->type != T_EOL &&
           pc.token->type != T_ELSE)
    {
      return Value_new_ERROR(value, MISSINGCOLON);
    }

  return Value_new_NIL(value);
}

/****************************************************************************
 * Public Functions
 ****************************************************************************/

void bas_init(int backslash_colon, int restricted, int uppercase, int lpfd)
{
  stack.begindata.line = -1;
  Token_init(backslash_colon, uppercase);
  Global_new(&globals);
  Auto_new(&stack);
  Program_new(&program);
  FS_opendev(STDCHANNEL, 0, 1);
  FS_opendev(LPCHANNEL, -1, lpfd);
  run_restricted = restricted;
}

void bas_runFile(const char *runFile)
{
  struct Value value;
  int dev;

  new();
  if ((dev = FS_openin(runFile)) == -1)
    {
      const char *errmsg = FS_errmsg;

      FS_putChars(0, _("bas: Executing `"));
      FS_putChars(0, runFile);
      FS_putChars(0, _("' failed ("));
      FS_putChars(0, errmsg);
      FS_putChars(0, _(").\n"));
    }
  else if (Program_merge(&program, dev, &value))
    {
      struct String s;

      FS_putChars(0, "bas: ");
      String_new(&s);
      Value_toString(&value, &s, ' ', -1, 0, 0, 0, 0, -1, 0, 0);
      FS_putString(0, &s);
      String_destroy(&s);
      FS_putChar(0, '\n');
      Value_destroy(&value);
    }
  else
    {
      struct Token line[2];

      Program_setname(&program, runFile);
      line[0].type = T_RUN;
      line[0].statement = stmt_RUN;
      line[1].type = T_EOL;
      line[1].statement = stmt_COLON_EOL;

      FS_close(dev);
      runline(line);
    }
}

void bas_runLine(const char *runLine)
{
  struct Token *line;

  line = Token_newCode(runLine);
  runline(line + 1);
  Token_destroy(line);
}

void bas_interpreter(void)
{
  if (FS_istty(STDCHANNEL))
    {
      FS_putChars(STDCHANNEL, "bas " CONFIG_INTERPRETER_BAS_VERSION "\n");
      FS_putChars(STDCHANNEL, "Copyright 1999-2014 Michael Haardt.\n");
      FS_putChars(STDCHANNEL,
                  "This is free software with ABSOLUTELY NO WARRANTY.\n");
    }

  new();
  while (1)
    {
      struct Token *line;
      struct String s;

      stopped = 0;
      FS_nextline(STDCHANNEL);
      if (FS_istty(STDCHANNEL))
        {
          FS_putChars(STDCHANNEL, "> ");
        }

      FS_flush(STDCHANNEL);
      String_new(&s);
      if (FS_appendToString(STDCHANNEL, &s, 1) == -1)
        {
          FS_putChars(STDCHANNEL, FS_errmsg);
          FS_flush(STDCHANNEL);
          String_destroy(&s);
          break;
        }

      if (s.length == 0)
        {
          String_destroy(&s);
          break;
        }

      line = Token_newCode(s.character);
      String_destroy(&s);
      if (line->type != T_EOL)
        {
          if (line->type == T_INTEGER && line->u.integer > 0)
            {
              if (program.numbered)
                {
                  if ((line + 1)->type == T_EOL)
                    {
                      struct Pc where;

                      if (Program_goLine(&program, line->u.integer, &where) ==
                          (struct Pc *)0)
                        {
                          FS_putChars(STDCHANNEL, (NOSUCHLINE));
                        }
                      else
                        {
                          Program_delete(&program, &where, &where);
                        }

                      Token_destroy(line);
                    }
                  else
                    {
                      Program_store(&program, line, line->u.integer);
                    }
                }
              else
                {
                  FS_putChars(STDCHANNEL,
                              _("Use `renum' to number program first"));
                  Token_destroy(line);
                }
            }
          else if (line->type == T_UNNUMBERED)
            {
              runline(line + 1);
              Token_destroy(line);
              if (FS_istty(STDCHANNEL) && bas_end > 0)
                {
                  FS_putChars(STDCHANNEL, _("END program\n"));
                  bas_end = 0;
                }
            }
          else
            {
              FS_putChars(STDCHANNEL, _("Invalid line\n"));
              Token_destroy(line);
            }
        }
      else
        {
          Token_destroy(line);
        }
    }
}

void bas_exit(void)
{
  Auto_destroy(&stack);
  Global_destroy(&globals);
  Program_destroy(&program);
  if (labelStack)
    {
      free(labelStack);
    }

  FS_closefiles();
  FS_close(LPCHANNEL);
  FS_close(STDCHANNEL);
}