source: trunk/third/enscript/states/utils.c @ 17620

/*
 * General helper utilities.
 * Copyright (c) 1997 Markku Rossi.
 *
 * Author: Markku Rossi <mtr@iki.fi>
 */

/*
 * This file is part of GNU enscript.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2, or (at your option)
 * any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; see the file COPYING.  If not, write to
 * the Free Software Foundation, 59 Temple Place - Suite 330,
 * Boston, MA 02111-1307, USA.
 */

#include "defs.h"

/*
 * Static variables.
 */

static RE_TRANSLATE_TYPE case_insensitive_translate = NULL;


/*
 * Global functions.
 */

/* Generic linked list. */

List *
list ()
{
  return (List *) xcalloc (1, sizeof (List));
}


void
list_prepend (list, data)
     List *list;
     void *data;
{
  ListItem *item;

  item = (ListItem *) xmalloc (sizeof (*item));
  item->data = data;

  item->next = list->head;
  list->head = item;

  if (list->tail == NULL)
    list->tail = item;
}


void
list_append (list, data)
     List *list;
     void *data;
{
  ListItem *item;

  item = (ListItem *) xcalloc (1, sizeof (*item));
  item->data = data;

  if (list->tail)
    list->tail->next = item;
  else
    list->head = item;
  list->tail = item;
}

/*
 * Node manipulators.
 */

Node *
node_alloc (type)
     NodeType type;
{
  Node *n;

  n = (Node *) xcalloc (1, sizeof (*n));
  n->type = type;
  n->refcount = 1;
  n->linenum = linenum;

  if (type == nREGEXP)
    n->u.re.compiled.fastmap = xmalloc (256);

  return n;
}


Node *
node_copy (n)
     Node *n;
{
  Node *n2;
  int i;

  n2 = node_alloc (n->type);
  n2->linenum = n->linenum;

  switch (n->type)
    {
    case nVOID:
      /* All done. */
      break;

    case nSTRING:
      n2->u.str.len = n->u.str.len;
      /* +1 to avoid zero allocation. */
      n2->u.str.data = (char *) xmalloc (n2->u.str.len + 1);
      memcpy (n2->u.str.data, n->u.str.data, n->u.str.len);
      break;

    case nREGEXP:
      n2->u.re.data = xstrdup (n->u.re.data);
      n2->u.re.len = n->u.re.len;
      break;

    case nINTEGER:
      n2->u.integer = n->u.integer;
      break;

    case nREAL:
      n2->u.real = n->u.real;
      break;

    case nSYMBOL:
      n2->u.sym = xstrdup (n->u.sym);
      break;

    case nARRAY:
      n2->u.array.len = n->u.array.len;
      n2->u.array.allocated = n2->u.array.len + 1;
      n2->u.array.array = (Node **) xcalloc (n2->u.array.allocated,
                                             sizeof (Node *));
      for (i = 0; i < n->u.array.len; i++)
        n2->u.array.array[i] = node_copy (n->u.array.array[i]);
      break;
    }

  return n2;
}


void
node_reference (node)
     Node *node;
{
  node->refcount++;
}


void
node_free (node)
     Node *node;
{
  unsigned int i;

  if (node == NULL)
    return;

  if (--node->refcount > 0)
    return;

  /* This was the last reference, free the node. */
  switch (node->type)
    {
    case nVOID:
      /* There is only nVOID node, do not free it. */
      return;
      break;

    case nSTRING:
      xfree (node->u.str.data);
      break;

    case nREGEXP:
      free (node->u.re.data);
      xfree (node->u.re.compiled.fastmap);
      break;

    case nINTEGER:
    case nREAL:
    case nSYMBOL:
      /* Nothing here. */
      break;

    case nARRAY:
      for (i = 0; i < node->u.array.len; i++)
        node_free (node->u.array.array[i]);

      xfree (node->u.array.array);
      break;
    }

  xfree (node);
}


void
enter_system_variable (name, value)
     char *name;
     char *value;
{
  Node *n, *old_val;

  n = node_alloc (nSTRING);
  n->u.str.len = strlen (value);
  n->u.str.data = xstrdup (value);
  if (!strhash_put (ns_vars, name, strlen (name), n, (void **) &old_val))
    {
      fprintf (stderr, _("%s: out of memory\n"), program);
      exit (1);
    }
  node_free (old_val);
}


void
compile_regexp (re)
     Node *re;
{
  const char *msg;

  if (case_insensitive_translate == NULL)
    {
      int i;

      case_insensitive_translate = xmalloc (256);

      for (i = 0; i < 256; i++)
        if (isupper (i))
          case_insensitive_translate[i] = tolower (i);
        else
          case_insensitive_translate[i] = i;
    }

  if (re->u.re.flags & fRE_CASE_INSENSITIVE)
    re->u.re.compiled.translate = case_insensitive_translate;

  msg = re_compile_pattern (re->u.re.data, re->u.re.len, &re->u.re.compiled);
  if (msg)
    {
      fprintf (stderr,
               _("%s:%d: couldn't compile regular expression \"%s\": %s\n"),
               defs_file, re->linenum, re->u.re.data, msg);
      exit (1);
    }

  re_compile_fastmap (&re->u.re.compiled);
}


/*
 * Grammar constructors.
 */

Stmt *
mk_stmt (type, arg1, arg2, arg3, arg4)
     StmtType type;
     void *arg1;
     void *arg2;
     void *arg3;
     void *arg4;
{
  Stmt *stmt;

  stmt = (Stmt *) xcalloc (1, sizeof (*stmt));
  stmt->type = type;
  stmt->linenum = linenum;

  switch (type)
    {
    case sEXPR:
    case sRETURN:
      stmt->u.expr = arg1;
      break;

    case sDEFSUB:
      stmt->u.defsub.name = arg1;
      stmt->u.defsub.closure = arg2;
      break;

    case sBLOCK:
      stmt->u.block = arg1;     /* Statement list. */
      break;

    case sIF:
      stmt->u.stmt_if.expr = arg1;
      stmt->u.stmt_if.then_stmt = arg2;
      stmt->u.stmt_if.else_stmt = arg3;
      break;

    case sWHILE:
      stmt->u.stmt_while.expr = arg1;
      stmt->u.stmt_while.body = arg2;
      break;

    case sFOR:
      stmt->u.stmt_for.init = arg1;
      stmt->u.stmt_for.cond = arg2;
      stmt->u.stmt_for.incr = arg3;
      stmt->u.stmt_for.body = arg4;
      break;
    }

  return stmt;
}


Expr *
mk_expr (type, arg1, arg2, arg3)
     ExprType type;
     void *arg1;
     void *arg2;
     void *arg3;
{
  Expr *expr;

  expr = (Expr *) xcalloc (1, sizeof (*expr));
  expr->type = type;
  expr->linenum = linenum;

  switch (type)
    {
    case eSTRING:
    case eREGEXP:
    case eINTEGER:
    case eREAL:
    case eSYMBOL:
      expr->u.node = arg1;
      break;

    case eNOT:
      expr->u.not = arg1;
      break;

    case eFCALL:
      expr->u.fcall.name = arg1;
      expr->u.fcall.args = arg2;
      break;

    case eASSIGN:
    case eADDASSIGN:
    case eSUBASSIGN:
    case eMULASSIGN:
    case eDIVASSIGN:
      expr->u.assign.sym = arg1;
      expr->u.assign.expr = arg2;
      break;

    case ePOSTFIXADD:
    case ePOSTFIXSUB:
    case ePREFIXADD:
    case ePREFIXSUB:
      expr->u.node = arg1;
      break;

    case eARRAYASSIGN:
      expr->u.arrayassign.expr1 = arg1;
      expr->u.arrayassign.expr2 = arg2;
      expr->u.arrayassign.expr3 = arg3;
      break;

    case eARRAYREF:
      expr->u.arrayref.expr1 = arg1;
      expr->u.arrayref.expr2 = arg2;
      break;

    case eQUESTCOLON:
      expr->u.questcolon.cond = arg1;
      expr->u.questcolon.expr1 = arg2;
      expr->u.questcolon.expr2 = arg3;
      break;

    case eMULT:
    case eDIV:
    case ePLUS:
    case eMINUS:
    case eLT:
    case eGT:
    case eEQ:
    case eNE:
    case eGE:
    case eLE:
    case eAND:
    case eOR:
      expr->u.op.left = arg1;
      expr->u.op.right = arg2;
      break;
    }

  return expr;
}


Cons *
cons (car, cdr)
     void *car;
     void *cdr;
{
  Cons *c;

  c = (Cons *) xmalloc (sizeof (*c));
  c->car = car;
  c->cdr = cdr;

  return c;
}


void
define_state (sym, rules)
     Node *sym;
     List *rules;
{
  void *old_rules;
  char msg[512];

  if (!strhash_put (ns_states, sym->u.sym, strlen (sym->u.sym), rules,
                    &old_rules))
    {
      fprintf (stderr, _("%s: ouf of memory"), program);
      exit (1);
    }
  if (old_rules)
    {
      sprintf (msg, _("warning: redefining state `%s'"), sym->u.sym);
      yyerror (msg);
    }
}


/*
 * Expression evaluation.
 */

static void
define_sub (sym, args_body, linenum)
     Node *sym;
     Cons *args_body;
     unsigned int linenum;
{
  void *old_data;

  if (!strhash_put (ns_subs, sym->u.sym, strlen (sym->u.sym), args_body,
                    &old_data))
    {
      fprintf (stderr, _("%s: ouf of memory"), program);
      exit (1);
    }
  if (old_data && warning_level >= WARN_ALL)
    fprintf (stderr, _("%s:%d: warning: redefining subroutine `%s'\n"),
             defs_file, linenum, sym->u.sym);
}

extern unsigned int current_linenum;

static Node *
lookup_var (env, ns, sym, linenum)
     Environment *env;
     StringHashPtr ns;
     Node *sym;
     unsigned int linenum;
{
  Node *n;
  Environment *e;

  /* Special variables. */
  if (sym->u.sym[0] == '$' && sym->u.sym[1] && sym->u.sym[2] == '\0')
    {
      /* Regexp sub expression reference. */
      if (sym->u.sym[1] >= '0' && sym->u.sym[1] <= '9')
        {
          int i;
          int len;

          /* Matched text. */
          i = sym->u.sym[1] - '0';

          n = node_alloc (nSTRING);
          if (current_match == NULL || current_match->start[i] < 0
              || current_match_buf == NULL)
            {
              n->u.str.data = (char *) xmalloc (1);
              n->u.str.len = 0;
            }
          else
            {
              len = current_match->end[i] - current_match->start[i];
              n->u.str.data = (char *) xmalloc (len + 1);
              memcpy (n->u.str.data,
                      current_match_buf + current_match->start[i], len);
              n->u.str.len = len;
            }

          return n;
        }

      /* Everything before the matched expression. */
      if (sym->u.sym[1] == '`' || sym->u.sym[1] == 'B')
        {
          n = node_alloc (nSTRING);
          if (current_match == NULL || current_match->start[0] < 0
              || current_match_buf == NULL)
            {
              n->u.str.data = (char *) xmalloc (1);
              n->u.str.len = 0;
            }
          else
            {
              n->u.str.len = current_match->start[0];
              n->u.str.data = (char *) xmalloc (n->u.str.len + 1);
              memcpy (n->u.str.data, current_match_buf, n->u.str.len);
            }

          return n;
        }

      /* Current input line number. */
      if (sym->u.sym[1] == '.')
        {
          n = node_alloc (nINTEGER);
          n->u.integer = current_linenum;
          return n;
        }
    }

  /* Local variables. */
  for (e = env; e; e = e->next)
    if (strcmp (e->name, sym->u.sym) == 0)
      return e->val;

  /* Global variables. */
  if (strhash_get (ns, sym->u.sym, strlen (sym->u.sym), (void **) &n))
    return n;

  /* Undefined variable. */
  fprintf (stderr, _("%s:%d: error: undefined variable `%s'\n"),
           defs_file, linenum, sym->u.sym);
  exit (1);

  /* NOTREACHED */
  return NULL;
}


static void
set_var (env, ns, sym, val, linenum)
     Environment *env;
     StringHashPtr ns;
     Node *sym;
     Node *val;
     unsigned int linenum;
{
  Node *n;
  Environment *e;

  /* Local variables. */
  for (e = env; e; e = e->next)
    if (strcmp (e->name, sym->u.sym) == 0)
      {
        node_free (e->val);
        e->val = val;
        return;
      }

  /* Global variables. */
  if (strhash_put (ns, sym->u.sym, strlen (sym->u.sym), val, (void **) &n))
    {
      node_free (n);
      return;
    }

  /* Couldn't set value for variable. */
  fprintf (stderr, _("%s:%d: error: couldn't set variable `%s'\n"),
           defs_file, linenum, sym->u.sym);
  exit (1);
  /* NOTREACHED */
}


static Node *
calculate_binary (l, r, type, linenum)
     Node *l;
     Node *r;
     ExprType type;
     unsigned int linenum;
{
  Node *n = NULL;

  switch (type)
    {
    case eMULT:
    case eDIV:
    case ePLUS:
    case eMINUS:
    case eLT:
    case eGT:
    case eEQ:
    case eNE:
    case eGE:
    case eLE:
      if (l->type == r->type && l->type == nINTEGER)
        {
          n = node_alloc (nINTEGER);
          switch (type)
            {
            case eMULT:
              n->u.integer = (l->u.integer * r->u.integer);
              break;

            case eDIV:
              n->u.integer = (l->u.integer / r->u.integer);
              break;

            case ePLUS:
              n->u.integer = (l->u.integer + r->u.integer);
              break;

            case eMINUS:
              n->u.integer = (l->u.integer - r->u.integer);
              break;

            case eLT:
              n->u.integer = (l->u.integer < r->u.integer);
              break;

            case eGT:
              n->u.integer = (l->u.integer > r->u.integer);
              break;

            case eEQ:
              n->u.integer = (l->u.integer == r->u.integer);
              break;

            case eNE:
              n->u.integer = (l->u.integer != r->u.integer);
              break;

            case eGE:
              n->u.integer = (l->u.integer >= r->u.integer);
              break;

            case eLE:
              n->u.integer = (l->u.integer <= r->u.integer);
              break;

            default:
              /* NOTREACHED */
              break;
            }
        }
      else if ((l->type == nINTEGER || l->type == nREAL)
               && (r->type == nINTEGER || r->type == nREAL))
        {
          double dl, dr;

          if (l->type == nINTEGER)
            dl = (double) l->u.integer;
          else
            dl = l->u.real;

          if (r->type == nINTEGER)
            dr = (double) r->u.integer;
          else
            dr = r->u.real;

          n = node_alloc (nREAL);
          switch (type)
            {
            case eMULT:
              n->u.real = (dl * dr);
              break;

            case eDIV:
              n->u.real = (dl / dr);
              break;

            case ePLUS:
              n->u.real = (dl + dr);
              break;

            case eMINUS:
              n->u.real = (dl - dr);
              break;

            case eLT:
              n->type = nINTEGER;
              n->u.integer = (dl < dr);
              break;

            case eGT:
              n->type = nINTEGER;
              n->u.integer = (dl > dr);
              break;

            case eEQ:
              n->type = nINTEGER;
              n->u.integer = (dl == dr);
              break;

            case eNE:
              n->type = nINTEGER;
              n->u.integer = (dl != dr);
              break;

            case eGE:
              n->type = nINTEGER;
              n->u.integer = (dl >= dr);
              break;

            case eLE:
              n->type = nINTEGER;
              n->u.integer = (dl <= dr);
              break;

            default:
              /* NOTREACHED */
              break;
            }
        }
      else
        {
          fprintf (stderr,
                   _("%s:%d: error: expression between illegal types\n"),
                   defs_file, linenum);
          exit (1);
        }
      break;

    default:
      /* This is definitely a bug. */
      abort ();
      break;
    }

  return n;
}


Node *
eval_expr (expr, env)
     Expr *expr;
     Environment *env;
{
  Node *n = nvoid;
  Node *n2;
  Node *l, *r;
  Cons *c;
  Primitive prim;
  int return_seen;
  Environment *ei, *ei2;
  int i;
  Node sn;

  if (expr == NULL)
    return nvoid;

  switch (expr->type)
    {
    case eSTRING:
    case eREGEXP:
    case eINTEGER:
    case eREAL:
      node_reference (expr->u.node);
      return expr->u.node;
      break;

    case eSYMBOL:
      n = lookup_var (env, ns_vars, expr->u.node, expr->linenum);
      node_reference (n);
      return n;
      break;

    case eNOT:
      n = eval_expr (expr->u.not, env);
      i = !IS_TRUE (n);
      node_free (n);

      n = node_alloc (nINTEGER);
      n->u.integer = i;
      return n;
      break;

    case eFCALL:
      n = expr->u.fcall.name;
      /* User-defined subroutine? */
      if (strhash_get (ns_subs, n->u.sym, strlen (n->u.sym),
                       (void **) &c))
        {
          Environment *nenv = NULL;
          ListItem *i, *e;
          List *stmts;
          List *lst;
          Cons *args_locals;

          /* Found it, now bind arguments. */
          args_locals = (Cons *) c->car;
          stmts = (List *) c->cdr;

          lst = (List *) args_locals->car;

          for (i = lst->head, e = expr->u.fcall.args->head; i && e;
               i = i->next, e = e->next)
            {
              Node *sym;

              sym = (Node *) i->data;

              n = eval_expr ((Expr *) e->data, env);

              ei = (Environment *) xcalloc (1, sizeof (*ei));
              ei->name = sym->u.sym;
              ei->val = n;
              ei->next = nenv;
              nenv = ei;
            }
          /* Check that we had correct amount of arguments. */
          if (i)
            {
              fprintf (stderr, _("%s: too few arguments for subroutine\n"),
                       program);
              exit (1);
            }
          if (e)
            {
              fprintf (stderr, _("%s: too many arguments for subroutine\n"),
                       program);
              exit (1);
            }

          /* Enter local variables. */
          lst = (List *) args_locals->cdr;
          for (i = lst->head; i; i = i->next)
            {
              Cons *c;
              Node *sym;
              Expr *init;

              c = (Cons *) i->data;
              sym = (Node *) c->car;
              init = (Expr *) c->cdr;

              ei = (Environment *) xcalloc (1, sizeof (*ei));
              ei->name = sym->u.sym;

              if (init)
                ei->val = eval_expr (init, nenv);
              else
                ei->val = nvoid;

              ei->next = nenv;
              nenv = ei;
            }

          /* Eval statement list. */
          return_seen = 0;
          n = eval_statement_list ((List *) c->cdr, nenv, &return_seen);

          /* Cleanup env. */
          for (ei = nenv; ei; ei = ei2)
            {
              ei2 = ei->next;
              node_free (ei->val);
              xfree (ei);
            }

          return n;
        }
      /* Primitives. */
      else if (strhash_get (ns_prims, n->u.sym, strlen (n->u.sym),
                            (void **) &prim))
        {
          n = (*prim) (n->u.sym, expr->u.fcall.args, env, expr->linenum);
          return n;
        }
      else
        {
          fprintf (stderr, _("%s: undefined procedure `%s'\n"),
                   program, n->u.sym);
          exit (1);
        }
      break;

    case eASSIGN:
      n = eval_expr (expr->u.assign.expr, env);
      set_var (env, ns_vars, expr->u.assign.sym, n, expr->linenum);

      node_reference (n);
      return n;
      break;

    case eADDASSIGN:
    case eSUBASSIGN:
    case eMULASSIGN:
    case eDIVASSIGN:
      n = eval_expr (expr->u.assign.expr, env);
      n2 = lookup_var (env, ns_vars, expr->u.assign.sym, expr->linenum);

      switch (expr->type)
        {
        case eADDASSIGN:
          n2 = calculate_binary (n2, n, ePLUS, expr->linenum);
          break;

        case eSUBASSIGN:
          n2 = calculate_binary (n2, n, eMINUS, expr->linenum);
          break;

        case eMULASSIGN:
          n2 = calculate_binary (n2, n, eMULT, expr->linenum);
          break;

        case eDIVASSIGN:
          n2 = calculate_binary (n2, n, eDIV, expr->linenum);
          break;

        default:
          /* NOTREACHED */
          abort ();
          break;
        }
      set_var (env, ns_vars, expr->u.assign.sym, n2, expr->linenum);

      node_free (n);
      node_reference (n2);
      return n2;
      break;

    case ePOSTFIXADD:
    case ePOSTFIXSUB:
      sn.type = nINTEGER;
      sn.u.integer = 1;

      n2 = lookup_var (env, ns_vars, expr->u.node, expr->linenum);
      node_reference (n2);

      n = calculate_binary (n2, &sn,
                            expr->type == ePOSTFIXADD ? ePLUS : eMINUS,
                            expr->linenum);
      set_var (env, ns_vars, expr->u.node, n, expr->linenum);

      return n2;
      break;

    case ePREFIXADD:
    case ePREFIXSUB:
      sn.type = nINTEGER;
      sn.u.integer = 1;

      n = lookup_var (env, ns_vars, expr->u.node, expr->linenum);
      n = calculate_binary (n, &sn,
                            expr->type == ePREFIXADD ? ePLUS : eMINUS,
                            expr->linenum);
      set_var (env, ns_vars, expr->u.node, n, expr->linenum);

      node_reference (n);
      return n;
      break;

    case eARRAYASSIGN:
      n = eval_expr (expr->u.arrayassign.expr1, env);
      if (n->type != nARRAY && n->type != nSTRING)
        {
          fprintf (stderr,
                   _("%s:%d: error: illegal lvalue for assignment\n"),
                   defs_file, expr->linenum);
          exit (1);
        }
      n2 = eval_expr (expr->u.arrayassign.expr2, env);
      if (n2->type != nINTEGER)
        {
          fprintf (stderr,
                   _("%s:%d: error: array reference index is not integer\n"),
                   defs_file, expr->linenum);
          exit (1);
        }
      if (n2->u.integer < 0)
        {
          fprintf (stderr, _("%s:%d: error: negative array reference index\n"),
                   defs_file, expr->linenum);
          exit (1);
        }

      /* Do the assignment. */
      if (n->type == nARRAY)
        {
          if (n2->u.integer >= n->u.array.len)
            {
              if (n2->u.integer >= n->u.array.allocated)
                {
                  /* Allocate more space. */
                  n->u.array.allocated = n2->u.integer + 100;
                  n->u.array.array = (Node **) xrealloc (n->u.array.array,
                                                         n->u.array.allocated
                                                         * sizeof (Node *));
                }
              /* Fill the possible gap. */
              for (i = n->u.array.len; i <= n2->u.integer; i++)
                n->u.array.array[i] = nvoid;

              /* Updated expanded array length. */
              n->u.array.len = n2->u.integer + 1;
            }
          node_free (n->u.array.array[n2->u.integer]);

          l = eval_expr (expr->u.arrayassign.expr3, env);

          /* +1 for the return value. */
          node_reference (l);

          n->u.array.array[n2->u.integer] = l;
        }
      else
        {
          if (n2->u.integer >= n->u.str.len)
            {
              i = n->u.str.len;
              n->u.str.len = n2->u.integer + 1;
              n->u.str.data = (char *) xrealloc (n->u.str.data,
                                                 n->u.str.len);

              /* Init the expanded string with ' ' character. */
              for (; i < n->u.str.len; i++)
                n->u.str.data[i] = ' ';
            }
          l = eval_expr (expr->u.arrayassign.expr3, env);
          if (l->type != nINTEGER)
            {
              fprintf (stderr,
                       _("%s:%d: error: illegal rvalue for string assignment\n"),
                       defs_file, expr->linenum);
              exit (1);
            }

          n->u.str.data[n2->u.integer] = l->u.integer;
        }

      node_free (n);
      node_free (n2);

      return l;
      break;

    case eARRAYREF:
      n = eval_expr (expr->u.arrayref.expr1, env);
      if (n->type != nARRAY && n->type != nSTRING)
        {
          fprintf (stderr,
                   _("%s:%d: error: illegal type for array reference\n"),
                   defs_file, expr->linenum);
          exit (1);
        }
      n2 = eval_expr (expr->u.arrayref.expr2, env);
      if (n2->type != nINTEGER)
        {
          fprintf (stderr,
                   _("%s:%d: error: array reference index is not integer\n"),
                   defs_file, expr->linenum);
          exit (1);
        }
      if (n2->u.integer < 0
          || (n->type == nARRAY && n2->u.integer >= n->u.array.len)
          || (n->type == nSTRING && n2->u.integer >= n->u.str.len))
        {
          fprintf (stderr,
                   _("%s:%d: error: array reference index out of rance\n"),
                   defs_file, expr->linenum);
          exit (1);
        }

      /* Do the reference. */
      if (n->type == nARRAY)
        {
          l = n->u.array.array[n2->u.integer];
          node_reference (l);
        }
      else
        {
          l = node_alloc (nINTEGER);
          l->u.integer
            = (int) ((unsigned char *) n->u.str.data)[n2->u.integer];
        }
      node_free (n);
      node_free (n2);
      return l;
      break;

    case eQUESTCOLON:
      n = eval_expr (expr->u.questcolon.cond, env);
      i = IS_TRUE (n);
      node_free (n);

      if (i)
        n = eval_expr (expr->u.questcolon.expr1, env);
      else
        n = eval_expr (expr->u.questcolon.expr2, env);

      return n;
      break;

    case eAND:
      n = eval_expr (expr->u.op.left, env);
      if (!IS_TRUE (n))
        return n;
      node_free (n);
      return eval_expr (expr->u.op.right, env);
      break;

    case eOR:
      n = eval_expr (expr->u.op.left, env);
      if (IS_TRUE (n))
        return n;
      node_free (n);
      return eval_expr (expr->u.op.right, env);
      break;

      /* Arithmetics. */
    case eMULT:
    case eDIV:
    case ePLUS:
    case eMINUS:
    case eLT:
    case eGT:
    case eEQ:
    case eNE:
    case eGE:
    case eLE:
      /* Eval sub-expressions. */
      l = eval_expr (expr->u.op.left, env);
      r = eval_expr (expr->u.op.right, env);

      n = calculate_binary (l, r, expr->type, expr->linenum);

      node_free (l);
      node_free (r);
      return n;
      break;
    }

  /* NOTREACHED */
  return n;
}


Node *
eval_statement (stmt, env, return_seen)
     Stmt *stmt;
     Environment *env;
     int *return_seen;
{
  Node *n = nvoid;
  Node *n2;
  int i;

  switch (stmt->type)
    {
    case sRETURN:
      n = eval_expr (stmt->u.expr, env);
      *return_seen = 1;
      break;

    case sDEFSUB:
      define_sub (stmt->u.defsub.name, stmt->u.defsub.closure, stmt->linenum);
      break;

    case sBLOCK:
      n = eval_statement_list (stmt->u.block, env, return_seen);
      break;

    case sIF:
      n = eval_expr (stmt->u.stmt_if.expr, env);
      i = IS_TRUE (n);
      node_free (n);

      if (i)
        /* Then branch. */
        n = eval_statement (stmt->u.stmt_if.then_stmt, env, return_seen);
      else
        {
          /* Optional else branch.  */
          if (stmt->u.stmt_if.else_stmt)
            n = eval_statement (stmt->u.stmt_if.else_stmt, env, return_seen);
          else
            n = nvoid;
        }
      break;

    case sWHILE:
      while (1)
        {
          n2 = eval_expr (stmt->u.stmt_while.expr, env);
          i = IS_TRUE (n2);
          node_free (n2);

          if (!i)
            break;

          node_free (n);

          /* Eval body. */
          n = eval_statement (stmt->u.stmt_while.body, env, return_seen);
          if (*return_seen)
            break;
        }
      break;

    case sFOR:
      /* Init. */
      if (stmt->u.stmt_for.init)
        {
          n2 = eval_expr (stmt->u.stmt_for.init, env);
          node_free (n2);
        }

      /* Body. */
      while (1)
        {
          n2 = eval_expr (stmt->u.stmt_for.cond, env);
          i = IS_TRUE (n2);
          node_free (n2);

          if (!i)
            break;

          node_free (n);

          /* Eval body. */
          n = eval_statement (stmt->u.stmt_for.body, env, return_seen);
          if (*return_seen)
            break;

          /* Increment. */
          if (stmt->u.stmt_for.incr)
            {
              n2 = eval_expr (stmt->u.stmt_for.incr, env);
              node_free (n2);
            }
        }
      break;

    case sEXPR:
      n = eval_expr (stmt->u.expr, env);
      break;
    }

  return n;
}


Node *
eval_statement_list (lst, env, return_seen)
     List *lst;
     Environment *env;
     int *return_seen;
{
  ListItem *i;
  Stmt *stmt;
  Node *n = nvoid;

  if (lst == NULL)
    return nvoid;

  for (i = lst->head; i; i = i->next)
    {
      node_free (n);

      stmt = (Stmt *) i->data;

      n = eval_statement (stmt, env, return_seen);
      if (*return_seen)
        return n;
    }

  return n;
}