libgfortran/io/format.c

   1 /* Copyright (C) 2002-2024 Free Software Foundation, Inc.
   2    Contributed by Andy Vaught
   3    F2003 I/O support contributed by Jerry DeLisle
   4
   5 This file is part of the GNU Fortran runtime library (libgfortran).
   6
   7 Libgfortran 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 3, or (at your option)
  10 any later version.
  11
  12 Libgfortran 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 Under Section 7 of GPL version 3, you are granted additional
  18 permissions described in the GCC Runtime Library Exception, version
  19 3.1, as published by the Free Software Foundation.
  20
  21 You should have received a copy of the GNU General Public License and
  22 a copy of the GCC Runtime Library Exception along with this program;
  23 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  24 <http://www.gnu.org/licenses/>.  */
  25
  26
  27 /* format.c-- parse a FORMAT string into a binary format suitable for
  28    interpretation during I/O statements.  */
  29
  30 #include "io.h"
  31 #include "format.h"
  32 #include <string.h>
  33
  34
  35 static const fnode colon_node = { FMT_COLON, FMT_NONE, 0, NULL, NULL, {{ 0, 0, 0 }}, 0,
  36                                   NULL };
  37
  38 /* Error messages. */
  39
  40 static const char posint_required[] = "Positive integer required in format",
  41   period_required[] = "Period required in format",
  42   nonneg_required[] = "Nonnegative width required in format",
  43   unexpected_element[] = "Unexpected element '%c' in format\n",
  44   unexpected_end[] = "Unexpected end of format string",
  45   bad_string[] = "Unterminated character constant in format",
  46   bad_hollerith[] = "Hollerith constant extends past the end of the format",
  47   reversion_error[] = "Exhausted data descriptors in format",
  48   zero_width[] = "Zero width in format descriptor";
  49
  50 /* The following routines support caching format data from parsed format strings
  51    into a hash table.  This avoids repeatedly parsing duplicate format strings
  52    or format strings in I/O statements that are repeated in loops.  */
  53
  54
  55 /* Traverse the table and free all data.  */
  56
  57 void
  58 free_format_hash_table (gfc_unit *u)
  59 {
  60   size_t i;
  61
  62   /* free_format_data handles any NULL pointers.  */
  63   for (i = 0; i < FORMAT_HASH_SIZE; i++)
  64     {
  65       if (u->format_hash_table[i].hashed_fmt != NULL)
  66         {
  67           free_format_data (u->format_hash_table[i].hashed_fmt);
  68           free (u->format_hash_table[i].key);
  69         }
  70       u->format_hash_table[i].key = NULL;
  71       u->format_hash_table[i].key_len = 0;
  72       u->format_hash_table[i].hashed_fmt = NULL;
  73     }
  74 }
  75
  76 /* Traverse the format_data structure and reset the fnode counters.  */
  77
  78 static void
  79 reset_node (fnode *fn)
  80 {
  81   fnode *f;
  82
  83   fn->count = 0;
  84   fn->current = NULL;
  85
  86   if (fn->format != FMT_LPAREN)
  87     return;
  88
  89   for (f = fn->u.child; f; f = f->next)
  90     {
  91       if (f->format == FMT_RPAREN)
  92         break;
  93       reset_node (f);
  94     }
  95 }
  96
  97 static void
  98 reset_fnode_counters (st_parameter_dt *dtp)
  99 {
 100   fnode *f;
 101   format_data *fmt;
 102
 103   fmt = dtp->u.p.fmt;
 104
 105   /* Clear this pointer at the head so things start at the right place.  */
 106   fmt->array.array[0].current = NULL;
 107
 108   for (f = fmt->array.array[0].u.child; f; f = f->next)
 109     reset_node (f);
 110 }
 111
 112
 113 /* A simple hashing function to generate an index into the hash table.  */
 114
 115 static uint32_t
 116 format_hash (st_parameter_dt *dtp)
 117 {
 118   char *key;
 119   gfc_charlen_type key_len;
 120   uint32_t hash = 0;
 121   gfc_charlen_type i;
 122
 123   /* Hash the format string. Super simple, but what the heck!  */
 124   key = dtp->format;
 125   key_len = dtp->format_len;
 126   for (i = 0; i < key_len; i++)
 127     hash ^= key[i];
 128   hash &= (FORMAT_HASH_SIZE - 1);
 129   return hash;
 130 }
 131
 132
 133 static void
 134 save_parsed_format (st_parameter_dt *dtp)
 135 {
 136   uint32_t hash;
 137   gfc_unit *u;
 138
 139   hash = format_hash (dtp);
 140   u = dtp->u.p.current_unit;
 141
 142   /* Index into the hash table.  We are simply replacing whatever is there
 143      relying on probability.  */
 144   if (u->format_hash_table[hash].hashed_fmt != NULL)
 145     free_format_data (u->format_hash_table[hash].hashed_fmt);
 146   u->format_hash_table[hash].hashed_fmt = NULL;
 147
 148   free (u->format_hash_table[hash].key);
 149   u->format_hash_table[hash].key = dtp->format;
 150
 151   u->format_hash_table[hash].key_len = dtp->format_len;
 152   u->format_hash_table[hash].hashed_fmt = dtp->u.p.fmt;
 153 }
 154
 155
 156 static format_data *
 157 find_parsed_format (st_parameter_dt *dtp)
 158 {
 159   uint32_t hash;
 160   gfc_unit *u;
 161
 162   hash = format_hash (dtp);
 163   u = dtp->u.p.current_unit;
 164
 165   if (u->format_hash_table[hash].key != NULL)
 166     {
 167       /* See if it matches.  */
 168       if (u->format_hash_table[hash].key_len == dtp->format_len)
 169         {
 170           /* So far so good.  */
 171           if (strncmp (u->format_hash_table[hash].key,
 172               dtp->format, dtp->format_len) == 0)
 173             return u->format_hash_table[hash].hashed_fmt;
 174         }
 175     }
 176   return NULL;
 177 }
 178
 179
 180 /* next_char()-- Return the next character in the format string.
 181    Returns -1 when the string is done.  If the literal flag is set,
 182    spaces are significant, otherwise they are not. */
 183
 184 static int
 185 next_char (format_data *fmt, int literal)
 186 {
 187   int c;
 188
 189   do
 190     {
 191       if (fmt->format_string_len == 0)
 192         return -1;
 193
 194       fmt->format_string_len--;
 195       c = safe_toupper (*fmt->format_string++);
 196       fmt->error_element = c;
 197     }
 198   while ((c == ' ' || c == '\t') && !literal);
 199
 200   return c;
 201 }
 202
 203
 204 /* unget_char()-- Back up one character position. */
 205
 206 #define unget_char(fmt) \
 207   { fmt->format_string--; fmt->format_string_len++; }
 208
 209
 210 /* get_fnode()-- Allocate a new format node, inserting it into the
 211    current singly linked list.  These are initially allocated from the
 212    static buffer. */
 213
 214 static fnode *
 215 get_fnode (format_data *fmt, fnode **head, fnode **tail, format_token t)
 216 {
 217   fnode *f;
 218
 219   if (fmt->avail == &fmt->last->array[FARRAY_SIZE])
 220     {
 221       fmt->last->next = xmalloc (sizeof (fnode_array));
 222       fmt->last = fmt->last->next;
 223       fmt->last->next = NULL;
 224       fmt->avail = &fmt->last->array[0];
 225     }
 226   f = fmt->avail++;
 227   memset (f, '\0', sizeof (fnode));
 228   f->pushed = FMT_NONE;
 229
 230   if (*head == NULL)
 231     *head = *tail = f;
 232   else
 233     {
 234       (*tail)->next = f;
 235       *tail = f;
 236     }
 237
 238   f->format = t;
 239   f->repeat = -1;
 240   f->source = fmt->format_string;
 241   return f;
 242 }
 243
 244
 245 /* free_format()-- Free allocated format string.  */
 246 void
 247 free_format (st_parameter_dt *dtp)
 248 {
 249   if ((dtp->common.flags & IOPARM_DT_HAS_FORMAT) && dtp->format)
 250     {
 251       free (dtp->format);
 252       dtp->format = NULL;
 253     }
 254 }
 255
 256
 257 /* free_format_data()-- Free all allocated format data.  */
 258
 259 void
 260 free_format_data (format_data *fmt)
 261 {
 262   fnode_array *fa, *fa_next;
 263   fnode *fnp;
 264
 265   if (fmt == NULL)
 266     return;
 267
 268   /* Free vlist descriptors in the fnode_array if one was allocated.  */
 269   for (fnp = fmt->array.array; fnp < &fmt->array.array[FARRAY_SIZE] &&
 270        fnp->format != FMT_NONE; fnp++)
 271     if (fnp->format == FMT_DT)
 272         {
 273           free (GFC_DESCRIPTOR_DATA(fnp->u.udf.vlist));
 274           free (fnp->u.udf.vlist);
 275         }
 276
 277   for (fa = fmt->array.next; fa; fa = fa_next)
 278     {
 279       fa_next = fa->next;
 280       free (fa);
 281     }
 282
 283   free (fmt);
 284   fmt = NULL;
 285 }
 286
 287
 288 /* format_lex()-- Simple lexical analyzer for getting the next token
 289    in a FORMAT string.  We support a one-level token pushback in the
 290    fmt->saved_token variable. */
 291
 292 static format_token
 293 format_lex (format_data *fmt)
 294 {
 295   format_token token;
 296   int negative_flag;
 297   int c;
 298   char delim;
 299
 300   if (fmt->saved_token != FMT_NONE)
 301     {
 302       token = fmt->saved_token;
 303       fmt->saved_token = FMT_NONE;
 304       return token;
 305     }
 306
 307   negative_flag = 0;
 308   c = next_char (fmt, 0);
 309
 310   switch (c)
 311     {
 312     case '*':
 313        token = FMT_STAR;
 314        break;
 315
 316     case '(':
 317       token = FMT_LPAREN;
 318       break;
 319
 320     case ')':
 321       token = FMT_RPAREN;
 322       break;
 323
 324     case '-':
 325       negative_flag = 1;
 326       /* Fall Through */
 327
 328     case '+':
 329       c = next_char (fmt, 0);
 330       if (!safe_isdigit (c))
 331         {
 332           token = FMT_UNKNOWN;
 333           break;
 334         }
 335
 336       fmt->value = c - '0';
 337
 338       for (;;)
 339         {
 340           c = next_char (fmt, 0);
 341           if (!safe_isdigit (c))
 342             break;
 343
 344           fmt->value = 10 * fmt->value + c - '0';
 345         }
 346
 347       unget_char (fmt);
 348
 349       if (negative_flag)
 350         fmt->value = -fmt->value;
 351       token = FMT_SIGNED_INT;
 352       break;
 353
 354     case '0':
 355     case '1':
 356     case '2':
 357     case '3':
 358     case '4':
 359     case '5':
 360     case '6':
 361     case '7':
 362     case '8':
 363     case '9':
 364       fmt->value = c - '0';
 365
 366       for (;;)
 367         {
 368           c = next_char (fmt, 0);
 369           if (!safe_isdigit (c))
 370             break;
 371
 372           fmt->value = 10 * fmt->value + c - '0';
 373         }
 374
 375       unget_char (fmt);
 376       token = (fmt->value == 0) ? FMT_ZERO : FMT_POSINT;
 377       break;
 378
 379     case '.':
 380       token = FMT_PERIOD;
 381       break;
 382
 383     case ',':
 384       token = FMT_COMMA;
 385       break;
 386
 387     case ':':
 388       token = FMT_COLON;
 389       break;
 390
 391     case '/':
 392       token = FMT_SLASH;
 393       break;
 394
 395     case '$':
 396       token = FMT_DOLLAR;
 397       break;
 398
 399     case 'T':
 400       switch (next_char (fmt, 0))
 401         {
 402         case 'L':
 403           token = FMT_TL;
 404           break;
 405         case 'R':
 406           token = FMT_TR;
 407           break;
 408         default:
 409           token = FMT_T;
 410           unget_char (fmt);
 411           break;
 412         }
 413
 414       break;
 415
 416     case 'X':
 417       token = FMT_X;
 418       break;
 419
 420     case 'S':
 421       switch (next_char (fmt, 0))
 422         {
 423         case 'S':
 424           token = FMT_SS;
 425           break;
 426         case 'P':
 427           token = FMT_SP;
 428           break;
 429         default:
 430           token = FMT_S;
 431           unget_char (fmt);
 432           break;
 433         }
 434
 435       break;
 436
 437     case 'B':
 438       switch (next_char (fmt, 0))
 439         {
 440         case 'N':
 441           token = FMT_BN;
 442           break;
 443         case 'Z':
 444           token = FMT_BZ;
 445           break;
 446         default:
 447           token = FMT_B;
 448           unget_char (fmt);
 449           break;
 450         }
 451
 452       break;
 453
 454     case '\'':
 455     case '"':
 456       delim = c;
 457
 458       fmt->string = fmt->format_string;
 459       fmt->value = 0;           /* This is the length of the string */
 460
 461       for (;;)
 462         {
 463           c = next_char (fmt, 1);
 464           if (c == -1)
 465             {
 466               token = FMT_BADSTRING;
 467               fmt->error = bad_string;
 468               break;
 469             }
 470
 471           if (c == delim)
 472             {
 473               c = next_char (fmt, 1);
 474
 475               if (c == -1)
 476                 {
 477                   token = FMT_BADSTRING;
 478                   fmt->error = bad_string;
 479                   break;
 480                 }
 481
 482               if (c != delim)
 483                 {
 484                   unget_char (fmt);
 485                   token = FMT_STRING;
 486                   break;
 487                 }
 488             }
 489
 490           fmt->value++;
 491         }
 492
 493       break;
 494
 495     case 'P':
 496       token = FMT_P;
 497       break;
 498
 499     case 'I':
 500       token = FMT_I;
 501       break;
 502
 503     case 'O':
 504       token = FMT_O;
 505       break;
 506
 507     case 'Z':
 508       token = FMT_Z;
 509       break;
 510
 511     case 'F':
 512       token = FMT_F;
 513       break;
 514
 515     case 'E':
 516       switch (next_char (fmt, 0))
 517         {
 518         case 'N':
 519           token = FMT_EN;
 520           break;
 521         case 'S':
 522           token = FMT_ES;
 523           break;
 524         default:
 525           token = FMT_E;
 526           unget_char (fmt);
 527           break;
 528         }
 529       break;
 530
 531     case 'G':
 532       token = FMT_G;
 533       break;
 534
 535     case 'H':
 536       token = FMT_H;
 537       break;
 538
 539     case 'L':
 540       token = FMT_L;
 541       break;
 542
 543     case 'A':
 544       token = FMT_A;
 545       break;
 546
 547     case 'D':
 548       switch (next_char (fmt, 0))
 549         {
 550         case 'P':
 551           token = FMT_DP;
 552           break;
 553         case 'C':
 554           token = FMT_DC;
 555           break;
 556         case 'T':
 557           token = FMT_DT;
 558           break;
 559         default:
 560           token = FMT_D;
 561           unget_char (fmt);
 562           break;
 563         }
 564       break;
 565
 566     case 'R':
 567       switch (next_char (fmt, 0))
 568         {
 569         case 'C':
 570           token = FMT_RC;
 571           break;
 572         case 'D':
 573           token = FMT_RD;
 574           break;
 575         case 'N':
 576           token = FMT_RN;
 577           break;
 578         case 'P':
 579           token = FMT_RP;
 580           break;
 581         case 'U':
 582           token = FMT_RU;
 583           break;
 584         case 'Z':
 585           token = FMT_RZ;
 586           break;
 587         default:
 588           unget_char (fmt);
 589           token = FMT_UNKNOWN;
 590           break;
 591         }
 592       break;
 593
 594     case -1:
 595       token = FMT_END;
 596       break;
 597
 598     default:
 599       token = FMT_UNKNOWN;
 600       break;
 601     }
 602
 603   return token;
 604 }
 605
 606
 607 /* parse_format_list()-- Parse a format list.  Assumes that a left
 608    paren has already been seen.  Returns a list representing the
 609    parenthesis node which contains the rest of the list. */
 610
 611 static fnode *
 612 parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
 613 {
 614   fnode *head, *tail;
 615   format_token t, u, t2;
 616   int repeat;
 617   format_data *fmt = dtp->u.p.fmt;
 618   bool seen_data_desc = false;
 619   int standard;
 620
 621   head = tail = NULL;
 622
 623   /* Get the next format item */
 624  format_item:
 625   t = format_lex (fmt);
 626  format_item_1:
 627   switch (t)
 628     {
 629     case FMT_STAR:
 630       t = format_lex (fmt);
 631       if (t != FMT_LPAREN)
 632         {
 633           fmt->error = "Left parenthesis required after '*'";
 634           goto finished;
 635         }
 636       get_fnode (fmt, &head, &tail, FMT_LPAREN);
 637       tail->repeat = -2;  /* Signifies unlimited format.  */
 638       tail->u.child = parse_format_list (dtp, &seen_data_desc);
 639       *seen_dd = seen_data_desc;
 640       if (fmt->error != NULL)
 641         goto finished;
 642       if (!seen_data_desc)
 643         {
 644           fmt->error = "'*' requires at least one associated data descriptor";
 645           goto finished;
 646         }
 647       goto between_desc;
 648
 649     case FMT_POSINT:
 650       repeat = fmt->value;
 651
 652       t = format_lex (fmt);
 653       switch (t)
 654         {
 655         case FMT_LPAREN:
 656           get_fnode (fmt, &head, &tail, FMT_LPAREN);
 657           tail->repeat = repeat;
 658           tail->u.child = parse_format_list (dtp, &seen_data_desc);
 659           *seen_dd = seen_data_desc;
 660           if (fmt->error != NULL)
 661             goto finished;
 662
 663           goto between_desc;
 664
 665         case FMT_SLASH:
 666           get_fnode (fmt, &head, &tail, FMT_SLASH);
 667           tail->repeat = repeat;
 668           goto optional_comma;
 669
 670         case FMT_X:
 671           get_fnode (fmt, &head, &tail, FMT_X);
 672           tail->repeat = 1;
 673           tail->u.k = fmt->value;
 674           goto between_desc;
 675
 676         case FMT_P:
 677           goto p_descriptor;
 678
 679         default:
 680           goto data_desc;
 681         }
 682
 683     case FMT_LPAREN:
 684       get_fnode (fmt, &head, &tail, FMT_LPAREN);
 685       tail->repeat = 1;
 686       tail->u.child = parse_format_list (dtp, &seen_data_desc);
 687       *seen_dd = seen_data_desc;
 688       if (fmt->error != NULL)
 689         goto finished;
 690
 691       goto between_desc;
 692
 693     case FMT_SIGNED_INT:        /* Signed integer can only precede a P format.  */
 694     case FMT_ZERO:              /* Same for zero.  */
 695       t = format_lex (fmt);
 696       if (t != FMT_P)
 697         {
 698           fmt->error = "Expected P edit descriptor in format";
 699           goto finished;
 700         }
 701
 702     p_descriptor:
 703       get_fnode (fmt, &head, &tail, FMT_P);
 704       tail->u.k = fmt->value;
 705       tail->repeat = 1;
 706
 707       t = format_lex (fmt);
 708       if (t == FMT_F || t == FMT_EN || t == FMT_ES || t == FMT_D
 709           || t == FMT_G || t == FMT_E)
 710         {
 711           repeat = 1;
 712           goto data_desc;
 713         }
 714
 715       if (t != FMT_COMMA && t != FMT_RPAREN && t != FMT_SLASH
 716           && t != FMT_POSINT)
 717         {
 718           fmt->error = "Comma required after P descriptor";
 719           goto finished;
 720         }
 721
 722       fmt->saved_token = t;
 723       goto optional_comma;
 724
 725     case FMT_P:         /* P and X require a prior number */
 726       fmt->error = "P descriptor requires leading scale factor";
 727       goto finished;
 728
 729     case FMT_X:
 730 /*
 731    EXTENSION!
 732
 733    If we would be pedantic in the library, we would have to reject
 734    an X descriptor without an integer prefix:
 735
 736       fmt->error = "X descriptor requires leading space count";
 737       goto finished;
 738
 739    However, this is an extension supported by many Fortran compilers,
 740    including Cray, HP, AIX, and IRIX.  Therefore, we allow it in the
 741    runtime library, and make the front end reject it if the compiler
 742    is in pedantic mode.  The interpretation of 'X' is '1X'.
 743 */
 744       get_fnode (fmt, &head, &tail, FMT_X);
 745       tail->repeat = 1;
 746       tail->u.k = 1;
 747       goto between_desc;
 748
 749     case FMT_STRING:
 750       get_fnode (fmt, &head, &tail, FMT_STRING);
 751       tail->u.string.p = fmt->string;
 752       tail->u.string.length = fmt->value;
 753       tail->repeat = 1;
 754       goto optional_comma;
 755
 756     case FMT_RC:
 757     case FMT_RD:
 758     case FMT_RN:
 759     case FMT_RP:
 760     case FMT_RU:
 761     case FMT_RZ:
 762       notify_std (&dtp->common, GFC_STD_F2003, "Fortran 2003: Round "
 763                   "descriptor not allowed");
 764       get_fnode (fmt, &head, &tail, t);
 765       tail->repeat = 1;
 766       goto between_desc;
 767
 768     case FMT_DC:
 769     case FMT_DP:
 770       notify_std (&dtp->common, GFC_STD_F2003, "Fortran 2003: DC or DP "
 771                   "descriptor not allowed");
 772     /* Fall through.  */
 773     case FMT_S:
 774     case FMT_SS:
 775     case FMT_SP:
 776     case FMT_BN:
 777     case FMT_BZ:
 778       get_fnode (fmt, &head, &tail, t);
 779       tail->repeat = 1;
 780       goto between_desc;
 781
 782     case FMT_COLON:
 783       get_fnode (fmt, &head, &tail, FMT_COLON);
 784       tail->repeat = 1;
 785       goto optional_comma;
 786
 787     case FMT_SLASH:
 788       get_fnode (fmt, &head, &tail, FMT_SLASH);
 789       tail->repeat = 1;
 790       tail->u.r = 1;
 791       goto optional_comma;
 792
 793     case FMT_DOLLAR:
 794       get_fnode (fmt, &head, &tail, FMT_DOLLAR);
 795       tail->repeat = 1;
 796       notify_std (&dtp->common, GFC_STD_GNU, "Extension: $ descriptor");
 797       goto between_desc;
 798
 799     case FMT_T:
 800     case FMT_TL:
 801     case FMT_TR:
 802       t2 = format_lex (fmt);
 803       if (t2 != FMT_POSINT)
 804         {
 805           fmt->error = posint_required;
 806           goto finished;
 807         }
 808       get_fnode (fmt, &head, &tail, t);
 809       tail->u.n = fmt->value;
 810       tail->repeat = 1;
 811       goto between_desc;
 812
 813     case FMT_I:
 814     case FMT_B:
 815     case FMT_O:
 816     case FMT_Z:
 817     case FMT_E:
 818     case FMT_EN:
 819     case FMT_ES:
 820     case FMT_D:
 821     case FMT_DT:
 822     case FMT_L:
 823     case FMT_A:
 824     case FMT_F:
 825     case FMT_G:
 826       repeat = 1;
 827       *seen_dd = true;
 828       goto data_desc;
 829
 830     case FMT_H:
 831       get_fnode (fmt, &head, &tail, FMT_STRING);
 832       if (fmt->format_string_len < 1)
 833         {
 834           fmt->error = bad_hollerith;
 835           goto finished;
 836         }
 837
 838       tail->u.string.p = fmt->format_string;
 839       tail->u.string.length = 1;
 840       tail->repeat = 1;
 841
 842       fmt->format_string++;
 843       fmt->format_string_len--;
 844
 845       goto between_desc;
 846
 847     case FMT_END:
 848       fmt->error = unexpected_end;
 849       goto finished;
 850
 851     case FMT_BADSTRING:
 852       goto finished;
 853
 854     case FMT_RPAREN:
 855       goto finished;
 856
 857     default:
 858       fmt->error = unexpected_element;
 859       goto finished;
 860     }
 861
 862   /* In this state, t must currently be a data descriptor.  Deal with
 863      things that can/must follow the descriptor */
 864  data_desc:
 865
 866   switch (t)
 867     {
 868     case FMT_L:
 869       *seen_dd = true;
 870       t = format_lex (fmt);
 871       if (t != FMT_POSINT)
 872         {
 873           if (t == FMT_ZERO)
 874             {
 875               if (notification_std(GFC_STD_GNU) == NOTIFICATION_ERROR)
 876                 {
 877                   fmt->error = "Extension: Zero width after L descriptor";
 878                   goto finished;
 879                 }
 880               else
 881                 notify_std (&dtp->common, GFC_STD_GNU,
 882                             "Zero width after L descriptor");
 883             }
 884           else
 885             {
 886               fmt->saved_token = t;
 887               notify_std (&dtp->common, GFC_STD_GNU,
 888                           "Positive width required with L descriptor");
 889             }
 890           fmt->value = 1;       /* Default width */
 891         }
 892       get_fnode (fmt, &head, &tail, FMT_L);
 893       tail->u.n = fmt->value;
 894       tail->repeat = repeat;
 895       break;
 896
 897     case FMT_A:
 898       *seen_dd = true;
 899       t = format_lex (fmt);
 900       if (t == FMT_ZERO)
 901         {
 902           fmt->error = zero_width;
 903           goto finished;
 904         }
 905
 906       if (t != FMT_POSINT)
 907         {
 908           fmt->saved_token = t;
 909           fmt->value = -1;              /* Width not present */
 910         }
 911
 912       get_fnode (fmt, &head, &tail, FMT_A);
 913       tail->repeat = repeat;
 914       tail->u.n = fmt->value;
 915       break;
 916
 917     case FMT_D:
 918     case FMT_E:
 919     case FMT_F:
 920     case FMT_G:
 921     case FMT_EN:
 922     case FMT_ES:
 923       *seen_dd = true;
 924       get_fnode (fmt, &head, &tail, t);
 925       tail->repeat = repeat;
 926       tail->pushed = FMT_NONE;
 927
 928       u = format_lex (fmt);
 929
 930       /* Processing for zero width formats.  */
 931       if (u == FMT_ZERO)
 932         {
 933           if (t == FMT_F)
 934             standard = GFC_STD_F95;
 935           else if (t == FMT_G)
 936             standard = GFC_STD_F2008;
 937           else
 938             standard = GFC_STD_F2018;
 939
 940           if (notification_std (standard) == NOTIFICATION_ERROR
 941               || dtp->u.p.mode == READING)
 942             {
 943               fmt->error = zero_width;
 944               goto finished;
 945             }
 946           tail->u.real.w = 0;
 947
 948           /* Look for the dot seperator.  */
 949           u = format_lex (fmt);
 950           if (u != FMT_PERIOD)
 951             {
 952               fmt->saved_token = u;
 953               break;
 954             }
 955
 956           /* Look for the precision.  */
 957           u = format_lex (fmt);
 958           if (u != FMT_ZERO && u != FMT_POSINT)
 959             {
 960               fmt->error = nonneg_required;
 961               goto finished;
 962             }
 963           tail->u.real.d = fmt->value;
 964
 965           /* Look for optional exponent, not allowed for FMT_D */
 966           if (t == FMT_D)
 967             break;
 968           u = format_lex (fmt);
 969           if (u != FMT_E)
 970             fmt->saved_token = u;
 971           else
 972             {
 973               u = format_lex (fmt);
 974               if (u != FMT_POSINT)
 975                 {
 976                   if (u == FMT_ZERO)
 977                     {
 978                       notify_std (&dtp->common, GFC_STD_F2018,
 979                                   "Positive exponent width required");
 980                     }
 981                   else
 982                     {
 983                       fmt->error = "Positive exponent width required in "
 984                                    "format string at %L";
 985                       goto finished;
 986                     }
 987                 }
 988               tail->u.real.e = fmt->value;
 989             }
 990           break;
 991         }
 992
 993       /* Processing for positive width formats.  */
 994       if (u == FMT_POSINT)
 995         {
 996           tail->u.real.w = fmt->value;
 997
 998           /* Look for the dot separator. Because of legacy behaviors
 999              we do some look ahead for missing things.  */
1000           t2 = t;
1001           t = format_lex (fmt);
1002           if (t != FMT_PERIOD)
1003             {
1004               /* We treat a missing decimal descriptor as 0.  Note: This is only
1005                  allowed if -std=legacy, otherwise an error occurs.  */
1006               if (compile_options.warn_std != 0)
1007                 {
1008                   fmt->error = period_required;
1009                   goto finished;
1010                 }
1011               fmt->saved_token = t;
1012               tail->u.real.d = 0;
1013               tail->u.real.e = -1;
1014               break;
1015             }
1016
1017           /* If we made it here, we should have the dot so look for the
1018              precision.  */
1019           t = format_lex (fmt);
1020           if (t != FMT_ZERO && t != FMT_POSINT)
1021             {
1022               fmt->error = nonneg_required;
1023               goto finished;
1024             }
1025           tail->u.real.d = fmt->value;
1026           tail->u.real.e = -1;
1027
1028           /* Done with D and F formats.  */
1029           if (t2 == FMT_D || t2 == FMT_F)
1030             {
1031               *seen_dd = true;
1032               break;
1033             }
1034
1035           /* Look for optional exponent */
1036           u = format_lex (fmt);
1037           if (u != FMT_E)
1038             fmt->saved_token = u;
1039           else
1040             {
1041               u = format_lex (fmt);
1042               if (u != FMT_POSINT)
1043                 {
1044                   if (u == FMT_ZERO)
1045                     {
1046                       notify_std (&dtp->common, GFC_STD_F2018,
1047                                   "Positive exponent width required");
1048                     }
1049                   else
1050                     {
1051                       fmt->error = "Positive exponent width required in "
1052                                    "format string at %L";
1053                       goto finished;
1054                     }
1055                 }
1056               tail->u.real.e = fmt->value;
1057             }
1058           break;
1059         }
1060
1061       /* Old DEC codes may not have width or precision specified.  */
1062       if (dtp->u.p.mode == WRITING && (dtp->common.flags & IOPARM_DT_DEC_EXT))
1063         {
1064           tail->u.real.w = DEFAULT_WIDTH;
1065           tail->u.real.d = 0;
1066           tail->u.real.e = -1;
1067           fmt->saved_token = u;
1068         }
1069       break;
1070
1071     case FMT_DT:
1072       *seen_dd = true;
1073       get_fnode (fmt, &head, &tail, t);
1074       tail->repeat = repeat;
1075
1076       t = format_lex (fmt);
1077
1078       /* Initialize the vlist to a zero size, rank-one array.  */
1079       tail->u.udf.vlist= xmalloc (sizeof(gfc_array_i4)
1080                                   + sizeof (descriptor_dimension));
1081       GFC_DESCRIPTOR_DATA(tail->u.udf.vlist) = NULL;
1082       GFC_DIMENSION_SET(tail->u.udf.vlist->dim[0],1, 0, 0);
1083
1084       if (t == FMT_STRING)
1085         {
1086           /* Get pointer to the optional format string.  */
1087           tail->u.udf.string = fmt->string;
1088           tail->u.udf.string_len = fmt->value;
1089           t = format_lex (fmt);
1090         }
1091       if (t == FMT_LPAREN)
1092         {
1093           /* Temporary buffer to hold the vlist values.  */
1094           GFC_INTEGER_4 temp[FARRAY_SIZE];
1095           int i = 0;
1096         loop:
1097           t = format_lex (fmt);
1098           if (t != FMT_POSINT)
1099             {
1100               fmt->error = posint_required;
1101               goto finished;
1102             }
1103           /* Save the positive integer value.  */
1104           temp[i++] = fmt->value;
1105           t = format_lex (fmt);
1106           if (t == FMT_COMMA)
1107             goto loop;
1108           if (t == FMT_RPAREN)
1109             {
1110               /* We have parsed the complete vlist so initialize the
1111                  array descriptor and save it in the format node.  */
1112               gfc_full_array_i4 *vp = tail->u.udf.vlist;
1113               GFC_DESCRIPTOR_DATA(vp) = xmalloc (i * sizeof(GFC_INTEGER_4));
1114               GFC_DIMENSION_SET(vp->dim[0],1, i, 1);
1115               memcpy (GFC_DESCRIPTOR_DATA(vp), temp, i * sizeof(GFC_INTEGER_4));
1116               break;
1117             }
1118           fmt->error = unexpected_element;
1119           goto finished;
1120         }
1121       fmt->saved_token = t;
1122       break;
1123     case FMT_H:
1124       if (repeat > fmt->format_string_len)
1125         {
1126           fmt->error = bad_hollerith;
1127           goto finished;
1128         }
1129
1130       get_fnode (fmt, &head, &tail, FMT_STRING);
1131       tail->u.string.p = fmt->format_string;
1132       tail->u.string.length = repeat;
1133       tail->repeat = 1;
1134
1135       fmt->format_string += fmt->value;
1136       fmt->format_string_len -= repeat;
1137
1138       break;
1139
1140     case FMT_I:
1141     case FMT_B:
1142     case FMT_O:
1143     case FMT_Z:
1144       *seen_dd = true;
1145       get_fnode (fmt, &head, &tail, t);
1146       tail->repeat = repeat;
1147
1148       t = format_lex (fmt);
1149
1150       if (dtp->u.p.mode == READING)
1151         {
1152           if (t != FMT_POSINT)
1153             {
1154               if (dtp->common.flags & IOPARM_DT_DEC_EXT)
1155                 {
1156                   tail->u.integer.w = DEFAULT_WIDTH;
1157                   tail->u.integer.m = -1;
1158                   fmt->saved_token = t;
1159                   break;
1160                 }
1161               fmt->error = posint_required;
1162               goto finished;
1163             }
1164         }
1165       else
1166         {
1167           if (t != FMT_ZERO && t != FMT_POSINT)
1168             {
1169               if (dtp->common.flags & IOPARM_DT_DEC_EXT)
1170                 {
1171                   tail->u.integer.w = DEFAULT_WIDTH;
1172                   tail->u.integer.m = -1;
1173                   fmt->saved_token = t;
1174                   break;
1175                 }
1176               fmt->error = nonneg_required;
1177               goto finished;
1178             }
1179         }
1180
1181       tail->u.integer.w = fmt->value;
1182       tail->u.integer.m = -1;
1183
1184       t = format_lex (fmt);
1185       if (t != FMT_PERIOD)
1186         {
1187           fmt->saved_token = t;
1188         }
1189       else
1190         {
1191           t = format_lex (fmt);
1192           if (t != FMT_ZERO && t != FMT_POSINT)
1193             {
1194               fmt->error = nonneg_required;
1195               goto finished;
1196             }
1197
1198           tail->u.integer.m = fmt->value;
1199         }
1200
1201       if (tail->u.integer.w != 0 && tail->u.integer.m > tail->u.integer.w)
1202         {
1203           fmt->error = "Minimum digits exceeds field width";
1204           goto finished;
1205         }
1206
1207       break;
1208
1209     default:
1210       fmt->error = unexpected_element;
1211       goto finished;
1212     }
1213
1214   /* Between a descriptor and what comes next */
1215  between_desc:
1216   t = format_lex (fmt);
1217   switch (t)
1218     {
1219     case FMT_COMMA:
1220       goto format_item;
1221
1222     case FMT_RPAREN:
1223       goto finished;
1224
1225     case FMT_SLASH:
1226     case FMT_COLON:
1227       get_fnode (fmt, &head, &tail, t);
1228       tail->repeat = 1;
1229       goto optional_comma;
1230
1231     case FMT_END:
1232       fmt->error = unexpected_end;
1233       goto finished;
1234
1235     default:
1236       /* Assume a missing comma, this is a GNU extension */
1237       goto format_item_1;
1238     }
1239
1240   /* Optional comma is a weird between state where we've just finished
1241      reading a colon, slash or P descriptor. */
1242  optional_comma:
1243   t = format_lex (fmt);
1244   switch (t)
1245     {
1246     case FMT_COMMA:
1247       break;
1248
1249     case FMT_RPAREN:
1250       goto finished;
1251
1252     default:                    /* Assume that we have another format item */
1253       fmt->saved_token = t;
1254       break;
1255     }
1256
1257   goto format_item;
1258
1259  finished:
1260
1261   return head;
1262 }
1263
1264
1265 /* format_error()-- Generate an error message for a format statement.
1266    If the node that gives the location of the error is NULL, the error
1267    is assumed to happen at parse time, and the current location of the
1268    parser is shown.
1269
1270    We generate a message showing where the problem is.  We take extra
1271    care to print only the relevant part of the format if it is longer
1272    than a standard 80 column display. */
1273
1274 void
1275 format_error (st_parameter_dt *dtp, const fnode *f, const char *message)
1276 {
1277   int width, i, offset;
1278 #define BUFLEN 300
1279   char *p, buffer[BUFLEN];
1280   format_data *fmt = dtp->u.p.fmt;
1281
1282   if (f != NULL)
1283     p = f->source;
1284   else                /* This should not happen.  */
1285     p = dtp->format;
1286
1287   if (message == unexpected_element)
1288     snprintf (buffer, BUFLEN, message, fmt->error_element);
1289   else
1290     snprintf (buffer, BUFLEN, "%s\n", message);
1291
1292   /* Get the offset into the format string where the error occurred.  */
1293   offset = dtp->format_len - (fmt->reversion_ok ?
1294                               (int) strlen(p) : fmt->format_string_len);
1295
1296   width = dtp->format_len;
1297
1298   if (width > 80)
1299     width = 80;
1300
1301   /* Show the format */
1302
1303   p = strchr (buffer, '\0');
1304
1305   if (dtp->format)
1306     memcpy (p, dtp->format, width);
1307
1308   p += width;
1309   *p++ = '\n';
1310
1311   /* Show where the problem is */
1312
1313   for (i = 1; i < offset; i++)
1314     *p++ = ' ';
1315
1316   *p++ = '^';
1317   *p = '\0';
1318
1319   generate_error (&dtp->common, LIBERROR_FORMAT, buffer);
1320 }
1321
1322
1323 /* revert()-- Do reversion of the format.  Control reverts to the left
1324    parenthesis that matches the rightmost right parenthesis.  From our
1325    tree structure, we are looking for the rightmost parenthesis node
1326    at the second level, the first level always being a single
1327    parenthesis node.  If this node doesn't exit, we use the top
1328    level. */
1329
1330 static void
1331 revert (st_parameter_dt *dtp)
1332 {
1333   fnode *f, *r;
1334   format_data *fmt = dtp->u.p.fmt;
1335
1336   dtp->u.p.reversion_flag = 1;
1337
1338   r = NULL;
1339
1340   for (f = fmt->array.array[0].u.child; f; f = f->next)
1341     if (f->format == FMT_LPAREN)
1342       r = f;
1343
1344   /* If r is NULL because no node was found, the whole tree will be used */
1345
1346   fmt->array.array[0].current = r;
1347   fmt->array.array[0].count = 0;
1348 }
1349
1350 /* parse_format()-- Parse a format string.  */
1351
1352 void
1353 parse_format (st_parameter_dt *dtp)
1354 {
1355   format_data *fmt;
1356   bool format_cache_ok, seen_data_desc = false;
1357
1358   /* Don't cache for internal units and set an arbitrary limit on the
1359      size of format strings we will cache.  (Avoids memory issues.)
1360      Also, the format_hash_table resides in the current_unit, so
1361      child_dtio procedures would overwrite the parent table  */
1362   format_cache_ok = !is_internal_unit (dtp)
1363                     && (dtp->u.p.current_unit->child_dtio == 0);
1364
1365   /* Lookup format string to see if it has already been parsed.  */
1366   if (format_cache_ok)
1367     {
1368       dtp->u.p.fmt = find_parsed_format (dtp);
1369
1370       if (dtp->u.p.fmt != NULL)
1371         {
1372           dtp->u.p.fmt->reversion_ok = 0;
1373           dtp->u.p.fmt->saved_token = FMT_NONE;
1374           dtp->u.p.fmt->saved_format = NULL;
1375           reset_fnode_counters (dtp);
1376           return;
1377         }
1378     }
1379
1380   /* Not found so proceed as follows.  */
1381
1382   char *fmt_string = fc_strdup_notrim (dtp->format, dtp->format_len);
1383   dtp->format = fmt_string;
1384
1385   dtp->u.p.fmt = fmt = xmalloc (sizeof (format_data));
1386   fmt->format_string = dtp->format;
1387   fmt->format_string_len = dtp->format_len;
1388
1389   fmt->string = NULL;
1390   fmt->saved_token = FMT_NONE;
1391   fmt->error = NULL;
1392   fmt->value = 0;
1393
1394   /* Initialize variables used during traversal of the tree.  */
1395
1396   fmt->reversion_ok = 0;
1397   fmt->saved_format = NULL;
1398
1399   /* Initialize the fnode_array.  */
1400
1401   memset (&(fmt->array), 0, sizeof(fmt->array));
1402
1403   /* Allocate the first format node as the root of the tree.  */
1404
1405   fmt->last = &fmt->array;
1406   fmt->last->next = NULL;
1407   fmt->avail = &fmt->array.array[0];
1408
1409   memset (fmt->avail, 0, sizeof (*fmt->avail));
1410   fmt->avail->format = FMT_LPAREN;
1411   fmt->avail->repeat = 1;
1412   fmt->avail++;
1413
1414   if (format_lex (fmt) == FMT_LPAREN)
1415     fmt->array.array[0].u.child = parse_format_list (dtp, &seen_data_desc);
1416   else
1417     fmt->error = "Missing initial left parenthesis in format";
1418
1419   if (format_cache_ok)
1420     save_parsed_format (dtp);
1421   else
1422     dtp->u.p.format_not_saved = 1;
1423
1424   if (fmt->error)
1425     format_error (dtp, NULL, fmt->error);
1426 }
1427
1428
1429 /* next_format0()-- Get the next format node without worrying about
1430    reversion.  Returns NULL when we hit the end of the list.
1431    Parenthesis nodes are incremented after the list has been
1432    exhausted, other nodes are incremented before they are returned. */
1433
1434 static const fnode *
1435 next_format0 (fnode *f)
1436 {
1437   const fnode *r;
1438
1439   if (f == NULL)
1440     return NULL;
1441
1442   if (f->format != FMT_LPAREN)
1443     {
1444       f->count++;
1445       if (f->count <= f->repeat)
1446         return f;
1447
1448       f->count = 0;
1449       return NULL;
1450     }
1451
1452   /* Deal with a parenthesis node with unlimited format.  */
1453
1454   if (f->repeat == -2)  /* -2 signifies unlimited.  */
1455   for (;;)
1456     {
1457       if (f->current == NULL)
1458         f->current = f->u.child;
1459
1460       for (; f->current != NULL; f->current = f->current->next)
1461         {
1462           r = next_format0 (f->current);
1463           if (r != NULL)
1464             return r;
1465         }
1466     }
1467
1468   /* Deal with a parenthesis node with specific repeat count.  */
1469   for (; f->count < f->repeat; f->count++)
1470     {
1471       if (f->current == NULL)
1472         f->current = f->u.child;
1473
1474       for (; f->current != NULL; f->current = f->current->next)
1475         {
1476           r = next_format0 (f->current);
1477           if (r != NULL)
1478             return r;
1479         }
1480     }
1481
1482   f->count = 0;
1483   return NULL;
1484 }
1485
1486
1487 /* next_format()-- Return the next format node.  If the format list
1488    ends up being exhausted, we do reversion.  Reversion is only
1489    allowed if we've seen a data descriptor since the
1490    initialization or the last reversion.  We return NULL if there
1491    are no more data descriptors to return (which is an error
1492    condition).  */
1493
1494 const fnode *
1495 next_format (st_parameter_dt *dtp)
1496 {
1497   format_token t;
1498   const fnode *f;
1499   format_data *fmt = dtp->u.p.fmt;
1500
1501   if (fmt->saved_format != NULL)
1502     {                           /* Deal with a pushed-back format node */
1503       f = fmt->saved_format;
1504       fmt->saved_format = NULL;
1505       goto done;
1506     }
1507
1508   f = next_format0 (&fmt->array.array[0]);
1509   if (f == NULL)
1510     {
1511       if (!fmt->reversion_ok)
1512         return NULL;
1513
1514       fmt->reversion_ok = 0;
1515       revert (dtp);
1516
1517       f = next_format0 (&fmt->array.array[0]);
1518       if (f == NULL)
1519         {
1520           format_error (dtp, NULL, reversion_error);
1521           return NULL;
1522         }
1523
1524       /* Push the first reverted token and return a colon node in case
1525          there are no more data items.  */
1526
1527       fmt->saved_format = f;
1528       return &colon_node;
1529     }
1530
1531   /* If this is a data edit descriptor, then reversion has become OK. */
1532  done:
1533   t = f->format;
1534
1535   if (!fmt->reversion_ok &&
1536       (t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F ||
1537        t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
1538        t == FMT_A || t == FMT_D || t == FMT_DT))
1539     fmt->reversion_ok = 1;
1540   return f;
1541 }
1542
1543
1544 /* unget_format()-- Push the given format back so that it will be
1545    returned on the next call to next_format() without affecting
1546    counts.  This is necessary when we've encountered a data
1547    descriptor, but don't know what the data item is yet.  The format
1548    node is pushed back, and we return control to the main program,
1549    which calls the library back with the data item (or not). */
1550
1551 void
1552 unget_format (st_parameter_dt *dtp, const fnode *f)
1553 {
1554   dtp->u.p.fmt->saved_format = f;
1555 }
1556