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