gcc/f/stt.c

   1 /* stt.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1997 Free Software Foundation, Inc.
   3    Contributed by James Craig Burley.
   4
   5 This file is part of GNU Fortran.
   6
   7 GNU Fortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2, or (at your option)
  10 any later version.
  11
  12 GNU Fortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GNU Fortran; see the file COPYING.  If not, write to
  19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, USA.
  21
  22    Related Modules:
  23       None
  24
  25    Description:
  26       Manages lists of tokens and related info for parsing.
  27
  28    Modifications:
  29 */
  30
  31 /* Include files. */
  32
  33 #include "proj.h"
  34 #include "stt.h"
  35 #include "bld.h"
  36 #include "expr.h"
  37 #include "info.h"
  38 #include "lex.h"
  39 #include "malloc.h"
  40 #include "sta.h"
  41 #include "stp.h"
  42
  43 /* Externals defined here. */
  44
  45
  46 /* Simple definitions and enumerations. */
  47
  48
  49 /* Internal typedefs. */
  50
  51
  52 /* Private include files. */
  53
  54
  55 /* Internal structure definitions. */
  56
  57
  58 /* Static objects accessed by functions in this module. */
  59
  60
  61 /* Static functions (internal). */
  62
  63
  64 /* Internal macros. */
  65 \f
  66
  67 /* ffestt_caselist_append -- Append case to list of cases
  68
  69    ffesttCaseList list;
  70    ffelexToken t;
  71    ffestt_caselist_append(list,range,case1,case2,t);
  72
  73    list must have already been created by ffestt_caselist_create.  The
  74    list is allocated out of the scratch pool.  The token is consumed.  */
  75
  76 void
  77 ffestt_caselist_append (ffesttCaseList list, bool range, ffebld case1,
  78                         ffebld case2, ffelexToken t)
  79 {
  80   ffesttCaseList new;
  81
  82   new = (ffesttCaseList) malloc_new_kp (ffesta_scratch_pool,
  83                                         "FFEST case list", sizeof (*new));
  84   new->next = list->previous->next;
  85   new->previous = list->previous;
  86   new->next->previous = new;
  87   new->previous->next = new;
  88   new->expr1 = case1;
  89   new->expr2 = case2;
  90   new->range = range;
  91   new->t = t;
  92 }
  93
  94 /* ffestt_caselist_create -- Create new list of cases
  95
  96    ffesttCaseList list;
  97    list = ffestt_caselist_create();
  98
  99    The list is allocated out of the scratch pool.  */
 100
 101 ffesttCaseList
 102 ffestt_caselist_create ()
 103 {
 104   ffesttCaseList new;
 105
 106   new = (ffesttCaseList) malloc_new_kp (ffesta_scratch_pool,
 107                                         "FFEST case list root",
 108                                         sizeof (*new));
 109   new->next = new->previous = new;
 110   new->t = NULL;
 111   new->expr1 = NULL;
 112   new->expr2 = NULL;
 113   new->range = FALSE;
 114   return new;
 115 }
 116
 117 /* ffestt_caselist_kill -- Kill list of cases
 118
 119    ffesttCaseList list;
 120    ffestt_caselist_kill(list);
 121
 122    The tokens on the list are killed.
 123
 124    02-Mar-90  JCB  1.1
 125       Don't kill the list itself or change it, since it will be trashed when
 126       ffesta_scratch_pool is killed anyway, so kill only the lex tokens.  */
 127
 128 void
 129 ffestt_caselist_kill (ffesttCaseList list)
 130 {
 131   ffesttCaseList next;
 132
 133   for (next = list->next; next != list; next = next->next)
 134     {
 135       ffelex_token_kill (next->t);
 136     }
 137 }
 138
 139 /* ffestt_dimlist_append -- Append dim to list of dims
 140
 141    ffesttDimList list;
 142    ffelexToken t;
 143    ffestt_dimlist_append(list,lower,upper,t);
 144
 145    list must have already been created by ffestt_dimlist_create.  The
 146    list is allocated out of the scratch pool.  The token is consumed.  */
 147
 148 void
 149 ffestt_dimlist_append (ffesttDimList list, ffebld lower, ffebld upper,
 150                        ffelexToken t)
 151 {
 152   ffesttDimList new;
 153
 154   new = (ffesttDimList) malloc_new_kp (ffesta_scratch_pool,
 155                                        "FFEST dim list", sizeof (*new));
 156   new->next = list->previous->next;
 157   new->previous = list->previous;
 158   new->next->previous = new;
 159   new->previous->next = new;
 160   new->lower = lower;
 161   new->upper = upper;
 162   new->t = t;
 163 }
 164
 165 /* Convert list of dims into ffebld format.
 166
 167    ffesttDimList list;
 168    ffeinfoRank rank;
 169    ffebld array_size;
 170    ffebld extents;
 171    ffestt_dimlist_as_expr (list, &rank, &array_size, &extents);
 172
 173    The dims in the list are converted to a list of ITEMs; the rank of the
 174    array, an expression representing the array size, a list of extent
 175    expressions, and the list of ITEMs are returned.
 176
 177    If is_ugly_assumed, treat a final dimension with no lower bound
 178    and an upper bound of 1 as a * bound.  */
 179
 180 ffebld
 181 ffestt_dimlist_as_expr (ffesttDimList list, ffeinfoRank *rank,
 182                         ffebld *array_size, ffebld *extents,
 183                         bool is_ugly_assumed)
 184 {
 185   ffesttDimList next;
 186   ffebld expr;
 187   ffebld as;
 188   ffebld ex;                    /* List of extents. */
 189   ffebld ext;                   /* Extent of a given dimension. */
 190   ffebldListBottom bottom;
 191   ffeinfoRank r;
 192   ffeinfoKindtype nkt;
 193   ffetargetIntegerDefault low;
 194   ffetargetIntegerDefault high;
 195   bool zero = FALSE;            /* Zero-size array. */
 196   bool any = FALSE;
 197   bool star = FALSE;            /* Adjustable array. */
 198
 199   assert (list != NULL);
 200
 201   r = 0;
 202   ffebld_init_list (&expr, &bottom);
 203   for (next = list->next; next != list; next = next->next)
 204     {
 205       ++r;
 206       if (((next->lower == NULL)
 207            || (ffebld_op (next->lower) == FFEBLD_opCONTER))
 208           && (ffebld_op (next->upper) == FFEBLD_opCONTER))
 209         {
 210           if (next->lower == NULL)
 211             low = 1;
 212           else
 213             low = ffebld_constant_integerdefault (ffebld_conter (next->lower));
 214           high = ffebld_constant_integerdefault (ffebld_conter (next->upper));
 215           if (low
 216               > high)
 217             zero = TRUE;
 218           if ((next->next == list)
 219               && is_ugly_assumed
 220               && (next->lower == NULL)
 221               && (high == 1)
 222               && (ffebld_conter_orig (next->upper) == NULL))
 223             {
 224               star = TRUE;
 225               ffebld_append_item (&bottom,
 226                                   ffebld_new_bounds (NULL, ffebld_new_star ()));
 227               continue;
 228             }
 229         }
 230       else if (((next->lower != NULL)
 231                 && (ffebld_op (next->lower) == FFEBLD_opANY))
 232                || (ffebld_op (next->upper) == FFEBLD_opANY))
 233         any = TRUE;
 234       else if (ffebld_op (next->upper) == FFEBLD_opSTAR)
 235         star = TRUE;
 236       ffebld_append_item (&bottom,
 237                           ffebld_new_bounds (next->lower, next->upper));
 238     }
 239   ffebld_end_list (&bottom);
 240
 241   if (zero)
 242     {
 243       as = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
 244       ffebld_set_info (as, ffeinfo_new
 245                        (FFEINFO_basictypeINTEGER,
 246                         FFEINFO_kindtypeINTEGERDEFAULT,
 247                         0,
 248                         FFEINFO_kindENTITY,
 249                         FFEINFO_whereCONSTANT,
 250                         FFETARGET_charactersizeNONE));
 251       ex = NULL;
 252     }
 253   else if (any)
 254     {
 255       as = ffebld_new_any ();
 256       ffebld_set_info (as, ffeinfo_new_any ());
 257       ex = ffebld_copy (as);
 258     }
 259   else if (star)
 260     {
 261       as = ffebld_new_star ();
 262       ex = ffebld_new_star ();  /* ~~Should really be list as below. */
 263     }
 264   else
 265     {
 266       as = NULL;
 267       ffebld_init_list (&ex, &bottom);
 268       for (next = list->next; next != list; next = next->next)
 269         {
 270           if ((next->lower == NULL)
 271               || ((ffebld_op (next->lower) == FFEBLD_opCONTER)
 272                   && (ffebld_constant_integerdefault (ffebld_conter
 273                                                       (next->lower)) == 1)))
 274             ext = ffebld_copy (next->upper);
 275           else
 276             {
 277               ext = ffebld_new_subtract (next->upper, next->lower);
 278               nkt
 279                 = ffeinfo_kindtype_max (FFEINFO_basictypeINTEGER,
 280                                         ffeinfo_kindtype (ffebld_info
 281                                                           (next->lower)),
 282                                         ffeinfo_kindtype (ffebld_info
 283                                                           (next->upper)));
 284               ffebld_set_info (ext,
 285                                ffeinfo_new (FFEINFO_basictypeINTEGER,
 286                                             nkt,
 287                                             0,
 288                                             FFEINFO_kindENTITY,
 289                                             ((ffebld_op (ffebld_left (ext))
 290                                               == FFEBLD_opCONTER)
 291                                              && (ffebld_op (ffebld_right
 292                                                             (ext))
 293                                                  == FFEBLD_opCONTER))
 294                                             ? FFEINFO_whereCONSTANT
 295                                             : FFEINFO_whereFLEETING,
 296                                             FFETARGET_charactersizeNONE));
 297               ffebld_set_left (ext,
 298                                ffeexpr_convert_expr (ffebld_left (ext),
 299                                                      next->t, ext, next->t,
 300                                                      FFEEXPR_contextLET));
 301               ffebld_set_right (ext,
 302                                 ffeexpr_convert_expr (ffebld_right (ext),
 303                                                       next->t, ext,
 304                                                       next->t,
 305                                                       FFEEXPR_contextLET));
 306               ext = ffeexpr_collapse_subtract (ext, next->t);
 307
 308               nkt
 309                 = ffeinfo_kindtype_max (FFEINFO_basictypeINTEGER,
 310                                         ffeinfo_kindtype (ffebld_info (ext)),
 311                                         FFEINFO_kindtypeINTEGERDEFAULT);
 312               ext
 313                 = ffebld_new_add (ext,
 314                                   ffebld_new_conter
 315                                   (ffebld_constant_new_integerdefault_val
 316                                    (1)));
 317               ffebld_set_info (ffebld_right (ext), ffeinfo_new
 318                                (FFEINFO_basictypeINTEGER,
 319                                 FFEINFO_kindtypeINTEGERDEFAULT,
 320                                 0,
 321                                 FFEINFO_kindENTITY,
 322                                 FFEINFO_whereCONSTANT,
 323                                 FFETARGET_charactersizeNONE));
 324               ffebld_set_info (ext,
 325                                ffeinfo_new (FFEINFO_basictypeINTEGER,
 326                                             nkt, 0, FFEINFO_kindENTITY,
 327                                             (ffebld_op (ffebld_left (ext))
 328                                              == FFEBLD_opCONTER)
 329                                             ? FFEINFO_whereCONSTANT
 330                                             : FFEINFO_whereFLEETING,
 331                                             FFETARGET_charactersizeNONE));
 332               ffebld_set_left (ext,
 333                                ffeexpr_convert_expr (ffebld_left (ext),
 334                                                      next->t, ext,
 335                                                      next->t,
 336                                                      FFEEXPR_contextLET));
 337               ffebld_set_right (ext,
 338                                 ffeexpr_convert_expr (ffebld_right (ext),
 339                                                       next->t, ext,
 340                                                       next->t,
 341                                                       FFEEXPR_contextLET));
 342               ext = ffeexpr_collapse_add (ext, next->t);
 343             }
 344           ffebld_append_item (&bottom, ext);
 345           if (as == NULL)
 346             as = ext;
 347           else
 348             {
 349               nkt
 350                 = ffeinfo_kindtype_max (FFEINFO_basictypeINTEGER,
 351                                         ffeinfo_kindtype (ffebld_info (as)),
 352                                       ffeinfo_kindtype (ffebld_info (ext)));
 353               as = ffebld_new_multiply (as, ext);
 354               ffebld_set_info (as,
 355                                ffeinfo_new (FFEINFO_basictypeINTEGER,
 356                                             nkt, 0, FFEINFO_kindENTITY,
 357                                             ((ffebld_op (ffebld_left (as))
 358                                               == FFEBLD_opCONTER)
 359                                              && (ffebld_op (ffebld_right
 360                                                             (as))
 361                                                  == FFEBLD_opCONTER))
 362                                             ? FFEINFO_whereCONSTANT
 363                                             : FFEINFO_whereFLEETING,
 364                                             FFETARGET_charactersizeNONE));
 365               ffebld_set_left (as,
 366                                ffeexpr_convert_expr (ffebld_left (as),
 367                                                      next->t, as, next->t,
 368                                                      FFEEXPR_contextLET));
 369               ffebld_set_right (as,
 370                                 ffeexpr_convert_expr (ffebld_right (as),
 371                                                       next->t, as,
 372                                                       next->t,
 373                                                       FFEEXPR_contextLET));
 374               as = ffeexpr_collapse_multiply (as, next->t);
 375             }
 376         }
 377       ffebld_end_list (&bottom);
 378       as = ffeexpr_convert (as, list->next->t, NULL,
 379                             FFEINFO_basictypeINTEGER,
 380                             FFEINFO_kindtypeINTEGERDEFAULT, 0,
 381                             FFETARGET_charactersizeNONE,
 382                             FFEEXPR_contextLET);
 383     }
 384
 385   *rank = r;
 386   *array_size = as;
 387   *extents = ex;
 388   return expr;
 389 }
 390
 391 /* ffestt_dimlist_create -- Create new list of dims
 392
 393    ffesttDimList list;
 394    list = ffestt_dimlist_create();
 395
 396    The list is allocated out of the scratch pool.  */
 397
 398 ffesttDimList
 399 ffestt_dimlist_create ()
 400 {
 401   ffesttDimList new;
 402
 403   new = (ffesttDimList) malloc_new_kp (ffesta_scratch_pool,
 404                                        "FFEST dim list root", sizeof (*new));
 405   new->next = new->previous = new;
 406   new->t = NULL;
 407   new->lower = NULL;
 408   new->upper = NULL;
 409   return new;
 410 }
 411
 412 /* ffestt_dimlist_kill -- Kill list of dims
 413
 414    ffesttDimList list;
 415    ffestt_dimlist_kill(list);
 416
 417    The tokens on the list are killed.  */
 418
 419 void
 420 ffestt_dimlist_kill (ffesttDimList list)
 421 {
 422   ffesttDimList next;
 423
 424   for (next = list->next; next != list; next = next->next)
 425     {
 426       ffelex_token_kill (next->t);
 427     }
 428 }
 429
 430 /* Determine type of list of dimensions.
 431
 432    Return KNOWN for all-constant bounds, ADJUSTABLE for constant
 433    and variable but no * bounds, ASSUMED for constant and * but
 434    not variable bounds, ADJUSTABLEASSUMED for constant and variable
 435    and * bounds.
 436
 437    If is_ugly_assumed, treat a final dimension with no lower bound
 438    and an upper bound of 1 as a * bound.  */
 439
 440 ffestpDimtype
 441 ffestt_dimlist_type (ffesttDimList list, bool is_ugly_assumed)
 442 {
 443   ffesttDimList next;
 444   ffestpDimtype type;
 445
 446   if (list == NULL)
 447     return FFESTP_dimtypeNONE;
 448
 449   type = FFESTP_dimtypeKNOWN;
 450   for (next = list->next; next != list; next = next->next)
 451     {
 452       bool ugly_assumed = FALSE;
 453
 454       if ((next->next == list)
 455           && is_ugly_assumed
 456           && (next->lower == NULL)
 457           && (next->upper != NULL)
 458           && (ffebld_op (next->upper) == FFEBLD_opCONTER)
 459           && (ffebld_constant_integerdefault (ffebld_conter (next->upper))
 460               == 1)
 461           && (ffebld_conter_orig (next->upper) == NULL))
 462         ugly_assumed = TRUE;
 463
 464       if (next->lower != NULL)
 465         {
 466           if (ffebld_op (next->lower) != FFEBLD_opCONTER)
 467             {
 468               if (type == FFESTP_dimtypeASSUMED)
 469                 type = FFESTP_dimtypeADJUSTABLEASSUMED;
 470               else
 471                 type = FFESTP_dimtypeADJUSTABLE;
 472             }
 473         }
 474       if (next->upper != NULL)
 475         {
 476           if (ugly_assumed
 477               || (ffebld_op (next->upper) == FFEBLD_opSTAR))
 478             {
 479               if (type == FFESTP_dimtypeADJUSTABLE)
 480                 type = FFESTP_dimtypeADJUSTABLEASSUMED;
 481               else
 482                 type = FFESTP_dimtypeASSUMED;
 483             }
 484           else if (ffebld_op (next->upper) != FFEBLD_opCONTER)
 485             type = FFESTP_dimtypeADJUSTABLE;
 486         }
 487     }
 488
 489   return type;
 490 }
 491
 492 /* ffestt_exprlist_append -- Append expr to list of exprs
 493
 494    ffesttExprList list;
 495    ffelexToken t;
 496    ffestt_exprlist_append(list,expr,t);
 497
 498    list must have already been created by ffestt_exprlist_create.  The
 499    list is allocated out of the scratch pool.  The token is consumed.  */
 500
 501 void
 502 ffestt_exprlist_append (ffesttExprList list, ffebld expr, ffelexToken t)
 503 {
 504   ffesttExprList new;
 505
 506   new = (ffesttExprList) malloc_new_kp (ffesta_scratch_pool,
 507                                         "FFEST expr list", sizeof (*new));
 508   new->next = list->previous->next;
 509   new->previous = list->previous;
 510   new->next->previous = new;
 511   new->previous->next = new;
 512   new->expr = expr;
 513   new->t = t;
 514 }
 515
 516 /* ffestt_exprlist_create -- Create new list of exprs
 517
 518    ffesttExprList list;
 519    list = ffestt_exprlist_create();
 520
 521    The list is allocated out of the scratch pool.  */
 522
 523 ffesttExprList
 524 ffestt_exprlist_create ()
 525 {
 526   ffesttExprList new;
 527
 528   new = (ffesttExprList) malloc_new_kp (ffesta_scratch_pool,
 529                                      "FFEST expr list root", sizeof (*new));
 530   new->next = new->previous = new;
 531   new->expr = NULL;
 532   new->t = NULL;
 533   return new;
 534 }
 535
 536 /* ffestt_exprlist_drive -- Drive list of token pairs into function
 537
 538    ffesttExprList list;
 539    void fn(ffebld expr,ffelexToken t);
 540    ffestt_exprlist_drive(list,fn);
 541
 542    The expr/token pairs in the list are passed to the function one pair
 543    at a time.  */
 544
 545 void
 546 ffestt_exprlist_drive (ffesttExprList list, void (*fn) (ffebld, ffelexToken))
 547 {
 548   ffesttExprList next;
 549
 550   if (list == NULL)
 551     return;
 552
 553   for (next = list->next; next != list; next = next->next)
 554     {
 555       (*fn) (next->expr, next->t);
 556     }
 557 }
 558
 559 /* ffestt_exprlist_kill -- Kill list of exprs
 560
 561    ffesttExprList list;
 562    ffestt_exprlist_kill(list);
 563
 564    The tokens on the list are killed.
 565
 566    02-Mar-90  JCB  1.1
 567       Don't kill the list itself or change it, since it will be trashed when
 568       ffesta_scratch_pool is killed anyway, so kill only the lex tokens.  */
 569
 570 void
 571 ffestt_exprlist_kill (ffesttExprList list)
 572 {
 573   ffesttExprList next;
 574
 575   for (next = list->next; next != list; next = next->next)
 576     {
 577       ffelex_token_kill (next->t);
 578     }
 579 }
 580
 581 /* ffestt_formatlist_append -- Append null format to list of formats
 582
 583    ffesttFormatList list, new;
 584    new = ffestt_formatlist_append(list);
 585
 586    list must have already been created by ffestt_formatlist_create.  The
 587    new item is allocated out of the scratch pool.  The caller must initialize
 588    it appropriately.  */
 589
 590 ffesttFormatList
 591 ffestt_formatlist_append (ffesttFormatList list)
 592 {
 593   ffesttFormatList new;
 594
 595   new = (ffesttFormatList) malloc_new_kp (ffesta_scratch_pool,
 596                                         "FFEST format list", sizeof (*new));
 597   new->next = list->previous->next;
 598   new->previous = list->previous;
 599   new->next->previous = new;
 600   new->previous->next = new;
 601   return new;
 602 }
 603
 604 /* ffestt_formatlist_create -- Create new list of formats
 605
 606    ffesttFormatList list;
 607    list = ffestt_formatlist_create(NULL);
 608
 609    The list is allocated out of the scratch pool.  */
 610
 611 ffesttFormatList
 612 ffestt_formatlist_create (ffesttFormatList parent, ffelexToken t)
 613 {
 614   ffesttFormatList new;
 615
 616   new = (ffesttFormatList) malloc_new_kp (ffesta_scratch_pool,
 617                                    "FFEST format list root", sizeof (*new));
 618   new->next = new->previous = new;
 619   new->type = FFESTP_formattypeNone;
 620   new->t = t;
 621   new->u.root.parent = parent;
 622   return new;
 623 }
 624
 625 /* ffestt_formatlist_kill -- Kill tokens on list of formats
 626
 627    ffesttFormatList list;
 628    ffestt_formatlist_kill(list);
 629
 630    The tokens on the list are killed.  */
 631
 632 void
 633 ffestt_formatlist_kill (ffesttFormatList list)
 634 {
 635   ffesttFormatList next;
 636
 637   /* Always kill from the very top on down. */
 638
 639   while (list->u.root.parent != NULL)
 640     list = list->u.root.parent->next;
 641
 642   /* Kill first token for this list. */
 643
 644   if (list->t != NULL)
 645     ffelex_token_kill (list->t);
 646
 647   /* Kill each item in this list. */
 648
 649   for (next = list->next; next != list; next = next->next)
 650     {
 651       ffelex_token_kill (next->t);
 652       switch (next->type)
 653         {
 654         case FFESTP_formattypeI:
 655         case FFESTP_formattypeB:
 656         case FFESTP_formattypeO:
 657         case FFESTP_formattypeZ:
 658         case FFESTP_formattypeF:
 659         case FFESTP_formattypeE:
 660         case FFESTP_formattypeEN:
 661         case FFESTP_formattypeG:
 662         case FFESTP_formattypeL:
 663         case FFESTP_formattypeA:
 664         case FFESTP_formattypeD:
 665           if (next->u.R1005.R1004.t != NULL)
 666             ffelex_token_kill (next->u.R1005.R1004.t);
 667           if (next->u.R1005.R1006.t != NULL)
 668             ffelex_token_kill (next->u.R1005.R1006.t);
 669           if (next->u.R1005.R1007_or_R1008.t != NULL)
 670             ffelex_token_kill (next->u.R1005.R1007_or_R1008.t);
 671           if (next->u.R1005.R1009.t != NULL)
 672             ffelex_token_kill (next->u.R1005.R1009.t);
 673           break;
 674
 675         case FFESTP_formattypeQ:
 676         case FFESTP_formattypeDOLLAR:
 677         case FFESTP_formattypeP:
 678         case FFESTP_formattypeT:
 679         case FFESTP_formattypeTL:
 680         case FFESTP_formattypeTR:
 681         case FFESTP_formattypeX:
 682         case FFESTP_formattypeS:
 683         case FFESTP_formattypeSP:
 684         case FFESTP_formattypeSS:
 685         case FFESTP_formattypeBN:
 686         case FFESTP_formattypeBZ:
 687         case FFESTP_formattypeSLASH:
 688         case FFESTP_formattypeCOLON:
 689           if (next->u.R1010.val.t != NULL)
 690             ffelex_token_kill (next->u.R1010.val.t);
 691           break;
 692
 693         case FFESTP_formattypeR1016:
 694           break;                /* Nothing more to do. */
 695
 696         case FFESTP_formattypeFORMAT:
 697           if (next->u.R1003D.R1004.t != NULL)
 698             ffelex_token_kill (next->u.R1003D.R1004.t);
 699           next->u.R1003D.format->u.root.parent = NULL;  /* Parent already dying. */
 700           ffestt_formatlist_kill (next->u.R1003D.format);
 701           break;
 702
 703         default:
 704           assert (FALSE);
 705         }
 706     }
 707 }
 708
 709 /* ffestt_implist_append -- Append token pair to list of token pairs
 710
 711    ffesttImpList list;
 712    ffelexToken t;
 713    ffestt_implist_append(list,start_token,end_token);
 714
 715    list must have already been created by ffestt_implist_create.  The
 716    list is allocated out of the scratch pool.  The tokens are consumed.  */
 717
 718 void
 719 ffestt_implist_append (ffesttImpList list, ffelexToken first, ffelexToken last)
 720 {
 721   ffesttImpList new;
 722
 723   new = (ffesttImpList) malloc_new_kp (ffesta_scratch_pool,
 724                                        "FFEST token list", sizeof (*new));
 725   new->next = list->previous->next;
 726   new->previous = list->previous;
 727   new->next->previous = new;
 728   new->previous->next = new;
 729   new->first = first;
 730   new->last = last;
 731 }
 732
 733 /* ffestt_implist_create -- Create new list of token pairs
 734
 735    ffesttImpList list;
 736    list = ffestt_implist_create();
 737
 738    The list is allocated out of the scratch pool.  */
 739
 740 ffesttImpList
 741 ffestt_implist_create ()
 742 {
 743   ffesttImpList new;
 744
 745   new = (ffesttImpList) malloc_new_kp (ffesta_scratch_pool,
 746                                        "FFEST token list root",
 747                                        sizeof (*new));
 748   new->next = new->previous = new;
 749   new->first = NULL;
 750   new->last = NULL;
 751   return new;
 752 }
 753
 754 /* ffestt_implist_drive -- Drive list of token pairs into function
 755
 756    ffesttImpList list;
 757    void fn(ffelexToken first,ffelexToken last);
 758    ffestt_implist_drive(list,fn);
 759
 760    The token pairs in the list are passed to the function one pair at a time.  */
 761
 762 void
 763 ffestt_implist_drive (ffesttImpList list, void (*fn) (ffelexToken, ffelexToken))
 764 {
 765   ffesttImpList next;
 766
 767   if (list == NULL)
 768     return;
 769
 770   for (next = list->next; next != list; next = next->next)
 771     {
 772       (*fn) (next->first, next->last);
 773     }
 774 }
 775
 776 /* ffestt_implist_kill -- Kill list of token pairs
 777
 778    ffesttImpList list;
 779    ffestt_implist_kill(list);
 780
 781    The tokens on the list are killed.  */
 782
 783 void
 784 ffestt_implist_kill (ffesttImpList list)
 785 {
 786   ffesttImpList next;
 787
 788   for (next = list->next; next != list; next = next->next)
 789     {
 790       ffelex_token_kill (next->first);
 791       if (next->last != NULL)
 792         ffelex_token_kill (next->last);
 793     }
 794 }
 795
 796 /* ffestt_tokenlist_append -- Append token to list of tokens
 797
 798    ffesttTokenList tl;
 799    ffelexToken t;
 800    ffestt_tokenlist_append(tl,t);
 801
 802    tl must have already been created by ffestt_tokenlist_create.  The
 803    list is allocated out of the scratch pool.  The token is consumed.  */
 804
 805 void
 806 ffestt_tokenlist_append (ffesttTokenList tl, ffelexToken t)
 807 {
 808   ffesttTokenItem ti;
 809
 810   ti = (ffesttTokenItem) malloc_new_kp (ffesta_scratch_pool,
 811                                         "FFEST token item", sizeof (*ti));
 812   ti->next = (ffesttTokenItem) &tl->first;
 813   ti->previous = tl->last;
 814   ti->next->previous = ti;
 815   ti->previous->next = ti;
 816   ti->t = t;
 817   ++tl->count;
 818 }
 819
 820 /* ffestt_tokenlist_create -- Create new list of tokens
 821
 822    ffesttTokenList tl;
 823    tl = ffestt_tokenlist_create();
 824
 825    The list is allocated out of the scratch pool.  */
 826
 827 ffesttTokenList
 828 ffestt_tokenlist_create ()
 829 {
 830   ffesttTokenList tl;
 831
 832   tl = (ffesttTokenList) malloc_new_kp (ffesta_scratch_pool,
 833                                         "FFEST token list", sizeof (*tl));
 834   tl->first = tl->last = (ffesttTokenItem) &tl->first;
 835   tl->count = 0;
 836   return tl;
 837 }
 838
 839 /* ffestt_tokenlist_drive -- Drive list of tokens
 840
 841    ffesttTokenList tl;
 842    void fn(ffelexToken t);
 843    ffestt_tokenlist_drive(tl,fn);
 844
 845    The tokens in the list are passed to the given function.  */
 846
 847 void
 848 ffestt_tokenlist_drive (ffesttTokenList tl, void (*fn) (ffelexToken))
 849 {
 850   ffesttTokenItem ti;
 851
 852   if (tl == NULL)
 853     return;
 854
 855   for (ti = tl->first; ti != (ffesttTokenItem) &tl->first; ti = ti->next)
 856     {
 857       (*fn) (ti->t);
 858     }
 859 }
 860
 861 /* ffestt_tokenlist_handle -- Handle list of tokens
 862
 863    ffesttTokenList tl;
 864    ffelexHandler handler;
 865    handler = ffestt_tokenlist_handle(tl,handler);
 866
 867    The tokens in the list are passed to the handler(s).  */
 868
 869 ffelexHandler
 870 ffestt_tokenlist_handle (ffesttTokenList tl, ffelexHandler handler)
 871 {
 872   ffesttTokenItem ti;
 873
 874   for (ti = tl->first; ti != (ffesttTokenItem) &tl->first; ti = ti->next)
 875     handler = (ffelexHandler) (*handler) (ti->t);
 876
 877   return (ffelexHandler) handler;
 878 }
 879
 880 /* ffestt_tokenlist_kill -- Kill list of tokens
 881
 882    ffesttTokenList tl;
 883    ffestt_tokenlist_kill(tl);
 884
 885    The tokens on the list are killed.
 886
 887    02-Mar-90  JCB  1.1
 888       Don't kill the list itself or change it, since it will be trashed when
 889       ffesta_scratch_pool is killed anyway, so kill only the lex tokens.  */
 890
 891 void
 892 ffestt_tokenlist_kill (ffesttTokenList tl)
 893 {
 894   ffesttTokenItem ti;
 895
 896   for (ti = tl->first; ti != (ffesttTokenItem) &tl->first; ti = ti->next)
 897     {
 898       ffelex_token_kill (ti->t);
 899     }
 900 }