stt.c

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

/* stt.c -- Implementation File (module.c template V1.0)
   Copyright (C) 1995, 1997 Free Software Foundation, Inc.
   Contributed by James Craig Burley.

This file is part of GNU Fortran.

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

   Related Modules:
      None

   Description:
      Manages lists of tokens and related info for parsing.

   Modifications:
*/

/* Include files. */

#include "proj.h"
#include "stt.h"
#include "bld.h"
#include "expr.h"
#include "info.h"
#include "lex.h"
#include "malloc.h"
#include "sta.h"
#include "stp.h"

/* Externals defined here. */


/* Simple definitions and enumerations. */


/* Internal typedefs. */


/* Private include files. */


/* Internal structure definitions. */


/* Static objects accessed by functions in this module. */


/* Static functions (internal). */


/* Internal macros. */


/* ffestt_caselist_append -- Append case to list of cases

   ffesttCaseList list;
   ffelexToken t;
   ffestt_caselist_append(list,range,case1,case2,t);

   list must have already been created by ffestt_caselist_create.  The
   list is allocated out of the scratch pool.  The token is consumed.  */

void
ffestt_caselist_append (ffesttCaseList list, bool range, ffebld case1,
			ffebld case2, ffelexToken t)
{
  ffesttCaseList new;

  new = (ffesttCaseList) malloc_new_kp (ffesta_scratch_pool,
					"FFEST case list", sizeof (*new));
  new->next = list->previous->next;
  new->previous = list->previous;
  new->next->previous = new;
  new->previous->next = new;
  new->expr1 = case1;
  new->expr2 = case2;
  new->range = range;
  new->t = t;
}

/* ffestt_caselist_create -- Create new list of cases

   ffesttCaseList list;
   list = ffestt_caselist_create();

   The list is allocated out of the scratch pool.  */

ffesttCaseList
ffestt_caselist_create ()
{
  ffesttCaseList new;

  new = (ffesttCaseList) malloc_new_kp (ffesta_scratch_pool,
					"FFEST case list root",
					sizeof (*new));
  new->next = new->previous = new;
  new->t = NULL;
  new->expr1 = NULL;
  new->expr2 = NULL;
  new->range = FALSE;
  return new;
}

/* ffestt_caselist_dump -- Dump list of cases

   ffesttCaseList list;
   ffestt_caselist_dump(list);

   The cases in the list are dumped with commas separating them.  */

#if FFECOM_targetCURRENT == FFECOM_targetFFE
void
ffestt_caselist_dump (ffesttCaseList list)
{
  ffesttCaseList next;

  for (next = list->next; next != list; next = next->next)
    {
      if (next != list->next)
	fputc (',', dmpout);
      if (next->expr1 != NULL)
	ffebld_dump (next->expr1);
      if (next->range)
	{
	  fputc (':', dmpout);
	  if (next->expr2 != NULL)
	    ffebld_dump (next->expr2);
	}
    }
}
#endif

/* ffestt_caselist_kill -- Kill list of cases

   ffesttCaseList list;
   ffestt_caselist_kill(list);

   The tokens on the list are killed.

   02-Mar-90  JCB  1.1
      Don't kill the list itself or change it, since it will be trashed when
      ffesta_scratch_pool is killed anyway, so kill only the lex tokens.  */

void
ffestt_caselist_kill (ffesttCaseList list)
{
  ffesttCaseList next;

  for (next = list->next; next != list; next = next->next)
    {
      ffelex_token_kill (next->t);
    }
}

/* ffestt_dimlist_append -- Append dim to list of dims

   ffesttDimList list;
   ffelexToken t;
   ffestt_dimlist_append(list,lower,upper,t);

   list must have already been created by ffestt_dimlist_create.  The
   list is allocated out of the scratch pool.  The token is consumed.  */

void
ffestt_dimlist_append (ffesttDimList list, ffebld lower, ffebld upper,
		       ffelexToken t)
{
  ffesttDimList new;

  new = (ffesttDimList) malloc_new_kp (ffesta_scratch_pool,
				       "FFEST dim list", sizeof (*new));
  new->next = list->previous->next;
  new->previous = list->previous;
  new->next->previous = new;
  new->previous->next = new;
  new->lower = lower;
  new->upper = upper;
  new->t = t;
}

/* Convert list of dims into ffebld format.

   ffesttDimList list;
   ffeinfoRank rank;
   ffebld array_size;
   ffebld extents;
   ffestt_dimlist_as_expr (list, &rank, &array_size, &extents);

   The dims in the list are converted to a list of ITEMs; the rank of the
   array, an expression representing the array size, a list of extent
   expressions, and the list of ITEMs are returned.

   If is_ugly_assumed, treat a final dimension with no lower bound
   and an upper bound of 1 as a * bound.  */

ffebld
ffestt_dimlist_as_expr (ffesttDimList list, ffeinfoRank *rank,
			ffebld *array_size, ffebld *extents,
			bool is_ugly_assumed)
{
  ffesttDimList next;
  ffebld expr;
  ffebld as;
  ffebld ex;			/* List of extents. */
  ffebld ext;			/* Extent of a given dimension. */
  ffebldListBottom bottom;
  ffeinfoRank r;
  ffeinfoKindtype nkt;
  ffetargetIntegerDefault low;
  ffetargetIntegerDefault high;
  bool zero = FALSE;		/* Zero-size array. */
  bool any = FALSE;
  bool star = FALSE;		/* Adjustable array. */

  assert (list != NULL);

  r = 0;
  ffebld_init_list (&expr, &bottom);
  for (next = list->next; next != list; next = next->next)
    {
      ++r;
      if (((next->lower == NULL)
	   || (ffebld_op (next->lower) == FFEBLD_opCONTER))
	  && (ffebld_op (next->upper) == FFEBLD_opCONTER))
	{
	  if (next->lower == NULL)
	    low = 1;
	  else
	    low = ffebld_constant_integerdefault (ffebld_conter (next->lower));
	  high = ffebld_constant_integerdefault (ffebld_conter (next->upper));
	  if (low
	      > high)
	    zero = TRUE;
	  if ((next->next == list)
	      && is_ugly_assumed
	      && (next->lower == NULL)
	      && (high == 1)
	      && (ffebld_conter_orig (next->upper) == NULL))
	    {
	      star = TRUE;
	      ffebld_append_item (&bottom,
				  ffebld_new_bounds (NULL, ffebld_new_star ()));
	      continue;
	    }
	}
      else if (((next->lower != NULL)
		&& (ffebld_op (next->lower) == FFEBLD_opANY))
	       || (ffebld_op (next->upper) == FFEBLD_opANY))
	any = TRUE;
      else if (ffebld_op (next->upper) == FFEBLD_opSTAR)
	star = TRUE;
      ffebld_append_item (&bottom,
			  ffebld_new_bounds (next->lower, next->upper));
    }
  ffebld_end_list (&bottom);

  if (zero)
    {
      as = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
      ffebld_set_info (as, ffeinfo_new
		       (FFEINFO_basictypeINTEGER,
			FFEINFO_kindtypeINTEGERDEFAULT,
			0,
			FFEINFO_kindENTITY,
			FFEINFO_whereCONSTANT,
			FFETARGET_charactersizeNONE));
      ex = NULL;
    }
  else if (any)
    {
      as = ffebld_new_any ();
      ffebld_set_info (as, ffeinfo_new_any ());
      ex = ffebld_copy (as);
    }
  else if (star)
    {
      as = ffebld_new_star ();
      ex = ffebld_new_star ();	/* ~~Should really be list as below. */
    }
  else
    {
      as = NULL;
      ffebld_init_list (&ex, &bottom);
      for (next = list->next; next != list; next = next->next)
	{
	  if ((next->lower == NULL)
	      || ((ffebld_op (next->lower) == FFEBLD_opCONTER)
		  && (ffebld_constant_integerdefault (ffebld_conter
						      (next->lower)) == 1)))
	    ext = ffebld_copy (next->upper);
	  else
	    {
	      ext = ffebld_new_subtract (next->upper, next->lower);
	      nkt
		= ffeinfo_kindtype_max (FFEINFO_basictypeINTEGER,
					ffeinfo_kindtype (ffebld_info
							  (next->lower)),
					ffeinfo_kindtype (ffebld_info
							  (next->upper)));
	      ffebld_set_info (ext,
			       ffeinfo_new (FFEINFO_basictypeINTEGER,
					    nkt,
					    0,
					    FFEINFO_kindENTITY,
					    ((ffebld_op (ffebld_left (ext))
					      == FFEBLD_opCONTER)
					     && (ffebld_op (ffebld_right
							    (ext))
						 == FFEBLD_opCONTER))
					    ? FFEINFO_whereCONSTANT
					    : FFEINFO_whereFLEETING,
					    FFETARGET_charactersizeNONE));
	      ffebld_set_left (ext,
			       ffeexpr_convert_expr (ffebld_left (ext),
						     next->t, ext, next->t,
						     FFEEXPR_contextLET));
	      ffebld_set_right (ext,
				ffeexpr_convert_expr (ffebld_right (ext),
						      next->t, ext,
						      next->t,
						      FFEEXPR_contextLET));
	      ext = ffeexpr_collapse_subtract (ext, next->t);

	      nkt
		= ffeinfo_kindtype_max (FFEINFO_basictypeINTEGER,
					ffeinfo_kindtype (ffebld_info (ext)),
					FFEINFO_kindtypeINTEGERDEFAULT);
	      ext
		= ffebld_new_add (ext,
				  ffebld_new_conter
				  (ffebld_constant_new_integerdefault_val
				   (1)));
	      ffebld_set_info (ffebld_right (ext), ffeinfo_new
			       (FFEINFO_basictypeINTEGER,
				FFEINFO_kindtypeINTEGERDEFAULT,
				0,
				FFEINFO_kindENTITY,
				FFEINFO_whereCONSTANT,
				FFETARGET_charactersizeNONE));
	      ffebld_set_info (ext,
			       ffeinfo_new (FFEINFO_basictypeINTEGER,
					    nkt, 0, FFEINFO_kindENTITY,
					    (ffebld_op (ffebld_left (ext))
					     == FFEBLD_opCONTER)
					    ? FFEINFO_whereCONSTANT
					    : FFEINFO_whereFLEETING,
					    FFETARGET_charactersizeNONE));
	      ffebld_set_left (ext,
			       ffeexpr_convert_expr (ffebld_left (ext),
						     next->t, ext,
						     next->t,
						     FFEEXPR_contextLET));
	      ffebld_set_right (ext,
				ffeexpr_convert_expr (ffebld_right (ext),
						      next->t, ext,
						      next->t,
						      FFEEXPR_contextLET));
	      ext = ffeexpr_collapse_add (ext, next->t);
	    }
	  ffebld_append_item (&bottom, ext);
	  if (as == NULL)
	    as = ext;
	  else
	    {
	      nkt
		= ffeinfo_kindtype_max (FFEINFO_basictypeINTEGER,
					ffeinfo_kindtype (ffebld_info (as)),
				      ffeinfo_kindtype (ffebld_info (ext)));
	      as = ffebld_new_multiply (as, ext);
	      ffebld_set_info (as,
			       ffeinfo_new (FFEINFO_basictypeINTEGER,
					    nkt, 0, FFEINFO_kindENTITY,
					    ((ffebld_op (ffebld_left (as))
					      == FFEBLD_opCONTER)
					     && (ffebld_op (ffebld_right
							    (as))
						 == FFEBLD_opCONTER))
					    ? FFEINFO_whereCONSTANT
					    : FFEINFO_whereFLEETING,
					    FFETARGET_charactersizeNONE));
	      ffebld_set_left (as,
			       ffeexpr_convert_expr (ffebld_left (as),
						     next->t, as, next->t,
						     FFEEXPR_contextLET));
	      ffebld_set_right (as,
				ffeexpr_convert_expr (ffebld_right (as),
						      next->t, as,
						      next->t,
						      FFEEXPR_contextLET));
	      as = ffeexpr_collapse_multiply (as, next->t);
	    }
	}
      ffebld_end_list (&bottom);
      as = ffeexpr_convert (as, list->next->t, NULL,
			    FFEINFO_basictypeINTEGER,
			    FFEINFO_kindtypeINTEGERDEFAULT, 0,
			    FFETARGET_charactersizeNONE,
			    FFEEXPR_contextLET);
    }

  *rank = r;
  *array_size = as;
  *extents = ex;
  return expr;
}

/* ffestt_dimlist_create -- Create new list of dims

   ffesttDimList list;
   list = ffestt_dimlist_create();

   The list is allocated out of the scratch pool.  */

ffesttDimList
ffestt_dimlist_create ()
{
  ffesttDimList new;

  new = (ffesttDimList) malloc_new_kp (ffesta_scratch_pool,
				       "FFEST dim list root", sizeof (*new));
  new->next = new->previous = new;
  new->t = NULL;
  new->lower = NULL;
  new->upper = NULL;
  return new;
}

/* ffestt_dimlist_dump -- Dump list of dims

   ffesttDimList list;
   ffestt_dimlist_dump(list);

   The dims in the list are dumped with commas separating them.	 */

#if FFECOM_targetCURRENT == FFECOM_targetFFE
void
ffestt_dimlist_dump (ffesttDimList list)
{
  ffesttDimList next;

  for (next = list->next; next != list; next = next->next)
    {
      if (next != list->next)
	fputc (',', dmpout);
      if (next->lower != NULL)
	ffebld_dump (next->lower);
      fputc (':', dmpout);
      if (next->upper != NULL)
	ffebld_dump (next->upper);
    }
}
#endif

/* ffestt_dimlist_kill -- Kill list of dims

   ffesttDimList list;
   ffestt_dimlist_kill(list);

   The tokens on the list are killed.  */

void
ffestt_dimlist_kill (ffesttDimList list)
{
  ffesttDimList next;

  for (next = list->next; next != list; next = next->next)
    {
      ffelex_token_kill (next->t);
    }
}

/* Determine type of list of dimensions.

   Return KNOWN for all-constant bounds, ADJUSTABLE for constant
   and variable but no * bounds, ASSUMED for constant and * but
   not variable bounds, ADJUSTABLEASSUMED for constant and variable
   and * bounds.

   If is_ugly_assumed, treat a final dimension with no lower bound
   and an upper bound of 1 as a * bound.  */

ffestpDimtype
ffestt_dimlist_type (ffesttDimList list, bool is_ugly_assumed)
{
  ffesttDimList next;
  ffestpDimtype type;

  if (list == NULL)
    return FFESTP_dimtypeNONE;

  type = FFESTP_dimtypeKNOWN;
  for (next = list->next; next != list; next = next->next)
    {
      bool ugly_assumed = FALSE;

      if ((next->next == list)
	  && is_ugly_assumed
	  && (next->lower == NULL)
	  && (next->upper != NULL)
	  && (ffebld_op (next->upper) == FFEBLD_opCONTER)
	  && (ffebld_constant_integerdefault (ffebld_conter (next->upper))
	      == 1)
	  && (ffebld_conter_orig (next->upper) == NULL))
	ugly_assumed = TRUE;

      if (next->lower != NULL)
	{
	  if (ffebld_op (next->lower) != FFEBLD_opCONTER)
	    {
	      if (type == FFESTP_dimtypeASSUMED)