freebsd-nq/contrib/gcc/f/stt.c

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

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)
		type = FFESTP_dimtypeADJUSTABLEASSUMED;
	      else
		type = FFESTP_dimtypeADJUSTABLE;
	    }
	}
      if (next->upper != NULL)
	{
	  if (ugly_assumed
	      || (ffebld_op (next->upper) == FFEBLD_opSTAR))
	    {
	      if (type == FFESTP_dimtypeADJUSTABLE)
		type = FFESTP_dimtypeADJUSTABLEASSUMED;
	      else
		type = FFESTP_dimtypeASSUMED;
	    }
	  else if (ffebld_op (next->upper) != FFEBLD_opCONTER)
	    type = FFESTP_dimtypeADJUSTABLE;
	}
    }

  return type;
}

/* ffestt_exprlist_append -- Append expr to list of exprs

   ffesttExprList list;
   ffelexToken t;
   ffestt_exprlist_append(list,expr,t);

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

void
ffestt_exprlist_append (ffesttExprList list, ffebld expr, ffelexToken t)
{
  ffesttExprList new;

  new = (ffesttExprList) malloc_new_kp (ffesta_scratch_pool,
					"FFEST expr list", sizeof (*new));
  new->next = list->previous->next;
  new->previous = list->previous;
  new->next->previous = new;
  new->previous->next = new;
  new->expr = expr;
  new->t = t;
}

/* ffestt_exprlist_create -- Create new list of exprs

   ffesttExprList list;
   list = ffestt_exprlist_create();

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

ffesttExprList
ffestt_exprlist_create ()
{
  ffesttExprList new;

  new = (ffesttExprList) malloc_new_kp (ffesta_scratch_pool,
				     "FFEST expr list root", sizeof (*new));
  new->next = new->previous = new;
  new->expr = NULL;
  new->t = NULL;
  return new;
}

/* ffestt_exprlist_drive -- Drive list of token pairs into function

   ffesttExprList list;
   void fn(ffebld expr,ffelexToken t);
   ffestt_exprlist_drive(list,fn);

   The expr/token pairs in the list are passed to the function one pair
   at a time.  */

void
ffestt_exprlist_drive (ffesttExprList list, void (*fn) ())
{
  ffesttExprList next;

  if (list == NULL)
    return;

  for (next = list->next; next != list; next = next->next)
    {
      (*fn) (next->expr, next->t);
    }
}

/* ffestt_exprlist_dump -- Dump list of exprs

   ffesttExprList list;
   ffestt_exprlist_dump(list);

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

#if FFECOM_targetCURRENT == FFECOM_targetFFE
void
ffestt_exprlist_dump (ffesttExprList list)
{
  ffesttExprList next;

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

/* ffestt_exprlist_kill -- Kill list of exprs

   ffesttExprList list;
   ffestt_exprlist_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_exprlist_kill (ffesttExprList list)
{
  ffesttExprList next;

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

/* ffestt_formatlist_append -- Append null format to list of formats

   ffesttFormatList list, new;
   new = ffestt_formatlist_append(list);

   list must have already been created by ffestt_formatlist_create.  The
   new item is allocated out of the scratch pool.  The caller must initialize
   it appropriately.  */

ffesttFormatList
ffestt_formatlist_append (ffesttFormatList list)
{
  ffesttFormatList new;

  new = (ffesttFormatList) malloc_new_kp (ffesta_scratch_pool,
					"FFEST format list", sizeof (*new));
  new->next = list->previous->next;
  new->previous = list->previous;
  new->next->previous = new;
  new->previous->next = new;
  return new;
}

/* ffestt_formatlist_create -- Create new list of formats

   ffesttFormatList list;
   list = ffestt_formatlist_create(NULL);

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

ffesttFormatList
ffestt_formatlist_create (ffesttFormatList parent, ffelexToken t)
{
  ffesttFormatList new;

  new = (ffesttFormatList) malloc_new_kp (ffesta_scratch_pool,
				   "FFEST format list root", sizeof (*new));
  new->next = new->previous = new;
  new->type = FFESTP_formattypeNone;
  new->t = t;
  new->u.root.parent = parent;
  return new;
}

/* ffestt_formatlist_kill -- Kill tokens on list of formats

   ffesttFormatList list;
   ffestt_formatlist_kill(list);

   The tokens on the list are killed.  */

void
ffestt_formatlist_kill (ffesttFormatList list)
{
  ffesttFormatList next;

  /* Always kill from the very top on down. */

  while (list->u.root.parent != NULL)
    list = list->u.root.parent->next;

  /* Kill first token for this list. */

  if (list->t != NULL)
    ffelex_token_kill (list->t);

  /* Kill each item in this list. */

  for (next = list->next; next != list; next = next->next)
    {
      ffelex_token_kill (next->t);
      switch (next->type)
	{
	case FFESTP_formattypeI:
	case FFESTP_formattypeB:
	case FFESTP_formattypeO:
	case FFESTP_formattypeZ:
	case FFESTP_formattypeF:
	case FFESTP_formattypeE:
	case FFESTP_formattypeEN:
	case FFESTP_formattypeG:
	case FFESTP_formattypeL:
	case FFESTP_formattypeA:
	case FFESTP_formattypeD:
	  if (next->u.R1005.R1004.t != NULL)
	    ffelex_token_kill (next->u.R1005.R1004.t);
	  if (next->u.R1005.R1006.t != NULL)
	    ffelex_token_kill (next->u.R1005.R1006.t);
	  if (next->u.R1005.R1007_or_R1008.t != NULL)
	    ffelex_token_kill (next->u.R1005.R1007_or_R1008.t);
	  if (next->u.R1005.R1009.t != NULL)
	    ffelex_token_kill (next->u.R1005.R1009.t);
	  break;

	case FFESTP_formattypeQ:
	case FFESTP_formattypeDOLLAR:
	case FFESTP_formattypeP:
	case FFESTP_formattypeT:
	case FFESTP_formattypeTL:
	case FFESTP_formattypeTR:
	case FFESTP_formattypeX:
	case FFESTP_formattypeS:
	case FFESTP_formattypeSP:
	case FFESTP_formattypeSS:
	case FFESTP_formattypeBN:
	case FFESTP_formattypeBZ:
	case FFESTP_formattypeSLASH:
	case FFESTP_formattypeCOLON:
	  if (next->u.R1010.val.t != NULL)
	    ffelex_token_kill (next->u.R1010.val.t);
	  break;

	case FFESTP_formattypeR1016:
	  break;		/* Nothing more to do. */

	case FFESTP_formattypeFORMAT:
	  if (next->u.R1003D.R1004.t != NULL)
	    ffelex_token_kill (next->u.R1003D.R1004.t);
	  next->u.R1003D.format->u.root.parent = NULL;	/* Parent already dying. */
	  ffestt_formatlist_kill (next->u.R1003D.format);
	  break;

	default:
	  assert (FALSE);
	}
    }
}

/* ffestt_implist_append -- Append token pair to list of token pairs

   ffesttImpList list;
   ffelexToken t;
   ffestt_implist_append(list,start_token,end_token);

   list must have already been created by ffestt_implist_create.  The
   list is allocated out of the scratch pool.  The tokens are consumed.	 */

void
ffestt_implist_append (ffesttImpList list, ffelexToken first, ffelexToken last)
{
  ffesttImpList new;

  new = (ffesttImpList) malloc_new_kp (ffesta_scratch_pool,
				       "FFEST token list", sizeof (*new));
  new->next = list->previous->next;
  new->previous = list->previous;
  new->next->previous = new;
  new->previous->next = new;
  new->first = first;
  new->last = last;
}

/* ffestt_implist_create -- Create new list of token pairs

   ffesttImpList list;
   list = ffestt_implist_create();

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

ffesttImpList
ffestt_implist_create ()
{
  ffesttImpList new;

  new = (ffesttImpList) malloc_new_kp (ffesta_scratch_pool,
				       "FFEST token list root",
				       sizeof (*new));
  new->next = new->previous = new;
  new->first = NULL;
  new->last = NULL;
  return new;
}

/* ffestt_implist_drive -- Drive list of token pairs into function

   ffesttImpList list;
   void fn(ffelexToken first,ffelexToken last);
   ffestt_implist_drive(list,fn);

   The token pairs in the list are passed to the function one pair at a time.  */

void
ffestt_implist_drive (ffesttImpList list, void (*fn) ())
{
  ffesttImpList next;

  if (list == NULL)
    return;

  for (next = list->next; next != list; next = next->next)
    {
      (*fn) (next->first, next->last);
    }
}

/* ffestt_implist_dump -- Dump list of token pairs

   ffesttImpList list;
   ffestt_implist_dump(list);

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

#if FFECOM_targetCURRENT == FFECOM_targetFFE
void
ffestt_implist_dump (ffesttImpList list)
{
  ffesttImpList next;

  for (next = list->next; next != list; next = next->next)
    {
      if (next != list->next)
	fputc (',', dmpout);
      assert (ffelex_token_type (next->first) == FFELEX_typeNAME);
      fputs (ffelex_token_text (next->first), dmpout);
      if (next->last != NULL)
	{
	  fputc ('-', dmpout);
	  assert (ffelex_token_type (next->last) == FFELEX_typeNAME);
	  fputs (ffelex_token_text (next->last), dmpout);
	}
    }
}
#endif

/* ffestt_implist_kill -- Kill list of token pairs

   ffesttImpList list;
   ffestt_implist_kill(list);

   The tokens on the list are killed.  */

void
ffestt_implist_kill (ffesttImpList list)
{
  ffesttImpList next;

  for (next = list->next; next != list; next = next->next)
    {
      ffelex_token_kill (next->first);
      if (next->last != NULL)
	ffelex_token_kill (next->last);
    }
}

/* ffestt_tokenlist_append -- Append token to list of tokens

   ffesttTokenList tl;
   ffelexToken t;
   ffestt_tokenlist_append(tl,t);

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

void
ffestt_tokenlist_append (ffesttTokenList tl, ffelexToken t)
{
  ffesttTokenItem ti;

  ti = (ffesttTokenItem) malloc_new_kp (ffesta_scratch_pool,
					"FFEST token item", sizeof (*ti));
  ti->next = (ffesttTokenItem) &tl->first;
  ti->previous = tl->last;
  ti->next->previous = ti;
  ti->previous->next = ti;
  ti->t = t;
  ++tl->count;
}

/* ffestt_tokenlist_create -- Create new list of tokens

   ffesttTokenList tl;
   tl = ffestt_tokenlist_create();

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

ffesttTokenList
ffestt_tokenlist_create ()
{
  ffesttTokenList tl;

  tl = (ffesttTokenList) malloc_new_kp (ffesta_scratch_pool,
					"FFEST token list", sizeof (*tl));
  tl->first = tl->last = (ffesttTokenItem) &tl->first;
  tl->count = 0;
  return tl;
}

/* ffestt_tokenlist_drive -- Drive list of tokens

   ffesttTokenList tl;
   void fn(ffelexToken t);
   ffestt_tokenlist_drive(tl,fn);

   The tokens in the list are passed to the given function.  */

void
ffestt_tokenlist_drive (ffesttTokenList tl, void (*fn) ())
{
  ffesttTokenItem ti;

  if (tl == NULL)
    return;

  for (ti = tl->first; ti != (ffesttTokenItem) &tl->first; ti = ti->next)
    {
      (*fn) (ti->t);
    }
}

/* ffestt_tokenlist_dump -- Dump list of tokens

   ffesttTokenList tl;
   ffestt_tokenlist_dump(tl);

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

#if FFECOM_targetCURRENT == FFECOM_targetFFE
void
ffestt_tokenlist_dump (ffesttTokenList tl)
{
  ffesttTokenItem ti;

  for (ti = tl->first; ti != (ffesttTokenItem) &tl->first; ti = ti->next)
    {
      if (ti != tl->first)
	fputc (',', dmpout);
      switch (ffelex_token_type (ti->t))
	{
	case FFELEX_typeNUMBER:
	case FFELEX_typeNAME:
	case FFELEX_typeNAMES:
	  fputs (ffelex_token_text (ti->t), dmpout);
	  break;

	case FFELEX_typeASTERISK:
	  fputc ('*', dmpout);
	  break;

	default:
	  assert (FALSE);
	  fputc ('?', dmpout);
	  break;
	}
    }
}
#endif

/* ffestt_tokenlist_handle -- Handle list of tokens

   ffesttTokenList tl;
   ffelexHandler handler;
   handler = ffestt_tokenlist_handle(tl,handler);

   The tokens in the list are passed to the handler(s).	 */

ffelexHandler
ffestt_tokenlist_handle (ffesttTokenList tl, ffelexHandler handler)
{
  ffesttTokenItem ti;

  for (ti = tl->first; ti != (ffesttTokenItem) &tl->first; ti = ti->next)
    handler = (ffelexHandler) (*handler) (ti->t);

  return (ffelexHandler) handler;
}

/* ffestt_tokenlist_kill -- Kill list of tokens

   ffesttTokenList tl;
   ffestt_tokenlist_kill(tl);

   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_tokenlist_kill (ffesttTokenList tl)
{
  ffesttTokenItem ti;

  for (ti = tl->first; ti != (ffesttTokenItem) &tl->first; ti = ti->next)
    {
      ffelex_token_kill (ti->t);
    }
}