libgfortran/io/format.c

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