[thirdparty/gcc.git] / gcc / fortran / trans-const.c

/* Translation of constants
   Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
   Contributed by Paul Brook

This file is part of GCC.

GCC 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.

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

/* trans-const.c -- convert constant values */

#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include <stdio.h>
#include "ggc.h"
#include "toplev.h"
#include "real.h"
#include <gmp.h>
#include <assert.h>
#include <math.h>
#include "gfortran.h"
#include "trans.h"
#include "trans-const.h"
#include "trans-types.h"

/* String constants.  */
tree gfc_strconst_bounds;
tree gfc_strconst_fault;
tree gfc_strconst_wrong_return;
tree gfc_strconst_current_filename;

tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1];

/* Build a constant with given type from an int_cst.  */
tree
gfc_build_const (tree type, tree intval)
{
  tree val;
  tree zero;

  switch (TREE_CODE (type))
    {
    case INTEGER_TYPE:
      val = convert (type, intval);
      break;

    case REAL_TYPE:
      val = build_real_from_int_cst (type, intval);
      break;

    case COMPLEX_TYPE:
      val = build_real_from_int_cst (TREE_TYPE (type), intval);
      zero = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
      val = build_complex (type, val, zero);
      break;

    default:
      abort ();
    }
  return val;
}

tree
gfc_build_string_const (int length, const char *s)
{
  tree str;
  tree len;

  str = build_string (length, s);
  len = build_int_2 (length, 0);
  TREE_TYPE (str) =
    build_array_type (gfc_character1_type_node,
		      build_range_type (gfc_strlen_type_node,
					integer_one_node, len));
  return str;
}

/* Return a string constant with the given length.  Used for static
   initializers.  The constant will be padded or truncated to match 
   length.  */

tree
gfc_conv_string_init (tree length, gfc_expr * expr)
{
  char *s;
  HOST_WIDE_INT len;
  int slen;
  tree str;

  assert (expr->expr_type == EXPR_CONSTANT);
  assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
  assert (INTEGER_CST_P (length));
  assert (TREE_INT_CST_HIGH (length) == 0);

  len = TREE_INT_CST_LOW (length);
  slen = expr->value.character.length;

  if (len > slen)
    {
      s = gfc_getmem (len);
      memcpy (s, expr->value.character.string, slen);
      memset (&s[slen], ' ', len - slen);
      str = gfc_build_string_const (len, s);
      gfc_free (s);
    }
  else
    str = gfc_build_string_const (len, expr->value.character.string);

  return str;
}


/* Create a tree node for the string length if it is constant.  */

void
gfc_conv_const_charlen (gfc_charlen * cl)
{
  if (cl->backend_decl)
    return;

  if (cl->length && cl->length->expr_type == EXPR_CONSTANT)
    {
      cl->backend_decl = gfc_conv_mpz_to_tree (cl->length->value.integer,
					       cl->length->ts.kind);
    }
}

void
gfc_init_constants (void)
{
  int n;

  for (n = 0; n <= GFC_MAX_DIMENSIONS; n++)
    {
      gfc_rank_cst[n] = build_int_2 (n, 0);
      TREE_TYPE (gfc_rank_cst[n]) = gfc_array_index_type;
    }

  gfc_strconst_bounds = gfc_build_string_const (21, "Array bound mismatch");

  gfc_strconst_fault =
    gfc_build_string_const (30, "Array reference out of bounds");

  gfc_strconst_wrong_return =
    gfc_build_string_const (32, "Incorrect function return value");

  gfc_strconst_current_filename =
    gfc_build_string_const (strlen (gfc_option.source) + 1,
			    gfc_option.source);
}

#define BITS_PER_HOST_WIDE_INT (8 * sizeof (HOST_WIDE_INT))
/* Converts a GMP integer into a backend tree node.  */
tree
gfc_conv_mpz_to_tree (mpz_t i, int kind)
{
  int val;
  tree res;
  HOST_WIDE_INT high;
  unsigned HOST_WIDE_INT low;
  int negate;
  char buff[10];
  char *p;
  char *q;
  int n;

  /* TODO: could be wrong if sizeof(HOST_WIDE_INT) |= SIZEOF (int).  */
  if (mpz_fits_slong_p (i))
    {
      val = mpz_get_si (i);
      res = build_int_2 (val, (val < 0) ? (HOST_WIDE_INT)-1 : 0);
      TREE_TYPE (res) = gfc_get_int_type (kind);
      return (res);
    }

  n = mpz_sizeinbase (i, 16);
  if (n > 8)
    q = gfc_getmem (n + 2);
  else
    q = buff;

  low = 0;
  high = 0;
  p = mpz_get_str (q, 16, i);
  if (p[0] == '-')
    {
      negate = 1;
      p++;
    }
  else
    negate = 0;

  while (*p)
    {
      n = *(p++);
      if (n >= '0' && n <= '9')
	n = n - '0';
      else if (n >= 'a' && n <= 'z')
	n = n + 10 - 'a';
      else if (n >= 'A' && n <= 'Z')
	n = n + 10 - 'A';
      else
	abort ();

      assert (n >= 0 && n < 16);
      high = (high << 4) + (low >> (BITS_PER_HOST_WIDE_INT - 4));
      low = (low << 4) + n;
    }
  res = build_int_2 (low, high);
  TREE_TYPE (res) = gfc_get_int_type (kind);
  if (negate)
    res = fold (build1 (NEGATE_EXPR, TREE_TYPE (res), res));

  if (q != buff)
    gfc_free (q);

  return res;
}

/* Converts a real constant into backend form.  Uses an intermediate string
   representation.  */
tree
gfc_conv_mpfr_to_tree (mpfr_t f, int kind)
{
  tree res;
  tree type;
  mp_exp_t exp;
  char *p;
  char *q;
  int n;
  int edigits;

  for (n = 0; gfc_real_kinds[n].kind != 0; n++)
    {
      if (gfc_real_kinds[n].kind == kind)
	break;
    }
  assert (gfc_real_kinds[n].kind);

  n = MAX (abs (gfc_real_kinds[n].min_exponent),
	   abs (gfc_real_kinds[n].max_exponent));

  edigits = 1;
  while (n > 0)
    {
      n = n / 10;
      edigits += 3;
    }

  if (kind == gfc_default_double_kind())
    p = mpfr_get_str (NULL, &exp, 10, 17, f, GFC_RND_MODE);
  else
    p = mpfr_get_str (NULL, &exp, 10, 8, f, GFC_RND_MODE);


  /* We also have one minus sign, "e", "." and a null terminator.  */
  q = (char *) gfc_getmem (strlen (p) + edigits + 4);

  if (p[0])
    {
      if (p[0] == '-')
	{
	  strcpy (&q[2], &p[1]);
	  q[0] = '-';
	  q[1] = '.';
	}
      else
	{
	  strcpy (&q[1], p);
	  q[0] = '.';
	}
      strcat (q, "e");
      sprintf (&q[strlen (q)], "%d", (int) exp);
    }
  else
    {
      strcpy (q, "0");
    }

  type = gfc_get_real_type (kind);
  res = build_real (type, REAL_VALUE_ATOF (q, TYPE_MODE (type)));

  gfc_free (q);
  gfc_free (p);

  return res;
}


/* Translate any literal constant to a tree.  Constants never have
   pre or post chains.  Character literal constants are special
   special because they have a value and a length, so they cannot be
   returned as a single tree.  It is up to the caller to set the
   length somewhere if necessary.

   Returns the translated constant, or aborts if it gets a type it
   can't handle.  */

tree
gfc_conv_constant_to_tree (gfc_expr * expr)
{
  assert (expr->expr_type == EXPR_CONSTANT);

  switch (expr->ts.type)
    {
    case BT_INTEGER:
      return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);

    case BT_REAL:
      return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind);

    case BT_LOGICAL:
      return build_int_2 (expr->value.logical, 0);

    case BT_COMPLEX:
      {
	tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r,
					  expr->ts.kind);
	tree imag = gfc_conv_mpfr_to_tree (expr->value.complex.i,
					  expr->ts.kind);

	return build_complex (NULL_TREE, real, imag);
      }

    case BT_CHARACTER:
      return gfc_build_string_const (expr->value.character.length,
				     expr->value.character.string);

    default:
      fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
		   gfc_typename (&expr->ts));
    }
}


/* Like gfc_conv_contrant_to_tree, but for a simplified expression.
   We can handle character literal constants here as well.  */

void
gfc_conv_constant (gfc_se * se, gfc_expr * expr)
{
  assert (expr->expr_type == EXPR_CONSTANT);

  if (se->ss != NULL)
    {
      assert (se->ss != gfc_ss_terminator);
      assert (se->ss->type == GFC_SS_SCALAR);
      assert (se->ss->expr == expr);

      se->expr = se->ss->data.scalar.expr;
      se->string_length = se->ss->data.scalar.string_length;
      gfc_advance_se_ss_chain (se);
      return;
    }

  /* Translate the constant and put it in the simplifier structure.  */
  se->expr = gfc_conv_constant_to_tree (expr);

  /* If this is a CHARACTER string, set it's length in the simplifier
     structure, too.  */
  if (expr->ts.type == BT_CHARACTER)
    se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
}
Commit	Line	Data
6de9cd9a	1	/* Translation of constants
9fc4d79b	2	Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
6de9cd9a DN	3	Contributed by Paul Brook
6de9cd9a DN	4
9fc4d79b	5	This file is part of GCC.
6de9cd9a	6
9fc4d79b TS	7	GCC is free software; you can redistribute it and/or modify it under
	8	the terms of the GNU General Public License as published by the Free
	9	Software Foundation; either version 2, or (at your option) any later
	10	version.
6de9cd9a	11
9fc4d79b TS	12	GCC is distributed in the hope that it will be useful, but WITHOUT ANY
	13	WARRANTY; without even the implied warranty of MERCHANTABILITY or
	14	FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
	15	for more details.
6de9cd9a DN	16
6de9cd9a DN	17	You should have received a copy of the GNU General Public License
9fc4d79b TS	18	along with GCC; see the file COPYING. If not, write to the Free
	19	Software Foundation, 59 Temple Place - Suite 330, Boston, MA
	20	02111-1307, USA. */
6de9cd9a DN	21
	22	/* trans-const.c -- convert constant values */
	23
	24	#include "config.h"
	25	#include "system.h"
	26	#include "coretypes.h"
	27	#include "tree.h"
	28	#include <stdio.h>
	29	#include "ggc.h"
	30	#include "toplev.h"
	31	#include "real.h"
	32	#include <gmp.h>
	33	#include <assert.h>
	34	#include <math.h>
	35	#include "gfortran.h"
	36	#include "trans.h"
	37	#include "trans-const.h"
	38	#include "trans-types.h"
	39
	40	/* String constants. */
	41	tree gfc_strconst_bounds;
	42	tree gfc_strconst_fault;
	43	tree gfc_strconst_wrong_return;
	44	tree gfc_strconst_current_filename;
	45
	46	tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1];
	47
	48	/* Build a constant with given type from an int_cst. */
	49	tree
	50	gfc_build_const (tree type, tree intval)
	51	{
	52	tree val;
	53	tree zero;
	54
	55	switch (TREE_CODE (type))
	56	{
	57	case INTEGER_TYPE:
	58	val = convert (type, intval);
	59	break;
	60
	61	case REAL_TYPE:
	62	val = build_real_from_int_cst (type, intval);
	63	break;
	64
	65	case COMPLEX_TYPE:
	66	val = build_real_from_int_cst (TREE_TYPE (type), intval);
	67	zero = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
	68	val = build_complex (type, val, zero);
	69	break;
	70
	71	default:
	72	abort ();
	73	}
	74	return val;
	75	}
	76
	77	tree
	78	gfc_build_string_const (int length, const char *s)
	79	{
	80	tree str;
	81	tree len;
	82
	83	str = build_string (length, s);
	84	len = build_int_2 (length, 0);
85	TREE_TYPE (str) =
86	build_array_type (gfc_character1_type_node,
87	build_range_type (gfc_strlen_type_node,
88	integer_one_node, len));
89	return str;
90	}
91
92	/* Return a string constant with the given length. Used for static
94716287 TS	93	initializers. The constant will be padded or truncated to match
	94	length. */
	95
6de9cd9a DN	96	tree
	97	gfc_conv_string_init (tree length, gfc_expr * expr)
	98	{
	99	char *s;
	100	HOST_WIDE_INT len;
	101	int slen;
	102	tree str;
	103
	104	assert (expr->expr_type == EXPR_CONSTANT);
	105	assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
	106	assert (INTEGER_CST_P (length));
	107	assert (TREE_INT_CST_HIGH (length) == 0);
	108
	109	len = TREE_INT_CST_LOW (length);
	110	slen = expr->value.character.length;
94716287 TS	111
94716287 TS	112	if (len > slen)
6de9cd9a DN	113	{
	114	s = gfc_getmem (len);
	115	memcpy (s, expr->value.character.string, slen);
	116	memset (&s[slen], ' ', len - slen);
	117	str = gfc_build_string_const (len, s);
	118	gfc_free (s);
	119	}
	120	else
	121	str = gfc_build_string_const (len, expr->value.character.string);
	122
	123	return str;
	124	}
	125
	126
	127	/* Create a tree node for the string length if it is constant. */
	128
	129	void
	130	gfc_conv_const_charlen (gfc_charlen * cl)
	131	{
	132	if (cl->backend_decl)
	133	return;
	134
	135	if (cl->length && cl->length->expr_type == EXPR_CONSTANT)
	136	{
	137	cl->backend_decl = gfc_conv_mpz_to_tree (cl->length->value.integer,
	138	cl->length->ts.kind);
	139	}
	140	}
	141
	142	void
	143	gfc_init_constants (void)
	144	{
	145	int n;
	146
	147	for (n = 0; n <= GFC_MAX_DIMENSIONS; n++)
	148	{
	149	gfc_rank_cst[n] = build_int_2 (n, 0);
	150	TREE_TYPE (gfc_rank_cst[n]) = gfc_array_index_type;
	151	}
	152
	153	gfc_strconst_bounds = gfc_build_string_const (21, "Array bound mismatch");
	154
	155	gfc_strconst_fault =
	156	gfc_build_string_const (30, "Array reference out of bounds");
	157
	158	gfc_strconst_wrong_return =
	159	gfc_build_string_const (32, "Incorrect function return value");
	160
	161	gfc_strconst_current_filename =
	162	gfc_build_string_const (strlen (gfc_option.source) + 1,
	163	gfc_option.source);
	164	}
	165
	166	#define BITS_PER_HOST_WIDE_INT (8 * sizeof (HOST_WIDE_INT))
	167	/* Converts a GMP integer into a backend tree node. */
	168	tree
	169	gfc_conv_mpz_to_tree (mpz_t i, int kind)
	170	{
	171	int val;
	172	tree res;
	173	HOST_WIDE_INT high;
	174	unsigned HOST_WIDE_INT low;
	175	int negate;
	176	char buff[10];
177	char *p;
178	char *q;
179	int n;
180
181	/* TODO: could be wrong if sizeof(HOST_WIDE_INT) \|= SIZEOF (int). */
182	if (mpz_fits_slong_p (i))
183	{
184	val = mpz_get_si (i);
185	res = build_int_2 (val, (val < 0) ? (HOST_WIDE_INT)-1 : 0);
186	TREE_TYPE (res) = gfc_get_int_type (kind);
187	return (res);
188	}
189
190	n = mpz_sizeinbase (i, 16);
191	if (n > 8)
192	q = gfc_getmem (n + 2);
193	else
194	q = buff;
195
196	low = 0;
197	high = 0;
198	p = mpz_get_str (q, 16, i);
199	if (p[0] == '-')
200	{
201	negate = 1;
202	p++;
203	}
204	else
205	negate = 0;
206
207	while (*p)
208	{
209	n = *(p++);
210	if (n >= '0' && n <= '9')
211	n = n - '0';
212	else if (n >= 'a' && n <= 'z')
213	n = n + 10 - 'a';
214	else if (n >= 'A' && n <= 'Z')
215	n = n + 10 - 'A';
216	else
217	abort ();
218
219	assert (n >= 0 && n < 16);
220	high = (high << 4) + (low >> (BITS_PER_HOST_WIDE_INT - 4));
221	low = (low << 4) + n;
222	}
223	res = build_int_2 (low, high);
224	TREE_TYPE (res) = gfc_get_int_type (kind);
225	if (negate)
226	res = fold (build1 (NEGATE_EXPR, TREE_TYPE (res), res));
227
228	if (q != buff)
229	gfc_free (q);
230
231	return res;
232	}
233
234	/* Converts a real constant into backend form. Uses an intermediate string
235	representation. */
236	tree
f8e566e5	237	gfc_conv_mpfr_to_tree (mpfr_t f, int kind)
6de9cd9a DN	238	{
	239	tree res;
	240	tree type;
	241	mp_exp_t exp;
	242	char *p;
	243	char *q;
	244	int n;
	245	int edigits;
	246
	247	for (n = 0; gfc_real_kinds[n].kind != 0; n++)
	248	{
	249	if (gfc_real_kinds[n].kind == kind)
	250	break;
	251	}
	252	assert (gfc_real_kinds[n].kind);
	253
6de9cd9a	254	n = MAX (abs (gfc_real_kinds[n].min_exponent),
e584e501	255	abs (gfc_real_kinds[n].max_exponent));
f8e566e5	256
6de9cd9a DN	257	edigits = 1;
	258	while (n > 0)
	259	{
	260	n = n / 10;
	261	edigits += 3;
	262	}
	263
f8e566e5 SK	264	if (kind == gfc_default_double_kind())
	265	p = mpfr_get_str (NULL, &exp, 10, 17, f, GFC_RND_MODE);
	266	else
	267	p = mpfr_get_str (NULL, &exp, 10, 8, f, GFC_RND_MODE);
6de9cd9a	268
6de9cd9a DN	269
	270	/* We also have one minus sign, "e", "." and a null terminator. */
	271	q = (char *) gfc_getmem (strlen (p) + edigits + 4);
	272
	273	if (p[0])
	274	{
	275	if (p[0] == '-')
	276	{
	277	strcpy (&q[2], &p[1]);
	278	q[0] = '-';
	279	q[1] = '.';
	280	}
	281	else
	282	{
	283	strcpy (&q[1], p);
	284	q[0] = '.';
	285	}
	286	strcat (q, "e");
	287	sprintf (&q[strlen (q)], "%d", (int) exp);
	288	}
	289	else
	290	{
	291	strcpy (q, "0");
	292	}
	293
	294	type = gfc_get_real_type (kind);
	295	res = build_real (type, REAL_VALUE_ATOF (q, TYPE_MODE (type)));
f8e566e5	296
6de9cd9a DN	297	gfc_free (q);
	298	gfc_free (p);
	299
	300	return res;
	301	}
	302
	303
	304	/* Translate any literal constant to a tree. Constants never have
	305	pre or post chains. Character literal constants are special
	306	special because they have a value and a length, so they cannot be
	307	returned as a single tree. It is up to the caller to set the
	308	length somewhere if necessary.
	309
	310	Returns the translated constant, or aborts if it gets a type it
	311	can't handle. */
	312
	313	tree
	314	gfc_conv_constant_to_tree (gfc_expr * expr)
	315	{
	316	assert (expr->expr_type == EXPR_CONSTANT);
	317
	318	switch (expr->ts.type)
	319	{
	320	case BT_INTEGER:
	321	return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
	322
	323	case BT_REAL:
f8e566e5	324	return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind);
6de9cd9a DN	325
	326	case BT_LOGICAL:
	327	return build_int_2 (expr->value.logical, 0);
	328
	329	case BT_COMPLEX:
	330	{
f8e566e5	331	tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r,
6de9cd9a	332	expr->ts.kind);
f8e566e5	333	tree imag = gfc_conv_mpfr_to_tree (expr->value.complex.i,
6de9cd9a DN	334	expr->ts.kind);
	335
	336	return build_complex (NULL_TREE, real, imag);
	337	}
	338
	339	case BT_CHARACTER:
	340	return gfc_build_string_const (expr->value.character.length,
	341	expr->value.character.string);
	342
	343	default:
	344	fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
	345	gfc_typename (&expr->ts));
	346	}
	347	}
	348
	349
	350	/* Like gfc_conv_contrant_to_tree, but for a simplified expression.
	351	We can handle character literal constants here as well. */
	352
	353	void
	354	gfc_conv_constant (gfc_se * se, gfc_expr * expr)
	355	{
	356	assert (expr->expr_type == EXPR_CONSTANT);
	357
	358	if (se->ss != NULL)
	359	{
	360	assert (se->ss != gfc_ss_terminator);
	361	assert (se->ss->type == GFC_SS_SCALAR);
	362	assert (se->ss->expr == expr);
	363
	364	se->expr = se->ss->data.scalar.expr;
	365	se->string_length = se->ss->data.scalar.string_length;
	366	gfc_advance_se_ss_chain (se);
	367	return;
	368	}
	369
	370	/* Translate the constant and put it in the simplifier structure. */
	371	se->expr = gfc_conv_constant_to_tree (expr);
	372
	373	/* If this is a CHARACTER string, set it's length in the simplifier
	374	structure, too. */
	375	if (expr->ts.type == BT_CHARACTER)
	376	se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
	377	}