Update FSF address in copyright header.

[platform/upstream/gcc.git] / gcc / ch / actions.c

/* Implement actions for CHILL.
   Copyright (C) 1992, 93, 1994, 1998 Free Software Foundation, Inc.
   Authors: Per Bothner, Bill Cox, Michael Tiemann, Michael North

This file is part of GNU CC.

GNU CC 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.

GNU CC 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 GNU CC; see the file COPYING.  If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.  */

#include "config.h"
#include "system.h"
#include "tree.h"
#include "rtl.h"
#include "expr.h"
#include "ch-tree.h"
#include "lex.h"
#include "flags.h"
#include "actions.h"
#include "obstack.h"
#include "assert.h"
#include "toplev.h"

#define obstack_chunk_alloc xmalloc
#define obstack_chunk_free free

/* reserved tag definitions */

#define TYPE_ID                 "id"
#define TAG_OBJECT              "chill_object"
#define TAG_CLASS               "chill_class"

extern int flag_short_enums;
extern int current_nesting_level;

extern struct obstack *expression_obstack, permanent_obstack;
extern struct obstack *current_obstack, *saveable_obstack;

/* This flag is checked throughout the non-CHILL-specific
   in the front end. */
tree chill_integer_type_node;
tree chill_unsigned_type_node;

/* Never used.  Referenced from c-typeck.c, which we use. */
int current_function_returns_value = 0;
int current_function_returns_null = 0;

/* data imported from toplev.c  */

extern char *dump_base_name;

/* set from command line parameter, to exit after 
   grant file written, generating no code. */
int grant_only_flag = 0;
\f
char *
lang_identify ()
{
  return "chill";
}


void
init_chill ()
{
}

void
print_lang_statistics ()
{
}


void
lang_finish ()
{
#if 0
    extern int errorcount, sorrycount;

    /* this should be the last action in compiling a module.
       If there are other actions to be performed at lang_finish
       please insert before this */

    /* FIXME: in case of a syntax error, this leaves the grant file incomplete */
    /* for the moment we print a warning in case of errors and 
       continue granting */
    if ((errorcount || sorrycount) && grant_count)
      {
        warning ("%d errors, %d sorries, do granting", errorcount, sorrycount);
        errorcount = sorrycount = 0;
      }
#endif
}

void
chill_check_decl (decl)
     tree decl;
{
  tree type = TREE_TYPE (decl);
  static int alreadyWarned = 0;

  if (TREE_CODE (type) == RECORD_TYPE) /* && TREE_STATIC_TEMPLATE (type)) */
    {
      if (!alreadyWarned)
        {
          error ("GNU compiler does not support statically allocated objects");          
          alreadyWarned = 1;
        }
      error_with_decl (decl, "`%s' cannot be statically allocated");
    }
}
\f
/* Comparison function for sorting identifiers in RAISES lists.
   Note that because IDENTIFIER_NODEs are unique, we can sort
   them by address, saving an indirection.  */
static int
id_cmp (p1, p2)
     tree *p1, *p2;
{
  long diff = (long)TREE_VALUE (*p1) - (long)TREE_VALUE (*p2);

  return (diff < 0) ? -1 : (diff > 0);
}

/* Build the FUNCTION_TYPE or METHOD_TYPE which may raise exceptions
   listed in RAISES.  */
tree
build_exception_variant (type, raises)
     tree type, raises;
{
  int i;
  tree v = TYPE_MAIN_VARIANT (type);
  tree t, t2;
  int constp    = TYPE_READONLY (type);
  int volatilep = TYPE_VOLATILE (type);

  if (!raises)
    return build_type_variant (v, constp, volatilep);

  if (TREE_CHAIN (raises))
    { /* Sort the list */
      tree *a = (tree *)alloca ((list_length (raises)+1) * sizeof (tree));
      for (i = 0, t = raises; t; t = TREE_CHAIN (t), i++)
        a[i] = t;
      /* NULL terminator for list.  */
      a[i] = NULL_TREE;
      qsort (a, i, sizeof (tree), id_cmp);
      while (i--)
        TREE_CHAIN (a[i]) = a[i+1];
      raises = a[0];
    }

  for (v = TYPE_NEXT_VARIANT (v); v; v = TYPE_NEXT_VARIANT (v))
    {
      if (TYPE_READONLY (v) != constp
          || TYPE_VOLATILE (v) != volatilep)
        continue;

      t = raises;
      t2 = TYPE_RAISES_EXCEPTIONS (v);
      while (t && t2)
        {
          if (TREE_TYPE (t) == TREE_TYPE (t2))
            {
              t = TREE_CHAIN (t);
              t2 = TREE_CHAIN (t2);
            }
          else break;
        }
      if (t || t2)
        continue;
      /* List of exceptions raised matches previously found list.

         @@ Nice to free up storage used in consing up the
         @@ list of exceptions raised.  */
      return v;
    }

  /* Need to build a new variant.  */
  if (TREE_PERMANENT (type))
    {
      push_obstacks_nochange ();
      end_temporary_allocation ();
      v = copy_node (type);
      pop_obstacks ();
    }
  else
    v = copy_node (type);

  TYPE_NEXT_VARIANT (v) = TYPE_NEXT_VARIANT (type);
  TYPE_NEXT_VARIANT (type) = v;
  if (raises && ! TREE_PERMANENT (raises))
    {
      push_obstacks_nochange ();
      end_temporary_allocation ();
      raises = copy_list (raises);
      pop_obstacks ();
    }
  TYPE_RAISES_EXCEPTIONS (v) = raises;
  return v;
}
#if 0
\f
tree
build_rts_call (name, type, args)
     char *name;
     tree type, args;
{
  tree decl = lookup_name (get_identifier (name));
  tree converted_args = NULL_TREE;
  tree result, length = NULL_TREE;

  assert (decl != NULL_TREE);
  while (args)
    {
      tree arg = TREE_VALUE (args);
      if (TREE_CODE (TREE_TYPE (arg)) == SET_TYPE
          || TREE_CODE (TREE_TYPE (arg)) == ARRAY_TYPE)
        {
          length = size_in_bytes (TREE_TYPE (arg));
          arg = build_chill_addr_expr (arg, (char *)0);
        }
      converted_args = tree_cons (NULL_TREE, arg, converted_args);
      args = TREE_CHAIN (args);
    }
  if (length != NULL_TREE)
    converted_args = tree_cons (NULL_TREE, length, converted_args);
  converted_args = nreverse (converted_args);
  result = build_chill_function_call (decl, converted_args);
  if (TREE_CODE (type) == SET_TYPE || TREE_CODE (type) == ARRAY_TYPE)
    result = build1 (INDIRECT_REF, type, result);
  else
    result = convert (type, result);
  return result;
}
#endif

/*
 * queue name of unhandled exception
 * to avoid multiple unhandled warnings
 * in one compilation module
 */

struct already_type
{
  struct already_type *next;
  char *name;
};

static struct already_type *already_warned = 0;

static void
warn_unhandled (ex)
     char *ex;
{
  struct already_type *p = already_warned;

  while (p)
    {
      if (!strcmp (p->name, ex))
        return;
      p = p->next;
    }
  
  /* not yet warned */
  p = (struct already_type *)xmalloc (sizeof (struct already_type));
  p->next = already_warned;
  p->name = (char *)xmalloc (strlen (ex) + 1);
  strcpy (p->name, ex);
  already_warned = p;
  pedwarn ("causing unhandled exception `%s' (this is flaged only once)", ex);
}

/*
 * build a call to the following function:
 *   void   __cause_ex1 (char* ex, const char *file, 
 *                       const unsigned lineno);
 * if the exception is handled or
 *   void __unhandled_ex (char *ex, char *file, unsigned lineno)
 * if the exception is not handled.
 */
tree
build_cause_exception (exp_name, warn_if_unhandled)
     tree exp_name;
     int warn_if_unhandled;
{
  /* We don't use build_rts_call() here, because the string (array of char)
     would be followed by its length in the parameter list built by
     build_rts_call, and the runtime routine doesn't want a length parameter.*/
  tree exp_decl = build_chill_exception_decl (IDENTIFIER_POINTER (exp_name));
  tree function, fname, lineno, result;
  int handled = is_handled (exp_name);

  switch (handled)
    {
    case 0:
      /* no handler */
      if (warn_if_unhandled)
        warn_unhandled (IDENTIFIER_POINTER (exp_name));
      function = lookup_name (get_identifier ("__unhandled_ex"));
      fname = force_addr_of (get_chill_filename ());
      lineno = get_chill_linenumber ();
      break;
    case 1:
      /* local handler */
      function = lookup_name (get_identifier ("__cause_ex1"));
      fname = force_addr_of (get_chill_filename ());
      lineno = get_chill_linenumber ();
      break;
    case 2:
      /* function may propagate this exception */
      function = lookup_name (get_identifier ("__cause_ex1"));
      fname = lookup_name (get_identifier (CALLER_FILE));
      if (fname == NULL_TREE)
        fname = error_mark_node;
      lineno = lookup_name (get_identifier (CALLER_LINE));
      if (lineno == NULL_TREE)
        lineno = error_mark_node;
      break;
    default:
      abort();
    }
  result =
    build_chill_function_call (function,
      tree_cons (NULL_TREE, build_chill_addr_expr (exp_decl, (char *)0),
        tree_cons (NULL_TREE,  fname,
          tree_cons (NULL_TREE, lineno, NULL_TREE))));
  return result;
}

void
expand_cause_exception (exp_name)
     tree exp_name;
{
  expand_expr_stmt (build_cause_exception (exp_name, 1));
}

/* If CONDITION is true, raise EXCEPTION (an IDENTIFIER_NODE);
   otherwise return EXPR. */

tree
check_expression (expr, condition, exception)
     tree expr, condition, exception;
{
  if (integer_zerop (condition))
    return expr;
  else
    return build (COMPOUND_EXPR, TREE_TYPE (expr),
                  fold (build (TRUTH_ANDIF_EXPR, boolean_type_node,
                               condition, build_cause_exception (exception, 0))),
                  expr);
}

/* Return an expression for VALUE < LO_LIMIT || VALUE > HI_LIMIT,
   somewhat optimized and with some warnings suppressed.
   If LO_LIMIT or HI_LIMIT is NULL_TREE, assume that (sub-)test passes.  */

tree
test_range (value, lo_limit, hi_limit)
     tree value, lo_limit, hi_limit;
{
  if (lo_limit || hi_limit)
    {
      int old_inhibit_warnings = inhibit_warnings;
      tree lo_check, hi_check, check;

      /* This is a hack so that `shorten_compare' doesn't warn the
         user about useless range checks that are too much work to
         optimize away here.  */
      inhibit_warnings = 1;

      lo_check = lo_limit ? 
        fold (build_compare_discrete_expr (LT_EXPR, value, lo_limit)) :
          boolean_false_node;   /* fake passing the check */

      hi_check = hi_limit ? 
        fold (build_compare_discrete_expr (GT_EXPR, value, hi_limit)) :
          boolean_false_node;   /* fake passing the check */

      if (lo_check == boolean_false_node)
        check = hi_check;
      else if (hi_check == boolean_false_node)
        check = lo_check;
      else
        check = fold (build (TRUTH_ORIF_EXPR, boolean_type_node,
                             lo_check, hi_check));

      inhibit_warnings = old_inhibit_warnings;
      return check;
    }
  else
    return boolean_false_node;
}

/* Return EXPR, except if range_checking is on, return an expression
   that also checks that value >= low_limit && value <= hi_limit.
   If LO_LIMIT or HI_LIMIT is NULL_TREE, assume that test passes.  */

tree
check_range (expr, value, lo_limit, hi_limit)
     tree expr, value, lo_limit, hi_limit;
{
  tree check = test_range (value, lo_limit, hi_limit);
  if (!integer_zerop (check))
    {
      if (current_function_decl == NULL_TREE)
        {
          if (TREE_CODE (check) == INTEGER_CST)
            error ("range failure (not inside function)");
          else
            warning ("possible range failure (not inside function)");
        }
      else
        {
          if (TREE_CODE (check) == INTEGER_CST)
            warning ("expression will always cause RANGEFAIL");
          if (range_checking)
            expr = check_expression (expr, check,
                                     ridpointers[(int) RID_RANGEFAIL]);
        }
    }
  return expr;
}

/* Same as EXPR, except raise EMPTY if EXPR is NULL. */

tree
check_non_null (expr)
     tree expr;
{
  if (empty_checking)
    {
      expr = save_if_needed (expr);
      return check_expression (expr,
                               build_compare_expr (EQ_EXPR,
                                                   expr, null_pointer_node),
                               ridpointers[(int) RID_EMPTY]);
    }
  return expr;
}
\f
/*
 * There are four conditions to generate a runtime check:
 *    1) assigning a longer INT to a shorter (signs irrelevant)
 *    2) assigning a signed to an unsigned
 *    3) assigning an unsigned to a signed of the same size.
 *    4) TYPE is a discrete subrange
 */
tree
chill_convert_for_assignment (type, expr, place)
     tree type, expr;
     char *place; /* location description for error messages */
{
  tree ttype = type;
  tree etype = TREE_TYPE (expr);
  tree result;

  if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
    return error_mark_node;
  if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
    return expr;
  if (TREE_CODE (expr) == TYPE_DECL)
    {
      error ("right hand side of assignment is a mode");
      return error_mark_node;
    }

  if (! CH_COMPATIBLE (expr, type))
    {
      error ("incompatible modes in %s", place);
      return error_mark_node;
    }

  if (TREE_CODE (type) == REFERENCE_TYPE)
    ttype = TREE_TYPE (ttype);
  if (etype && TREE_CODE (etype) == REFERENCE_TYPE)
    etype = TREE_TYPE (etype);

  if (etype
      && (CH_STRING_TYPE_P (ttype)
          || (chill_varying_type_p (ttype)
              && CH_STRING_TYPE_P (CH_VARYING_ARRAY_TYPE (ttype))))
      && (CH_STRING_TYPE_P (etype)
          || (chill_varying_type_p (etype)
              && CH_STRING_TYPE_P (CH_VARYING_ARRAY_TYPE (etype)))))
    {
      tree cond;
      if (range_checking)
        expr = save_if_needed (expr);
      cond = string_assignment_condition (ttype, expr);
      if (TREE_CODE (cond) == INTEGER_CST)
        {
          if (integer_zerop (cond))
            {
              error ("bad string length in %s", place);
              return error_mark_node;
            }
          /* Otherwise, the condition is always true, so no runtime test. */
        }
      else if (range_checking)
        expr = check_expression (expr,
                                 invert_truthvalue (cond),
                                 ridpointers[(int) RID_RANGEFAIL]);
    }

  if (range_checking 
      && discrete_type_p (ttype) 
      && etype != NULL_TREE
      && discrete_type_p (etype))
    {
      int cond1 = tree_int_cst_lt (TYPE_SIZE (ttype),
                                   TYPE_SIZE (etype));
      int cond2 = TREE_UNSIGNED (ttype) 
                  && (! TREE_UNSIGNED (etype));
      int cond3 = (! TREE_UNSIGNED (type))
                  && TREE_UNSIGNED (etype) 
                  && tree_int_cst_equal (TYPE_SIZE (ttype),
                                         TYPE_SIZE (etype));
      int cond4 = TREE_TYPE (ttype) 
                  && discrete_type_p (TREE_TYPE (ttype));

      if (cond1 || cond2 || cond3 || cond4)
        {
          tree type_min = TYPE_MIN_VALUE (ttype);
          tree type_max = TYPE_MAX_VALUE (ttype);

          expr = save_if_needed (expr);
          if (expr && type_min && type_max)
            expr = check_range (expr, expr, type_min, type_max);
        }
    }
  result = convert (type, expr);

  /* If the type is a array of PACK bits and the expression is an array constructor,
     then build a CONSTRUCTOR for a bitstring.  Bitstrings are zero based, so
     decrement the value of each CONSTRUCTOR element by the amount of the lower
     bound of the array.  */
  if (TREE_CODE (type) == ARRAY_TYPE && TYPE_PACKED (type)
      && TREE_CODE (result) == CONSTRUCTOR)
    {
      tree domain_min = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
      tree new_list = NULL_TREE;
      long index;
      tree element;
      for (element = TREE_OPERAND (result, 1);
           element != NULL_TREE;
           element = TREE_CHAIN (element))
        {
          if (!tree_int_cst_equal (TREE_VALUE (element), integer_zero_node))
            {
              tree purpose = TREE_PURPOSE (element);
              switch (TREE_CODE (purpose))
                {
                case INTEGER_CST:
                  new_list = tree_cons (NULL_TREE,
                                        size_binop (MINUS_EXPR, purpose, domain_min),
                                        new_list);
                  break;
                case RANGE_EXPR:
                  for (index  = TREE_INT_CST_LOW (TREE_OPERAND (purpose, 0));
                       index <= TREE_INT_CST_LOW (TREE_OPERAND (purpose, 1));
                       index++)
                    new_list = tree_cons (NULL_TREE,
                                          size_binop (MINUS_EXPR,
                                                      build_int_2 (index, 0),
                                                      domain_min),
                                          new_list);
                  break;
                default:
                  abort ();
                }
            }
        }
      result = copy_node (result);
      TREE_OPERAND (result, 1) = nreverse (new_list);
      TREE_TYPE (result) = build_bitstring_type (TYPE_SIZE (type));
    }

  return result;
}
\f
/* Check that EXPR has valid type for a RETURN or RESULT expression,
   converting to the right type.  ACTION is "RESULT" or "RETURN". */

static tree
adjust_return_value (expr, action)
     tree expr;
     char *action;
{
  tree type = TREE_TYPE (TREE_TYPE (current_function_decl));

  if (TREE_CODE (type) == REFERENCE_TYPE)
    {
      if (CH_LOCATION_P (expr))
        {
          if (! CH_READ_COMPATIBLE (TREE_TYPE (type), 
                                    TREE_TYPE (expr)))
            {
              error ("mode mismatch in %s expression", action);
              return error_mark_node;
            }
          return convert (type, expr);
        }
      else
        {
          error ("%s expression must be referable", action);
          return error_mark_node;
        }
    }
  else if (! CH_COMPATIBLE (expr, type))
    {
      error ("mode mismatch in %s expression", action);
      return error_mark_node;
    }
  return convert (type, expr);
}
\f
void
chill_expand_result (expr, result_or_return)
     tree expr;
     int result_or_return;
{
  tree type;
  char *action_name = result_or_return ? "RESULT" : "RETURN";
  
  if (pass == 1)
    return;

  if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
    return;

  CH_FUNCTION_SETS_RESULT (current_function_decl) = 1;

  if (chill_at_module_level || global_bindings_p ())
    error ("%s not allowed outside a PROC", action_name);

  result_never_set = 0;

  if (chill_result_decl == NULL_TREE)
    {
      error ("%s action in PROC with no declared RESULTS", action_name);
      return;
    }
  type = TREE_TYPE (chill_result_decl);

  if (TREE_CODE (type) == ERROR_MARK)
    return;

  expr = adjust_return_value (expr, action_name);

  expand_expr_stmt (build_chill_modify_expr (chill_result_decl, expr));
}
\f
/*
 * error if EXPR not NULL and procedure doesn't
 * have a return type; 
 * warning if EXPR NULL,
 * procedure *has* a return type, and a previous
 * RESULT actions hasn't saved a return value.
 */
void
chill_expand_return (expr, implicit)
     tree expr;
     int implicit; /* 1 if an implicit return at end of function. */
{
  tree valtype;

  if (expr != NULL_TREE && TREE_CODE (expr) == ERROR_MARK)
    return;
  if (chill_at_module_level || global_bindings_p ())
    {
      error ("RETURN not allowed outside PROC");
      return;
    }

  if (pass == 1)
    return;

  result_never_set = 0;

  valtype = TREE_TYPE (TREE_TYPE (current_function_decl));
  if (TREE_CODE (valtype) == VOID_TYPE)
    {
      if (expr != NULL_TREE)
        error ("RETURN with a value, in PROC returning void");
      expand_null_return ();
    }
  else if (TREE_CODE (valtype) != ERROR_MARK)
    {
      if (expr == NULL_TREE)
        {
          if (!CH_FUNCTION_SETS_RESULT (current_function_decl)
              && !implicit)
            warning ("RETURN with no value and no RESULT action in procedure");
          expr = chill_result_decl;
        }
      else
        expr = adjust_return_value (expr, "RETURN");
      expr = build (MODIFY_EXPR, valtype,
                    DECL_RESULT (current_function_decl),
                    expr);
      TREE_SIDE_EFFECTS (expr) = 1;
      expand_return (expr);
    }
}

void
lookup_and_expand_goto (name)
     tree name;
{
  if (name == NULL_TREE ||  TREE_CODE (name) == ERROR_MARK)
    return;
  if (!ignoring)
    {
      tree decl = lookup_name (name);
      if (decl == NULL || TREE_CODE (decl) != LABEL_DECL)
        error ("no label named `%s'", IDENTIFIER_POINTER (name));
      else if (DECL_CONTEXT (decl) != current_function_decl)
        error ("cannot GOTO label `%s' outside current function",
               IDENTIFIER_POINTER (name));
      else
        {
          TREE_USED (decl) = 1;
          expand_goto_except_cleanup (DECL_ACTION_NESTING_LEVEL (decl));
          expand_goto (decl);
        }
    }
}

void
lookup_and_handle_exit (name)
     tree name;
{
  if (name == NULL_TREE ||  TREE_CODE (name) == ERROR_MARK)
    return;
  if (!ignoring)
    {
      tree label = munge_exit_label (name);
      tree decl = lookup_name (label);
      if (decl == NULL || TREE_CODE (decl) != LABEL_DECL)
        error ("no EXITable label named `%s'", IDENTIFIER_POINTER (name));
      else if (DECL_CONTEXT (decl) != current_function_decl)
        error ("cannot EXIT label `%s' outside current function",
               IDENTIFIER_POINTER (name));
      else
        {
          TREE_USED (decl) = 1;
          expand_goto_except_cleanup (DECL_ACTION_NESTING_LEVEL (decl));
          expand_goto (decl);
        }
    }
}
\f
/* ELSE-range handling: The else-range is a chain of trees which collectively
   represent the ranges to be tested for the (ELSE) case label. Each element in
   the chain represents a range to be tested. The boundaries of the range are
   represented by INTEGER_CST trees in the PURPOSE and VALUE fields. */

/* This function updates the else-range by removing the given integer constant. */
static tree
update_else_range_for_int_const (else_range, label)
     tree else_range, label;
{
  int  lowval, highval;
  int  label_value = TREE_INT_CST_LOW (label);
  tree this_range, prev_range, new_range;

  /* First, find the range element containing the integer, if it exists. */
  prev_range = NULL_TREE;
  for (this_range = else_range ;
       this_range != NULL_TREE;
       this_range = TREE_CHAIN (this_range))
    {
      lowval  = TREE_INT_CST_LOW (TREE_PURPOSE (this_range));
      highval = TREE_INT_CST_LOW (TREE_VALUE (this_range));
      if (label_value >= lowval && label_value <= highval)
        break;
      prev_range = this_range;
    }

  /* If a range element containing the integer was found, then update the range. */
  if (this_range != NULL_TREE)
    {
      tree next = TREE_CHAIN (this_range);
      if (label_value == lowval)
        {
          /* The integer is the lower bound of the range element. If it is also the
             upper bound, then remove this range element, otherwise update it. */
          if (label_value == highval)
            {
              if (prev_range == NULL_TREE)
                else_range = next;
              else
                TREE_CHAIN (prev_range) = next;
            }
          else
            TREE_PURPOSE (this_range) = build_int_2 (label_value + 1, 0);
        }
      else if (label_value == highval)
        {
          /* The integer is the upper bound of the range element, so ajust it. */
          TREE_VALUE (this_range) = build_int_2 (label_value - 1, 0);
        }
      else
        {
          /* The integer is in the middle of the range element, so split it. */
          new_range = tree_cons (
            build_int_2 (label_value + 1, 0), TREE_VALUE (this_range), next);
          TREE_VALUE (this_range) = build_int_2 (label_value - 1, 0);
          TREE_CHAIN (this_range) = new_range;
        }
    }
  return else_range;
}

/* Update the else-range to remove a range of values/ */
static tree
update_else_range_for_range (else_range, low_target, high_target)
     tree else_range, low_target, high_target;
{
  tree this_range, prev_range, new_range, next_range;
  int  low_range_val, high_range_val;
  int  low_target_val  = TREE_INT_CST_LOW (low_target);
  int  high_target_val = TREE_INT_CST_LOW (high_target);

  /* find the first else-range element which overlaps the target range. */
  prev_range = NULL_TREE;
  for (this_range = else_range ;
       this_range != NULL_TREE;
       this_range = TREE_CHAIN (this_range))
    {
      low_range_val  = TREE_INT_CST_LOW (TREE_PURPOSE (this_range));
      high_range_val = TREE_INT_CST_LOW (TREE_VALUE (this_range));
      if ((low_target_val >= low_range_val && low_target_val <= high_range_val)
          || (high_target_val >= low_range_val && high_target_val <= high_range_val))
        break;
      prev_range = this_range;
    }
  if (this_range == NULL_TREE)
    return else_range;

  /* This first else-range element might be truncated at the top or completely
     contain the target range. */
  if (low_range_val < low_target_val)
    {
      next_range = TREE_CHAIN (this_range);
      if (high_range_val > high_target_val)
        {
          new_range = tree_cons (
            build_int_2 (high_target_val + 1, 0), TREE_VALUE (this_range), next_range);
          TREE_VALUE (this_range) = build_int_2 (low_target_val - 1, 0);
          TREE_CHAIN (this_range) = new_range;
          return else_range;
        }

      TREE_VALUE (this_range) = build_int_2 (low_target_val - 1, 0);
      if (next_range == NULL_TREE)
        return else_range;

      prev_range = this_range;
      this_range = next_range;
      high_range_val = TREE_INT_CST_LOW (TREE_VALUE (this_range));
    }

  /* There may then follow zero or more else-range elements which are completely
     contained in the target range. */
  while (high_range_val <= high_target_val)
    {
      this_range = TREE_CHAIN (this_range);
      if (prev_range == NULL_TREE)
        else_range = this_range;
      else
        TREE_CHAIN (prev_range) = this_range;

      if (this_range == NULL_TREE)
        return else_range;
      high_range_val = TREE_INT_CST_LOW (TREE_VALUE (this_range));
    }

  /* Finally, there may be a else-range element which is truncated at the bottom. */
  low_range_val = TREE_INT_CST_LOW (TREE_PURPOSE (this_range));
  if (low_range_val <= high_target_val)
    TREE_PURPOSE (this_range) = build_int_2 (high_target_val + 1, 0);

  return else_range;
}

static tree
update_else_range_for_range_expr (else_range, label)
     tree else_range, label;
{
  if (TREE_OPERAND (label, 0) == NULL_TREE)
    {
      if (TREE_OPERAND (label, 1) == NULL_TREE)
        else_range = NULL_TREE; /* (*) -- matches everything */
    }
  else
    else_range = update_else_range_for_range (
      else_range, TREE_OPERAND (label, 0), TREE_OPERAND (label, 1));

  return else_range;
}

static tree
update_else_range_for_type (else_range, label)
     tree else_range, label;
{
  tree type = TREE_TYPE (label);
  else_range = update_else_range_for_range (
    else_range, TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type));
  return else_range;
}

static tree
compute_else_range (selector, alternatives, selector_no)
     tree selector, alternatives;
     int selector_no;
{
  /* Start with an else-range that spans the entire range of the selector type. */
  tree type = TREE_TYPE (TREE_VALUE (selector));
  tree range = tree_cons (TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type), NULL_TREE);

  /* Now remove the values represented by each case lebel specified for that
     selector. The remaining range is the else-range. */
  for ( ; alternatives != NULL_TREE; alternatives = TREE_CHAIN (alternatives))
    {
      tree label;
      tree label_list = TREE_PURPOSE (alternatives);
      int  this_selector;
      for (this_selector = 0; this_selector < selector_no ; ++this_selector)
        label_list = TREE_CHAIN (label_list);

      for (label = TREE_VALUE (label_list);
           label != NULL_TREE;
           label = TREE_CHAIN (label))
        {
          tree label_value = TREE_VALUE (label);
          if (TREE_CODE (label_value) == INTEGER_CST)
            range = update_else_range_for_int_const (range, label_value);
          else if (TREE_CODE (label_value) == RANGE_EXPR)
            range = update_else_range_for_range_expr (range, label_value);
          else if (TREE_CODE (label_value) == TYPE_DECL)
            range = update_else_range_for_type (range, label_value);

          if (range == NULL_TREE)
            break;
        }
    }

  return range;
}

void
compute_else_ranges (selectors, alternatives)
     tree selectors, alternatives;
{
  tree selector;
  int selector_no = 0;

  for (selector = selectors; selector != NULL_TREE; selector = TREE_CHAIN (selector))
    {
      if (ELSE_LABEL_SPECIFIED (selector))
        TREE_PURPOSE (selector) =
          compute_else_range (selector, alternatives, selector_no);
      selector_no++;
    }
}

static tree
check_case_value (label_value, selector)
     tree label_value, selector;
{
  if (TREE_CODE (label_value) == ERROR_MARK)
    return label_value;
  if (TREE_CODE (selector) == ERROR_MARK)
    return selector;    

  /* Z.200 (6.4 Case action) says:  "The class of any discrete expression
     in the case selector list must be compatible with the corresponding
     (by position) class of the resulting list of classes of the case label
     list occurrences ...".  We don't actually construct the resulting
     list of classes, but this test should be more-or-less equivalent.
     I think... */
  if (!CH_COMPATIBLE_CLASSES (selector, label_value))
    {
      error ("case selector not compatible with label");
      return error_mark_node;
    }

  /* Strip NON_LVALUE_EXPRs since we aren't using as an lvalue.  */
  STRIP_TYPE_NOPS (label_value);

  if (TREE_CODE (label_value) != INTEGER_CST)
    {
      error ("case label does not reduce to an integer constant");
      return error_mark_node;
    }

  constant_expression_warning (label_value);
  return label_value;
}

void
chill_handle_case_default ()
{
  tree duplicate;
  register tree label = build_decl (LABEL_DECL, NULL_TREE, 
                                    NULL_TREE);
  int success = pushcase (NULL_TREE, 0, label, &duplicate);

  if (success == 1)
    error ("ELSE label not within a CASE statement");
#if 0
  else if (success == 2)
    {
      error ("multiple default labels found in a CASE statement"); 
      error_with_decl (duplicate, "this is the first ELSE label");
    }
#endif
}
\f
/* Handle cases label such as (I:J):  or (modename): */

static void
chill_handle_case_label_range (min_value, max_value, selector)
     tree min_value, max_value, selector;
{
  register tree label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
  min_value = check_case_value (min_value, selector);
  max_value = check_case_value (max_value, selector);
  if (TREE_CODE (min_value) != ERROR_MARK
      && TREE_CODE (max_value) != ERROR_MARK)
    {
      tree duplicate;
      int success = pushcase_range (min_value, max_value,
                                    convert, label, &duplicate);
      if (success == 1)
        error ("label found outside of CASE statement");
      else if (success == 2)
        {
          error ("duplicate CASE value");
          error_with_decl (duplicate, "this is the first entry for that value");
        }
      else if (success == 3)
        error ("CASE value out of range");
      else if (success == 4)
        error ("empty range");
      else if (success == 5)
        error ("label within scope of cleanup or variable array");
    }
}

void
chill_handle_case_label (label_value, selector)
     tree label_value, selector;
{
  if (label_value == NULL_TREE 
      || TREE_CODE (label_value) == ERROR_MARK)
    return;
  if (TREE_CODE (label_value) == RANGE_EXPR)
    {
      if (TREE_OPERAND (label_value, 0) == NULL_TREE)
        chill_handle_case_default ();  /* i.e. (ELSE): or (*): */
      else
        chill_handle_case_label_range (TREE_OPERAND (label_value, 0),
                                       TREE_OPERAND (label_value, 1),
                                       selector);
    }
  else if (TREE_CODE (label_value) == TYPE_DECL)
    {
      tree type = TREE_TYPE (label_value);
      if (! discrete_type_p (type))
        error ("mode in label is not discrete");
      else
        chill_handle_case_label_range (TYPE_MIN_VALUE (type),
                                       TYPE_MAX_VALUE (type),
                                       selector);
    }
  else
    {
      register tree label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);

      label_value = check_case_value (label_value, selector);

      if (TREE_CODE (label_value) != ERROR_MARK)
        {
          tree duplicate;
          int success = pushcase (label_value, convert, label, &duplicate);
          if (success == 1)
            error ("label not within a CASE statement");
          else if (success == 2)
            {
              error ("duplicate case value");
              error_with_decl (duplicate, 
                               "this is the first entry for that value");
            }
          else if (success == 3)
            error ("CASE value out of range");
          else if (success == 4)
            error ("empty range");
          else if (success == 5)
            error ("label within scope of cleanup or variable array");
        }
    }
}

int
chill_handle_single_dimension_case_label (
  selector, label_spec, expand_exit_needed, caseaction_flag
)
  tree selector, label_spec;
  int *expand_exit_needed, *caseaction_flag;
{
  tree labels, one_label;
  int  no_completeness_check = 0;

  if (*expand_exit_needed || *caseaction_flag == 1)
    {
      expand_exit_something ();
      *expand_exit_needed = 0;
    }

  for (labels = label_spec; labels != NULL_TREE; labels = TREE_CHAIN (labels))
    for (one_label = TREE_VALUE (labels); one_label != NULL_TREE;
         one_label = TREE_CHAIN (one_label))
      {
        if (TREE_VALUE (one_label) == case_else_node)
          no_completeness_check = 1;

        chill_handle_case_label (TREE_VALUE (one_label), selector);
      }

  *caseaction_flag = 1;

  return no_completeness_check;
}

static tree
chill_handle_multi_case_label_range (low, high, selector)
  tree low, high, selector;
{
  tree low_expr, high_expr, and_expr;
  tree selector_type;
  int  low_target_val, high_target_val;
  int  low_type_val, high_type_val;

  /* we can eliminate some tests is the low and/or high value in the given range
     are outside the range of the selector type. */
  low_target_val  = TREE_INT_CST_LOW (low);
  high_target_val = TREE_INT_CST_LOW (high);
  selector_type   = TREE_TYPE (selector);
  low_type_val    = TREE_INT_CST_LOW (TYPE_MIN_VALUE (selector_type));
  high_type_val   = TREE_INT_CST_LOW (TYPE_MAX_VALUE (selector_type));

  if (low_target_val > high_type_val || high_target_val < low_type_val)
    return boolean_false_node; /* selector never in range */

  if (low_type_val >= low_target_val)
    {
      if (high_type_val <= high_target_val)
        return boolean_true_node; /* always in the range */
      return build_compare_expr (LE_EXPR, selector, high);
    }

  if (high_type_val <= high_target_val)
    return build_compare_expr (GE_EXPR, selector, low);

  /* The target range in completely within the range of the selector, but we
     might be able to save a test if the upper bound is the same as the lower
     bound. */
  if (low_target_val == high_target_val)
    return build_compare_expr (EQ_EXPR, selector, low);

  /* No optimizations possible. Just generate tests against the upper and lower
     bound of the target */
  low_expr  = build_compare_expr (GE_EXPR, selector, low);
  high_expr = build_compare_expr (LE_EXPR, selector, high);
  and_expr  = build_chill_binary_op (TRUTH_ANDIF_EXPR, low_expr, high_expr);

  return and_expr;
}

static tree
chill_handle_multi_case_else_label (selector)
     tree selector;
{
  tree else_range, selector_value, selector_type;
  tree low, high, larg;

  else_range = TREE_PURPOSE (selector);
  if (else_range == NULL_TREE)
    return boolean_false_node; /* no values in ELSE range */

  /* Test each of the ranges in the else-range chain */
  selector_value = TREE_VALUE (selector);
  selector_type  = TREE_TYPE (selector_value);
  low  = convert (selector_type, TREE_PURPOSE (else_range));
  high = convert (selector_type, TREE_VALUE (else_range));
  larg = chill_handle_multi_case_label_range (low, high, selector_value);

  for (else_range = TREE_CHAIN (else_range);
       else_range != NULL_TREE;
       else_range = TREE_CHAIN (else_range))
    {
      tree rarg;
      low  = convert (selector_type, TREE_PURPOSE (else_range));
      high = convert (selector_type, TREE_VALUE (else_range));
      rarg = chill_handle_multi_case_label_range (low, high, selector_value);
      larg = build_chill_binary_op (TRUTH_ORIF_EXPR, larg, rarg);
    }

  return larg;
}

static tree
chill_handle_multi_case_label (selector, label)
  tree selector, label;
{
  tree expr;

  if (label == NULL_TREE || TREE_CODE (label) == ERROR_MARK)
    return NULL_TREE;

  if (TREE_CODE (label) == INTEGER_CST)
    {
      int  target_val = TREE_INT_CST_LOW (label);
      tree selector_type = TREE_TYPE (TREE_VALUE (selector));
      int  low_type_val  = TREE_INT_CST_LOW (TYPE_MIN_VALUE (selector_type));
      int  high_type_val = TREE_INT_CST_LOW (TYPE_MAX_VALUE (selector_type));
      if (target_val < low_type_val || target_val > high_type_val)
        expr = boolean_false_node;
      else
        expr = build_compare_expr (EQ_EXPR, TREE_VALUE (selector), label);
    }
  else if (TREE_CODE (label) == RANGE_EXPR)
    {
      if (TREE_OPERAND (label, 0) == NULL_TREE)
        {
          if (TREE_OPERAND (label, 1) == NULL_TREE)
            expr = boolean_true_node; /* (*) -- matches everything */
          else
            expr = chill_handle_multi_case_else_label (selector);
        }
      else
        {
          tree low = TREE_OPERAND (label, 0);
          tree high = TREE_OPERAND (label, 1);
          if (TREE_CODE (low) != INTEGER_CST)
            {
              error ("Lower bound of range must be a discrete literal expression");
              expr = error_mark_node;
            }
          if (TREE_CODE (high) != INTEGER_CST)
            {
              error ("Upper bound of range must be a discrete literal expression");
              expr = error_mark_node;
            }
          if (expr != error_mark_node)
            {
              expr = chill_handle_multi_case_label_range (
                       low, high, TREE_VALUE (selector));
            }
        }
    }
  else if (TREE_CODE (label) == TYPE_DECL)
    {
      tree type = TREE_TYPE (label);
      if (! discrete_type_p (type))
        {
          error ("mode in label is not discrete");
          expr = error_mark_node;
        }
      else
        expr = chill_handle_multi_case_label_range (
                 TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type), TREE_VALUE (selector));
    }
  else
    {
      error ("The CASE label is not valid");
      expr = error_mark_node;
    }

  return expr;
}

static tree
chill_handle_multi_case_label_list (selector, labels)
  tree selector, labels;
{
  tree one_label, larg, rarg;

  one_label = TREE_VALUE (labels);
  larg = chill_handle_multi_case_label (selector, TREE_VALUE (one_label));

  for (one_label = TREE_CHAIN (one_label);
       one_label != NULL_TREE;
       one_label = TREE_CHAIN (one_label))
    {
      rarg = chill_handle_multi_case_label (selector, TREE_VALUE (one_label));
      larg = build_chill_binary_op (TRUTH_ORIF_EXPR, larg, rarg);
    }

  return larg;
}

tree
build_multi_case_selector_expression (selector_list, label_spec)
  tree selector_list, label_spec;
{
  tree labels, selector, larg, rarg;

  labels   = label_spec;
  selector = selector_list;
  larg = chill_handle_multi_case_label_list(selector, labels);

  for (labels = TREE_CHAIN (labels), selector = TREE_CHAIN (selector);
       labels != NULL_TREE && selector != NULL_TREE;
       labels = TREE_CHAIN (labels), selector = TREE_CHAIN (selector))
    {
      rarg = chill_handle_multi_case_label_list(selector, labels);
      larg = build_chill_binary_op (TRUTH_ANDIF_EXPR, larg, rarg);
    }

  if (labels != NULL_TREE || selector != NULL_TREE)
    error ("The number of CASE selectors does not match the number of CASE label lists");

  return larg;
}

#define BITARRAY_TEST(ARRAY, INDEX) \
  ((ARRAY)[(unsigned)(INDEX) / HOST_BITS_PER_CHAR]\
                          & (1 << ((unsigned)(INDEX) % HOST_BITS_PER_CHAR)))
#define BITARRAY_SET(ARRAY, INDEX) \
  ((ARRAY)[(unsigned)(INDEX) / HOST_BITS_PER_CHAR]\
                          |= 1 << ((unsigned)(INDEX) % HOST_BITS_PER_CHAR))

/* CASES_SEEN is a set (bitarray) of length COUNT.
   For each element that is zero, print an error message,
   assume the element have the given TYPE. */

static void
print_missing_cases (type, cases_seen, count)
     tree type;
     unsigned char *cases_seen;
     long count;
{
  long i;
  for (i = 0;  i < count; i++)
    {
      if (BITARRAY_TEST(cases_seen, i) == 0)
        {
          char buf[20];
          long x = i;
          long j;
          tree t = type;
          char *err_val_name = "???";
          if (TYPE_MIN_VALUE (t)
              && TREE_CODE (TYPE_MIN_VALUE (t)) == INTEGER_CST)
            x += TREE_INT_CST_LOW (TYPE_MIN_VALUE (t));
          while (TREE_TYPE (t) != NULL_TREE)
            t = TREE_TYPE (t);
          switch (TREE_CODE (t))
            {
              tree v;
            case BOOLEAN_TYPE:
              err_val_name = x ? "TRUE" : "FALSE";
              break;
            case CHAR_TYPE:
              if ((x >= ' ' && x < 127) && x != '\'' && x != '^')
                sprintf (buf, "'%c'", (char)x);
              else
                sprintf (buf, "'^(%ld)'", x);
              err_val_name = buf;
              j = i;
              while (j < count && !BITARRAY_TEST(cases_seen, j))
                j++;
              if (j > i + 1)
                {
                  long y = x+j-i-1;
                  err_val_name += strlen (err_val_name);
                  if ((y >= ' ' && y < 127) && y != '\'' && y != '^')
                    sprintf (err_val_name, "%s:'%c'", buf, (char)y);
                  else
                    sprintf (err_val_name, "%s:'^(%ld)'", buf, y);
                  i = j - 1;      
                }
              break;
            case ENUMERAL_TYPE:
              for (v = TYPE_VALUES (t);  v && x;  v = TREE_CHAIN (v))
                x--;
              if (v)
                err_val_name = IDENTIFIER_POINTER (TREE_PURPOSE (v));
              break;
            default:
              j = i;
              while (j < count && !BITARRAY_TEST(cases_seen, j))
                j++;
              if (j == i + 1)
                sprintf (buf, "%ld", x);
              else
                sprintf (buf, "%ld:%ld", x, x+j-i-1);
              i = j - 1;      
              err_val_name = buf;
              break;
            }
          error ("incomplete CASE - %s not handled", err_val_name);
        }
    }
}

void
check_missing_cases (type)
     tree type;
{
  int is_sparse;
  /* For each possible selector value. a one iff it has been matched
     by a case value alternative. */
  unsigned char *cases_seen;
  /* The number of possible selector values. */
  HOST_WIDE_INT size = all_cases_count (type, &is_sparse);
  long bytes_needed = (size+HOST_BITS_PER_CHAR)/HOST_BITS_PER_CHAR;

  if (size == -1)
    warning ("CASE selector with variable range");
  else if (size < 0 || size > 600000
           /* We deliberately use malloc here - not xmalloc. */
           || (cases_seen = (char*) malloc (bytes_needed)) == NULL)
    warning ("too many cases to do CASE completeness testing");
  else
    {
      bzero (cases_seen, bytes_needed);
      mark_seen_cases (type, cases_seen, size, is_sparse);
      print_missing_cases (type, cases_seen, size);
      free (cases_seen);
    }
}

/*
 * We build an expression tree here because, in many contexts,
 * we don't know the type of result that's desired.  By the
 * time we get to expanding the tree, we do know.
 */
tree
build_chill_case_expr (exprlist, casealtlist_expr,
                       optelsecase_expr)
     tree exprlist, casealtlist_expr, optelsecase_expr;
{
  return build (CASE_EXPR, NULL_TREE, exprlist,
                optelsecase_expr ?
                  tree_cons (NULL_TREE,
                             optelsecase_expr,
                             casealtlist_expr) :
                  casealtlist_expr);
}

/* This function transforms the selector_list and alternatives into a COND_EXPR. */
tree
build_chill_multi_dimension_case_expr (selector_list, alternatives, else_expr)
  tree selector_list, alternatives, else_expr;
{
  tree expr;

  selector_list = check_case_selector_list (selector_list);

  if (alternatives == NULL_TREE)
    return NULL_TREE;

  alternatives = nreverse (alternatives);
  /* alternatives represents the CASE label specifications and resulting values in
     the reverse order in which they appeared.
     If there is an ELSE expression, then use it. If there is no
     ELSE expression, make the last alternative (which is the first in the list)
     into the ELSE expression. This is safe because, if the CASE is complete
     (as required), then the last condition need not be checked anyway. */
  if (else_expr != NULL_TREE)
    expr = else_expr;
  else
    {
      expr = TREE_VALUE (alternatives);
      alternatives = TREE_CHAIN (alternatives);
    }

  for ( ; alternatives != NULL_TREE; alternatives = TREE_CHAIN (alternatives))
    { 
      tree value  = TREE_VALUE (alternatives);
      tree labels = TREE_PURPOSE (alternatives);
      tree cond   = build_multi_case_selector_expression(selector_list, labels);
      expr = build_nt (COND_EXPR, cond, value, expr);
    }

  return expr;
}

\f
/* This is called with the assumption that RHS has been stabilized.  
   It has one purpose:  to iterate through the CHILL list of LHS's */
void
expand_assignment_action (loclist, modifycode, rhs)
     tree loclist;
     enum chill_tree_code modifycode;
     tree rhs;
{
  if (loclist == NULL_TREE || TREE_CODE (loclist) == ERROR_MARK
      || rhs == NULL_TREE  || TREE_CODE (rhs) == ERROR_MARK)
    return;

  if (TREE_CHAIN (loclist) != NULL_TREE)
    { /* Multiple assignment */
      tree target;
      if (TREE_TYPE (rhs) != NULL_TREE)
        rhs = save_expr (rhs);
      else if (TREE_CODE (rhs) == CONSTRUCTOR)
        error ("type of tuple cannot be implicit in multiple assignent");
      else if (TREE_CODE (rhs) == CASE_EXPR || TREE_CODE (rhs) == COND_EXPR)
        error ("conditional expression cannot be used in multiple assignent");
      else
        error ("internal error - unknown type in multiple assignment");

      if (modifycode != NOP_EXPR)
        {
          error ("no operator allowed in multiple assignment,");
          modifycode = NOP_EXPR;
        }

      for (target = TREE_CHAIN (loclist); target; target = TREE_CHAIN (target))
        {
          if (!CH_EQUIVALENT (TREE_TYPE (TREE_VALUE (target)),
                              TREE_TYPE (TREE_VALUE (loclist))))
            {
              error
                ("location modes in multiple assignment are not equivalent");
              break;
            }
        }
    }
  for ( ; loclist != NULL_TREE; loclist = TREE_CHAIN (loclist))
    chill_expand_assignment (TREE_VALUE (loclist), modifycode, rhs);
}

void
chill_expand_assignment (lhs, modifycode, rhs)
     tree lhs;
     enum chill_tree_code modifycode;
     tree rhs;
{
  tree loc;

  while (TREE_CODE (lhs) == COMPOUND_EXPR)
    {
      expand_expr (TREE_OPERAND (lhs, 0), const0_rtx, VOIDmode, 0);
      emit_queue ();
      lhs = TREE_OPERAND (lhs, 1);
    }

  if (TREE_CODE (lhs) == ERROR_MARK)
    return;

  /* errors for assignment to BUFFER, EVENT locations.
     what about SIGNALs? FIXME: Need similar test in
     build_chill_function_call. */
  if (TREE_CODE (lhs) == IDENTIFIER_NODE)
    {
      tree decl = lookup_name (lhs);
      if (decl)
        {
          tree type = TREE_TYPE (decl);
          if (CH_IS_BUFFER_MODE (type) || CH_IS_EVENT_MODE (type))
            {
              error ("You may not assign a value to a BUFFER or EVENT location");
              return;
            }
        }
    }

  if (TYPE_READONLY_PROPERTY (TREE_TYPE (lhs)) || TREE_READONLY (lhs))
    {
      error ("can't assign value to READonly location");
      return;
    }
  if (CH_TYPE_NONVALUE_P (TREE_TYPE (lhs)))
    {
      error ("cannot assign to location with non-value property");
      return;
    }

  if (TREE_CODE (TREE_TYPE (lhs)) == REFERENCE_TYPE)
    lhs = convert_from_reference (lhs);

  /* check for lhs is a location */
  loc = lhs;
  while (1)
    {
      if (TREE_CODE (loc) == SLICE_EXPR)
        loc = TREE_OPERAND (loc, 0);
      else if (TREE_CODE (loc) == SET_IN_EXPR)
        loc = TREE_OPERAND (loc, 1);
      else
        break;
    }
  if (! CH_LOCATION_P (loc))
    {
      error ("lefthand side of assignment is not a location");
      return;
    }

  /* If a binary op has been requested, combine the old LHS value with
     the RHS producing the value we should actually store into the LHS. */

  if (modifycode != NOP_EXPR)
    {
      lhs = stabilize_reference (lhs);
      /* This is to handle border-line cases such
         as: LHS OR := [I].  This seems to be permitted
         by the letter of Z.200, though it violates
         its spirit, since LHS:=LHS OR [I] is
         *not* legal. */
      if (TREE_TYPE (rhs) == NULL_TREE)
        rhs = convert (TREE_TYPE (lhs), rhs);
      rhs = build_chill_binary_op (modifycode, lhs, rhs);
    }

  rhs = chill_convert_for_assignment (TREE_TYPE (lhs), rhs, "assignment");

  /* handle the LENGTH (vary_array) := expr action */
  loc = lhs;
  if (TREE_CODE (loc) == NOP_EXPR)
    loc = TREE_OPERAND (loc, 0);
  if (TREE_CODE (loc) == COMPONENT_REF
      && chill_varying_type_p (TREE_TYPE (TREE_OPERAND (loc, 0)))
      && DECL_NAME (TREE_OPERAND (loc, 1)) == var_length_id)
    {
      expand_varying_length_assignment (TREE_OPERAND (loc, 0), rhs);
    }
  else if (TREE_CODE (lhs) == SLICE_EXPR)
    {
      tree func = lookup_name (get_identifier ("__pscpy"));
      tree dst = TREE_OPERAND (lhs, 0);
      tree dst_offset = TREE_OPERAND (lhs, 1);
      tree length = TREE_OPERAND (lhs, 2);
      tree src, src_offset;
      if (TREE_CODE (rhs) == SLICE_EXPR)
        {
          src = TREE_OPERAND (rhs, 0);
          /* Should check that the TREE_OPERAND (src, 0) is
             the same as length and powerserlen (src).  FIXME */
          src_offset = TREE_OPERAND (rhs, 1);
        }
      else
        {
          src = rhs;
          src_offset = integer_zero_node;
        }
      expand_expr_stmt (build_chill_function_call (func,
        tree_cons (NULL_TREE, force_addr_of (dst),
          tree_cons (NULL_TREE, powersetlen (dst),
            tree_cons (NULL_TREE, convert (long_unsigned_type_node, dst_offset),
              tree_cons (NULL_TREE, force_addr_of (src),
                tree_cons (NULL_TREE, powersetlen (src),
                  tree_cons (NULL_TREE, convert (long_unsigned_type_node, src_offset),
                    tree_cons (NULL_TREE, convert (long_unsigned_type_node, length),
                       NULL_TREE)))))))));
    }

  else if (TREE_CODE (lhs) == SET_IN_EXPR)
    {
      tree from_pos = save_expr (TREE_OPERAND (lhs, 0));
      tree set = TREE_OPERAND (lhs, 1);
      tree domain = TYPE_DOMAIN (TREE_TYPE (set));
      tree set_length = size_binop (PLUS_EXPR,
                                    size_binop (MINUS_EXPR,
                                                TYPE_MAX_VALUE (domain),
                                                TYPE_MIN_VALUE (domain)),
                                    integer_one_node);
      tree filename = force_addr_of (get_chill_filename());
      
      if (TREE_CODE (TREE_TYPE (lhs)) != BOOLEAN_TYPE)
        sorry("bitstring slice");
      expand_expr_stmt (
        build_chill_function_call (lookup_name (
          get_identifier ("__setbitpowerset")),
              tree_cons (NULL_TREE, build_chill_addr_expr (set, "powerset"),
                  tree_cons (NULL_TREE, set_length,
                    tree_cons (NULL_TREE, TYPE_MIN_VALUE (domain),
                      tree_cons (NULL_TREE, convert (long_integer_type_node, from_pos),
                        tree_cons (NULL_TREE, rhs,
                          tree_cons (NULL_TREE, filename,
                            tree_cons (NULL_TREE, get_chill_linenumber(),
                              NULL_TREE)))))))));
    }

  /* Handle arrays of packed bitfields. Currently, this is limited to bitfields
     which are 1 bit wide, so use the powerset runtime function. */
  else if (TREE_CODE (lhs) == PACKED_ARRAY_REF)
    {
      tree from_pos = save_expr (TREE_OPERAND (lhs, 1));
      tree array = TREE_OPERAND (lhs, 0);
      tree domain = TYPE_DOMAIN (TREE_TYPE (array));
      tree array_length = size_binop (PLUS_EXPR,
                                    size_binop (MINUS_EXPR,
                                                TYPE_MAX_VALUE (domain),
                                                TYPE_MIN_VALUE (domain)),
                                    integer_one_node);
      tree filename = force_addr_of (get_chill_filename());
      expand_expr_stmt (
        build_chill_function_call (lookup_name (
          get_identifier ("__setbitpowerset")),
            tree_cons (NULL_TREE, build_chill_addr_expr (array, "packed bitfield array"),
                tree_cons (NULL_TREE, convert (long_unsigned_type_node, array_length),
                  tree_cons (NULL_TREE, convert (long_integer_type_node,
                                                 TYPE_MIN_VALUE (domain)),
                    tree_cons (NULL_TREE, convert (long_integer_type_node, from_pos),
                      tree_cons (NULL_TREE, build1 (CONVERT_EXPR, boolean_type_node, rhs),
                        tree_cons (NULL_TREE, filename,
                          tree_cons (NULL_TREE, get_chill_linenumber(),
                            NULL_TREE)))))))));
    }

  /* The following is probably superceded by the
     above code for SET_IN_EXPR. FIXME! */
  else if (TREE_CODE (lhs) == BIT_FIELD_REF)
    {
      tree set = TREE_OPERAND (lhs, 0);
      tree numbits = TREE_OPERAND (lhs, 1);
      tree from_pos = save_expr (TREE_OPERAND (lhs, 2));
      tree domain = TYPE_DOMAIN (TREE_TYPE (set));
      tree set_length = size_binop (PLUS_EXPR,
                                    size_binop (MINUS_EXPR,
                                                TYPE_MAX_VALUE (domain),
                                                TYPE_MIN_VALUE (domain)),
                                    integer_one_node);
      tree filename = force_addr_of (get_chill_filename());
      tree to_pos;
      switch (TREE_CODE (TREE_TYPE (rhs)))
        {
        case SET_TYPE:
          to_pos = size_binop (MINUS_EXPR,
                               size_binop (PLUS_EXPR, from_pos, numbits),
                               integer_one_node);
          break;
        case BOOLEAN_TYPE:
          to_pos = from_pos;
          break;
        default:
          abort ();
        }
      
      if (TREE_CODE (TREE_TYPE (lhs)) != BOOLEAN_TYPE)
        sorry("bitstring slice");
      expand_expr_stmt (
          build_chill_function_call( lookup_name (
              get_identifier ("__setbitpowerset")),
                tree_cons (NULL_TREE, build_chill_addr_expr (set, "powerset"),
                  tree_cons (NULL_TREE, set_length,
                    tree_cons (NULL_TREE, TYPE_MIN_VALUE (domain),
                      tree_cons (NULL_TREE, from_pos,
                        tree_cons (NULL_TREE, rhs,
                          tree_cons (NULL_TREE, filename,
                            tree_cons (NULL_TREE, get_chill_linenumber(),
                              NULL_TREE)))))))));
    }

  else
    expand_expr_stmt (build_chill_modify_expr (lhs, rhs));
}
\f
/* Also assumes that rhs has been stabilized */
void
expand_varying_length_assignment (lhs, rhs)
     tree lhs, rhs;
{
  tree base_array, min_domain_val;

  pedwarn ("LENGTH on left-hand-side is non-portable");
      
  if (! CH_LOCATION_P (lhs))
    {
      error ("Can only set LENGTH of array location");
      return;
    }

  /* cause a RANGE exception if rhs would cause a 'hole' in the array. */
  rhs = valid_array_index_p (lhs, rhs, "new array length too large", 1);

  base_array     = CH_VARYING_ARRAY_TYPE (TREE_TYPE (lhs));
  min_domain_val = TYPE_MIN_VALUE (TYPE_DOMAIN (base_array));

  lhs = build_component_ref (lhs, var_length_id);
  rhs = size_binop (MINUS_EXPR, rhs, min_domain_val);

  expand_expr_stmt (build_chill_modify_expr (lhs, rhs));
}
\f
void
push_action ()
{
  push_handler ();
  if (ignoring)
    return;
  emit_line_note (input_filename, lineno);
}