convert.c

gcc-2.95.3 Linux下最常用的C编译器

/* Language-level data type conversion for GNU CHILL.
   Copyright (C) 1992, 93, 1994, 1998 Free Software Foundation, Inc.

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.  */


/* This file contains the functions for converting CHILL expressions
   to different data types.  The only entry point is `convert'.
   Every language front end must have a `convert' function
   but what kind of conversions it does will depend on the language.  */

#include "config.h"
#include "system.h"
#include "tree.h"
#include "ch-tree.h"
#include "flags.h"
#include "convert.h"
#include "lex.h"
#include "toplev.h"

extern tree bit_one_node, bit_zero_node;
extern tree string_one_type_node;
extern tree bitstring_one_type_node;

static tree
convert_to_reference (reftype, expr)
     tree reftype, expr;
{
  while (TREE_CODE (expr) == NOP_EXPR)  /* RETYPE_EXPR */
    expr = TREE_OPERAND (expr, 0);

  if (! CH_LOCATION_P (expr))
    error("internal error: trying to make loc-identity with non-location");
  else
    {
      mark_addressable (expr);
      return fold (build1 (ADDR_EXPR, reftype, expr));
    }

  return error_mark_node;
}

tree
convert_from_reference (expr)
     tree expr;
{
  tree e = build1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (expr)), expr);
  TREE_READONLY (e) = TREE_READONLY (expr);
  return e;
}

/* Convert EXPR to a boolean type.  */

static tree
convert_to_boolean (type, expr)
     tree type, expr;
{
  register tree intype = TREE_TYPE (expr);
  
  if (integer_zerop (expr))
    return boolean_false_node;
  if (integer_onep (expr))
    return boolean_true_node;

  /* Convert a singleton bitstring to a Boolean.
     Needed if flag_old_strings. */
  if (CH_BOOLS_ONE_P (intype))
    {
      if (TREE_CODE (expr) == CONSTRUCTOR)
	{
	  tree valuelist = TREE_OPERAND (expr, 1);
	  if (valuelist == NULL_TREE)
	    return boolean_false_node;
	  if (TREE_CHAIN (valuelist) == NULL_TREE
	      && TREE_PURPOSE (valuelist) == NULL_TREE
	      && integer_zerop (TREE_VALUE (valuelist)))
	    return boolean_true_node;
	}
      return build_chill_bitref (expr,
				 build_tree_list (NULL_TREE,
						  integer_zero_node));
    }

  if (INTEGRAL_TYPE_P (intype))
    return build1 (CONVERT_EXPR, type, expr);

  error ("cannot convert to a boolean mode");
  return boolean_false_node;
}

/* Convert EXPR to a char type.  */

static tree
convert_to_char (type, expr)
     tree type, expr;
{
  register tree intype = TREE_TYPE (expr);
  register enum chill_tree_code form = TREE_CODE (intype);
  
  if (form == CHAR_TYPE)
    return build1 (NOP_EXPR, type, expr);

  /* Convert a singleton string to a char.
     Needed if flag_old_strings. */
  if (CH_CHARS_ONE_P (intype))
    {
      if (TREE_CODE (expr) == STRING_CST)
	{
	  expr = build_int_2 ((unsigned char)TREE_STRING_POINTER(expr)[0], 0);
	  TREE_TYPE (expr) = char_type_node;
	  return expr;
	}
      else
	return build (ARRAY_REF, char_type_node, expr, integer_zero_node);

    }

  /* For now, assume it will always fit */
  if (form == INTEGER_TYPE)
    return build1 (CONVERT_EXPR, type, expr);

  error ("cannot convert to a char mode");

  {
    register tree tem = build_int_2 (0, 0);
    TREE_TYPE (tem) = type;
    return tem;
  }
}

tree
base_type_size_in_bytes (type)
     tree type;
{
  if (type == NULL_TREE
      || TREE_CODE (type) == ERROR_MARK
      || TREE_CODE (type) != ARRAY_TYPE)
    return error_mark_node;
  return size_in_bytes (TREE_TYPE (type));
}

/*
 * build a singleton array type, of TYPE objects.
 */
tree
build_array_type_for_scalar (type)
     tree type;
{
  /* KLUDGE */
  if (type == char_type_node)
    return build_string_type (type, integer_one_node);

  if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
    return error_mark_node;

  return build_chill_array_type
    (type,
     tree_cons (NULL_TREE,
		build_chill_range_type (NULL_TREE,
					integer_zero_node, integer_zero_node),
		NULL_TREE),
     0, NULL_TREE);

}

#if 0
static tree
unreferenced_type_of (type)
     tree type;
{
  if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
    return error_mark_node;
  while (TREE_CODE (type) == REFERENCE_TYPE)
    type = TREE_TYPE (type);
  return type;
}
#endif


/* Remove from *LISTP the first TREE_LIST node whose TREE_PURPOSE == KEY.
   Return the TREE_LIST node, or NULL_TREE on failure. */

static tree
remove_tree_element (key, listp)
     tree *listp;
     tree key;
{
  tree node = *listp;
  for ( ; node; listp = &TREE_CHAIN (node), node = *listp)
    {
      if (TREE_PURPOSE (node) == key)
	{
	  *listp = TREE_CHAIN (node);
	  TREE_CHAIN (node) = NULL_TREE;
	  return node;
	}
    }
  return NULL_TREE;
}

/* This is quite the same as check_range in actions.c, but with
   different error message. */

static tree
check_ps_range (value, lo_limit, hi_limit)
     tree value;
     tree lo_limit;
     tree hi_limit;
{
  tree check = test_range (value, lo_limit, hi_limit);

  if (!integer_zerop (check))
    {
      if (TREE_CODE (check) == INTEGER_CST)
	{
	  error ("powerset tuple element out of range");
	  return error_mark_node;
	}
      else
	value = check_expression (value, check,
				  ridpointers[(int) RID_RANGEFAIL]);
    }
  return value;
}

static tree
digest_powerset_tuple (type, inits)
     tree type;
     tree inits;
{
  tree list;
  tree result;
  tree domain = TYPE_DOMAIN (type);
  int i = 0;
  int is_erroneous = 0, is_constant = 1, is_simple = 1;
  if (domain == NULL_TREE || TREE_CODE (domain) == ERROR_MARK)
    return error_mark_node;
  for (list = TREE_OPERAND (inits, 1);  list; list = TREE_CHAIN (list), i++)
    {
      tree val = TREE_VALUE (list);
      if (TREE_CODE (val) == ERROR_MARK)
	{
	  is_erroneous = 1;
	  continue;
	}
      if (!TREE_CONSTANT (val))
	is_constant = 0;
      else if (!initializer_constant_valid_p (val, TREE_TYPE (val)))
	is_simple = 0;
      if (! CH_COMPATIBLE (val, domain))
	{
	  error ("incompatible member of powerset tuple (at position #%d)", i);
	  is_erroneous = 1;
	  continue;
	}
      /* check range of value */
      val = check_ps_range (val, TYPE_MIN_VALUE (domain),
			    TYPE_MAX_VALUE (domain));
      if (TREE_CODE (val) == ERROR_MARK)
	{
	  is_erroneous = 1;
	  continue;
	}

      /* Updating the list in place is in principle questionable,
	 but I can't think how it could hurt. */
      TREE_VALUE (list) = convert (domain, val);

      val = TREE_PURPOSE (list);
      if (val == NULL_TREE)
	continue;

      if (TREE_CODE (val) == ERROR_MARK)
	{
	  is_erroneous = 1;
	  continue;
	}
      if (! CH_COMPATIBLE (val, domain))
	{
	  error ("incompatible member of powerset tuple (at position #%d)", i);
	  is_erroneous = 1;
	  continue;
	}
      val = check_ps_range (val, TYPE_MIN_VALUE (domain),
			    TYPE_MAX_VALUE (domain));
      if (TREE_CODE (val) == ERROR_MARK)
	{
	  is_erroneous = 1;
	  continue;
	}
      TREE_PURPOSE (list) = convert (domain, val);
      if (!TREE_CONSTANT (val))
	is_constant = 0;
      else if (!initializer_constant_valid_p (val, TREE_TYPE (val)))
	is_simple = 0;
    }
  result = build (CONSTRUCTOR, type, NULL_TREE, TREE_OPERAND (inits, 1));
  if (is_erroneous)
    return error_mark_node;
  if (is_constant)
    TREE_CONSTANT (result) = 1;
  if (is_constant && is_simple)
    TREE_STATIC (result) = 1;
  return result;
}

static tree
digest_structure_tuple (type, inits)
     tree type;
     tree inits;
{
  tree elements = CONSTRUCTOR_ELTS (inits);
  tree values = NULL_TREE;
  int is_constant = 1;
  int is_simple = 1;
  int is_erroneous = 0;
  tree field;
  int labelled_elements = 0;
  int unlabelled_elements = 0;
  for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
    {
      if (TREE_CODE (TREE_TYPE (field)) != UNION_TYPE)
	{ /* Regular fixed field. */
	  tree value = remove_tree_element (DECL_NAME (field), &elements);

	  if (value)
	    labelled_elements++;
	  else if (elements && TREE_PURPOSE (elements) == NULL_TREE)
	    {
	      value = elements;
	      elements = TREE_CHAIN (elements);
	      unlabelled_elements++;
	    }

	  if (value)
	    {
	      tree val;
	      char msg[120];
	      sprintf (msg, "initializer for field `%.80s'",
		       IDENTIFIER_POINTER (DECL_NAME (field)));
	      val = chill_convert_for_assignment (TREE_TYPE (field),
						  TREE_VALUE (value), msg);
	      if (TREE_CODE (val) == ERROR_MARK)
		  is_erroneous = 1;
	      else
		{
		  TREE_VALUE (value) = val;
		  TREE_CHAIN (value) = values;
		  TREE_PURPOSE (value) = field;
		  values = value;	
		  if (TREE_CODE (val) == ERROR_MARK)
		    is_erroneous = 1;
		  else if (!TREE_CONSTANT (val))
		    is_constant = 0;
		  else if (!initializer_constant_valid_p (val,
							  TREE_TYPE (val)))
		    is_simple = 0;
		}
	    }
	  else
	    {
	      pedwarn ("no initializer value for fixed field `%s'",
		       IDENTIFIER_POINTER (DECL_NAME (field)));
	    }
	}
      else
	{
	  tree variant;
	  tree selected_variant = NULL_TREE;
	  tree variant_values = NULL_TREE;

	  /* In a tagged variant structure mode, try to figure out
	     (from the fixed fields), which is the selected variant. */
	  if (TYPE_TAGFIELDS (TREE_TYPE (field)))
	    {
	      for (variant = TYPE_FIELDS (TREE_TYPE (field));
		   variant; variant = TREE_CHAIN (variant))
		{
		  tree tag_labels = TYPE_TAG_VALUES (TREE_TYPE (variant));
		  tree tag_fields = TYPE_TAGFIELDS (TREE_TYPE (field));
		  if (DECL_NAME (variant) == ELSE_VARIANT_NAME)
		    {
		      selected_variant = variant;
		      break;
		    }
		  for (; tag_labels && tag_fields;
		       tag_labels = TREE_CHAIN (tag_labels),
		       tag_fields = TREE_CHAIN (tag_fields))
		    {
		      tree tag_value = values;
		      int found = 0;
		      tree tag_decl = TREE_VALUE (tag_fields);
		      tree tag_value_set = TREE_VALUE (tag_labels);
		      for ( ; tag_value; tag_value = TREE_CHAIN (tag_value))
			{
			  if (TREE_PURPOSE (tag_value) == tag_decl)