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