contrib/gcc-3.4/gcc/f/stt.c

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