libgfortran/io/format.c

   1 /* Copyright (C) 2002-2017 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 <ctype.h>
  33 #include <string.h>
  34
  35
  36 static const fnode colon_node = { FMT_COLON, 0, NULL, NULL, {{ 0, 0, 0 }}, 0,
  37                                   NULL };
  38
  39 /* Error messages. */
  40
  41 static const char posint_required[] = "Positive width required in format",
  42   period_required[] = "Period required in format",
  43   nonneg_required[] = "Nonnegative width required in format",
  44   unexpected_element[] = "Unexpected element '%c' in format\n",
  45   unexpected_end[] = "Unexpected end of format string",
  46   bad_string[] = "Unterminated character constant in format",
  47   bad_hollerith[] = "Hollerith constant extends past the end of the format",
  48   reversion_error[] = "Exhausted data descriptors in format",
  49   zero_width[] = "Zero width in format descriptor";
  50
  51 /* The following routines support caching format data from parsed format strings
  52    into a hash table.  This avoids repeatedly parsing duplicate format strings
  53    or format strings in I/O statements that are repeated in loops.  */
  54
  55
  56 /* Traverse the table and free all data.  */
  57
  58 void
  59 free_format_hash_table (gfc_unit *u)
  60 {
  61   size_t i;
  62
  63   /* free_format_data handles any NULL pointers.  */
  64   for (i = 0; i < FORMAT_HASH_SIZE; i++)
  65     {
  66       if (u->format_hash_table[i].hashed_fmt != NULL)
  67         {
  68           free_format_data (u->format_hash_table[i].hashed_fmt);
  69           free (u->format_hash_table[i].key);
  70         }
  71       u->format_hash_table[i].key = NULL;
  72       u->format_hash_table[i].key_len = 0;
  73       u->format_hash_table[i].hashed_fmt = NULL;
  74     }
  75 }
  76
  77 /* Traverse the format_data structure and reset the fnode counters.  */
  78
  79 static void
  80 reset_node (fnode *fn)
  81 {
  82   fnode *f;
  83
  84   fn->count = 0;
  85   fn->current = NULL;
  86
  87   if (fn->format != FMT_LPAREN)
  88     return;
  89
  90   for (f = fn->u.child; f; f = f->next)
  91     {
  92       if (f->format == FMT_RPAREN)
  93         break;
  94       reset_node (f);
  95     }
  96 }
  97
  98 static void
  99 reset_fnode_counters (st_parameter_dt *dtp)
 100 {
 101   fnode *f;
 102   format_data *fmt;
 103
 104   fmt = dtp->u.p.fmt;
 105
 106   /* Clear this pointer at the head so things start at the right place.  */
 107   fmt->array.array[0].current = NULL;
 108
 109   for (f = fmt->array.array[0].u.child; f; f = f->next)
 110     reset_node (f);
 111 }
 112
 113
 114 /* A simple hashing function to generate an index into the hash table.  */
 115
 116 static uint32_t
 117 format_hash (st_parameter_dt *dtp)
 118 {
 119   char *key;
 120   gfc_charlen_type key_len;
 121   uint32_t hash = 0;
 122   gfc_charlen_type i;
 123
 124   /* Hash the format string. Super simple, but what the heck!  */
 125   key = dtp->format;
 126   key_len = dtp->format_len;
 127   for (i = 0; i < key_len; i++)
 128     hash ^= key[i];
 129   hash &= (FORMAT_HASH_SIZE - 1);
 130   return hash;
 131 }
 132
 133
 134 static void
 135 save_parsed_format (st_parameter_dt *dtp)
 136 {
 137   uint32_t hash;
 138   gfc_unit *u;
 139
 140   hash = format_hash (dtp);
 141   u = dtp->u.p.current_unit;
 142
 143   /* Index into the hash table.  We are simply replacing whatever is there
 144      relying on probability.  */
 145   if (u->format_hash_table[hash].hashed_fmt != NULL)
 146     free_format_data (u->format_hash_table[hash].hashed_fmt);
 147   u->format_hash_table[hash].hashed_fmt = NULL;
 148
 149   free (u->format_hash_table[hash].key);
 150   u->format_hash_table[hash].key = dtp->format;
 151
 152   u->format_hash_table[hash].key_len = dtp->format_len;
 153   u->format_hash_table[hash].hashed_fmt = dtp->u.p.fmt;
 154 }
 155
 156
 157 static format_data *
 158 find_parsed_format (st_parameter_dt *dtp)
 159 {
 160   uint32_t hash;
 161   gfc_unit *u;
 162
 163   hash = format_hash (dtp);
 164   u = dtp->u.p.current_unit;
 165
 166   if (u->format_hash_table[hash].key != NULL)
 167     {
 168       /* See if it matches.  */
 169       if (u->format_hash_table[hash].key_len == dtp->format_len)
 170         {
 171           /* So far so good.  */
 172           if (strncmp (u->format_hash_table[hash].key,
 173               dtp->format, dtp->format_len) == 0)
 174             return u->format_hash_table[hash].hashed_fmt;
 175         }
 176     }
 177   return NULL;
 178 }
 179
 180
 181 /* next_char()-- Return the next character in the format string.
 182    Returns -1 when the string is done.  If the literal flag is set,
 183    spaces are significant, otherwise they are not. */
 184
 185 static int
 186 next_char (format_data *fmt, int literal)
 187 {
 188   int c;
 189
 190   do
 191     {
 192       if (fmt->format_string_len == 0)
 193         return -1;
 194
 195       fmt->format_string_len--;
 196       c = toupper (*fmt->format_string++);
 197       fmt->error_element = c;
 198     }
 199   while ((c == ' ' || c == '\t') && !literal);
 200
 201   return c;
 202 }
 203
 204
 205 /* unget_char()-- Back up one character position. */
 206
 207 #define unget_char(fmt) \
 208   { fmt->format_string--; fmt->format_string_len++; }
 209
 210
 211 /* get_fnode()-- Allocate a new format node, inserting it into the
 212    current singly linked list.  These are initially allocated from the
 213    static buffer. */
 214
 215 static fnode *
 216 get_fnode (format_data *fmt, fnode **head, fnode **tail, format_token t)
 217 {
 218   fnode *f;
 219
 220   if (fmt->avail == &fmt->last->array[FARRAY_SIZE])
 221     {
 222       fmt->last->next = xmalloc (sizeof (fnode_array));
 223       fmt->last = fmt->last->next;
 224       fmt->last->next = NULL;
 225       fmt->avail = &fmt->last->array[0];
 226     }
 227   f = fmt->avail++;
 228   memset (f, '\0', sizeof (fnode));
 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->format != FMT_NONE; fnp++)
 270     if (fnp->format == FMT_DT)
 271         {
 272           if (GFC_DESCRIPTOR_DATA(fnp->u.udf.vlist))
 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 (!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 (!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 (!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
 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       if (t == FMT_G && u == FMT_ZERO)
 928         {
 929           *seen_dd = true;
 930           if (notification_std (GFC_STD_F2008) == NOTIFICATION_ERROR
 931               || dtp->u.p.mode == READING)
 932             {
 933               fmt->error = zero_width;
 934               goto finished;
 935             }
 936           tail->u.real.w = 0;
 937           u = format_lex (fmt);
 938           if (u != FMT_PERIOD)
 939             {
 940               fmt->saved_token = u;
 941               break;
 942             }
 943
 944           u = format_lex (fmt);
 945           if (u != FMT_POSINT)
 946             {
 947               fmt->error = posint_required;
 948               goto finished;
 949             }
 950           tail->u.real.d = fmt->value;
 951           break;
 952         }
 953       if (t == FMT_F && dtp->u.p.mode == WRITING)
 954         {
 955           *seen_dd = true;
 956           if (u != FMT_POSINT && u != FMT_ZERO)
 957             {
 958               fmt->error = nonneg_required;
 959               goto finished;
 960             }
 961         }
 962       else if (u != FMT_POSINT)
 963         {
 964           fmt->error = posint_required;
 965           goto finished;
 966         }
 967
 968       tail->u.real.w = fmt->value;
 969       t2 = t;
 970       t = format_lex (fmt);
 971       if (t != FMT_PERIOD)
 972         {
 973           /* We treat a missing decimal descriptor as 0.  Note: This is only
 974              allowed if -std=legacy, otherwise an error occurs.  */
 975           if (compile_options.warn_std != 0)
 976             {
 977               fmt->error = period_required;
 978               goto finished;
 979             }
 980           fmt->saved_token = t;
 981           tail->u.real.d = 0;
 982           tail->u.real.e = -1;
 983           break;
 984         }
 985
 986       t = format_lex (fmt);
 987       if (t != FMT_ZERO && t != FMT_POSINT)
 988         {
 989           fmt->error = nonneg_required;
 990           goto finished;
 991         }
 992
 993       tail->u.real.d = fmt->value;
 994       tail->u.real.e = -1;
 995
 996       if (t2 == FMT_D || t2 == FMT_F)
 997         {
 998           *seen_dd = true;
 999           break;
1000         }
1001
1002       /* Look for optional exponent */
1003       t = format_lex (fmt);
1004       if (t != FMT_E)
1005         fmt->saved_token = t;
1006       else
1007         {
1008           t = format_lex (fmt);
1009           if (t != FMT_POSINT)
1010             {
1011               fmt->error = "Positive exponent width required in format";
1012               goto finished;
1013             }
1014
1015           tail->u.real.e = fmt->value;
1016         }
1017
1018       break;
1019     case FMT_DT:
1020       *seen_dd = true;
1021       get_fnode (fmt, &head, &tail, t);
1022       tail->repeat = repeat;
1023
1024       t = format_lex (fmt);
1025
1026       /* Initialize the vlist to a zero size array.  */
1027       tail->u.udf.vlist= xmalloc (sizeof(gfc_array_i4));
1028       GFC_DESCRIPTOR_DATA(tail->u.udf.vlist) = NULL;
1029       GFC_DIMENSION_SET(tail->u.udf.vlist->dim[0],1, 0, 0);
1030
1031       if (t == FMT_STRING)
1032         {
1033           /* Get pointer to the optional format string.  */
1034           tail->u.udf.string = fmt->string;
1035           tail->u.udf.string_len = fmt->value;
1036           t = format_lex (fmt);
1037         }
1038       if (t == FMT_LPAREN)
1039         {
1040           /* Temporary buffer to hold the vlist values.  */
1041           GFC_INTEGER_4 temp[FARRAY_SIZE];
1042           int i = 0;
1043         loop:
1044           t = format_lex (fmt);
1045           if (t != FMT_POSINT)
1046             {
1047               fmt->error = posint_required;
1048               goto finished;
1049             }
1050           /* Save the positive integer value.  */
1051           temp[i++] = fmt->value;
1052           t = format_lex (fmt);
1053           if (t == FMT_COMMA)
1054             goto loop;
1055           if (t == FMT_RPAREN)
1056             {
1057               /* We have parsed the complete vlist so initialize the
1058                  array descriptor and save it in the format node.  */
1059               gfc_array_i4 *vp = tail->u.udf.vlist;
1060               GFC_DESCRIPTOR_DATA(vp) = xmalloc (i * sizeof(GFC_INTEGER_4));
1061               GFC_DIMENSION_SET(vp->dim[0],1, i, 1);
1062               memcpy (GFC_DESCRIPTOR_DATA(vp), temp, i * sizeof(GFC_INTEGER_4));
1063               break;
1064             }
1065           fmt->error = unexpected_element;
1066           goto finished;
1067         }
1068       fmt->saved_token = t;
1069       break;
1070     case FMT_H:
1071       if (repeat > fmt->format_string_len)
1072         {
1073           fmt->error = bad_hollerith;
1074           goto finished;
1075         }
1076
1077       get_fnode (fmt, &head, &tail, FMT_STRING);
1078       tail->u.string.p = fmt->format_string;
1079       tail->u.string.length = repeat;
1080       tail->repeat = 1;
1081
1082       fmt->format_string += fmt->value;
1083       fmt->format_string_len -= repeat;
1084
1085       break;
1086
1087     case FMT_I:
1088     case FMT_B:
1089     case FMT_O:
1090     case FMT_Z:
1091       *seen_dd = true;
1092       get_fnode (fmt, &head, &tail, t);
1093       tail->repeat = repeat;
1094
1095       t = format_lex (fmt);
1096
1097       if (dtp->u.p.mode == READING)
1098         {
1099           if (t != FMT_POSINT)
1100             {
1101               fmt->error = posint_required;
1102               goto finished;
1103             }
1104         }
1105       else
1106         {
1107           if (t != FMT_ZERO && t != FMT_POSINT)
1108             {
1109               fmt->error = nonneg_required;
1110               goto finished;
1111             }
1112         }
1113
1114       tail->u.integer.w = fmt->value;
1115       tail->u.integer.m = -1;
1116
1117       t = format_lex (fmt);
1118       if (t != FMT_PERIOD)
1119         {
1120           fmt->saved_token = t;
1121         }
1122       else
1123         {
1124           t = format_lex (fmt);
1125           if (t != FMT_ZERO && t != FMT_POSINT)
1126             {
1127               fmt->error = nonneg_required;
1128               goto finished;
1129             }
1130
1131           tail->u.integer.m = fmt->value;
1132         }
1133
1134       if (tail->u.integer.w != 0 && tail->u.integer.m > tail->u.integer.w)
1135         {
1136           fmt->error = "Minimum digits exceeds field width";
1137           goto finished;
1138         }
1139
1140       break;
1141
1142     default:
1143       fmt->error = unexpected_element;
1144       goto finished;
1145     }
1146
1147   /* Between a descriptor and what comes next */
1148  between_desc:
1149   t = format_lex (fmt);
1150   switch (t)
1151     {
1152     case FMT_COMMA:
1153       goto format_item;
1154
1155     case FMT_RPAREN:
1156       goto finished;
1157
1158     case FMT_SLASH:
1159     case FMT_COLON:
1160       get_fnode (fmt, &head, &tail, t);
1161       tail->repeat = 1;
1162       goto optional_comma;
1163
1164     case FMT_END:
1165       fmt->error = unexpected_end;
1166       goto finished;
1167
1168     default:
1169       /* Assume a missing comma, this is a GNU extension */
1170       goto format_item_1;
1171     }
1172
1173   /* Optional comma is a weird between state where we've just finished
1174      reading a colon, slash or P descriptor. */
1175  optional_comma:
1176   t = format_lex (fmt);
1177   switch (t)
1178     {
1179     case FMT_COMMA:
1180       break;
1181
1182     case FMT_RPAREN:
1183       goto finished;
1184
1185     default:                    /* Assume that we have another format item */
1186       fmt->saved_token = t;
1187       break;
1188     }
1189
1190   goto format_item;
1191
1192  finished:
1193
1194   return head;
1195 }
1196
1197
1198 /* format_error()-- Generate an error message for a format statement.
1199    If the node that gives the location of the error is NULL, the error
1200    is assumed to happen at parse time, and the current location of the
1201    parser is shown.
1202
1203    We generate a message showing where the problem is.  We take extra
1204    care to print only the relevant part of the format if it is longer
1205    than a standard 80 column display. */
1206
1207 void
1208 format_error (st_parameter_dt *dtp, const fnode *f, const char *message)
1209 {
1210   int width, i, offset;
1211 #define BUFLEN 300
1212   char *p, buffer[BUFLEN];
1213   format_data *fmt = dtp->u.p.fmt;
1214
1215   if (f != NULL)
1216     p = f->source;
1217   else                /* This should not happen.  */
1218     p = dtp->format;
1219
1220   if (message == unexpected_element)
1221     snprintf (buffer, BUFLEN, message, fmt->error_element);
1222   else
1223     snprintf (buffer, BUFLEN, "%s\n", message);
1224
1225   /* Get the offset into the format string where the error occurred.  */
1226   offset = dtp->format_len - (fmt->reversion_ok ?
1227                               (int) strlen(p) : fmt->format_string_len);
1228
1229   width = dtp->format_len;
1230
1231   if (width > 80)
1232     width = 80;
1233
1234   /* Show the format */
1235
1236   p = strchr (buffer, '\0');
1237
1238   if (dtp->format)
1239     memcpy (p, dtp->format, width);
1240
1241   p += width;
1242   *p++ = '\n';
1243
1244   /* Show where the problem is */
1245
1246   for (i = 1; i < offset; i++)
1247     *p++ = ' ';
1248
1249   *p++ = '^';
1250   *p = '\0';
1251
1252   generate_error (&dtp->common, LIBERROR_FORMAT, buffer);
1253 }
1254
1255
1256 /* revert()-- Do reversion of the format.  Control reverts to the left
1257    parenthesis that matches the rightmost right parenthesis.  From our
1258    tree structure, we are looking for the rightmost parenthesis node
1259    at the second level, the first level always being a single
1260    parenthesis node.  If this node doesn't exit, we use the top
1261    level. */
1262
1263 static void
1264 revert (st_parameter_dt *dtp)
1265 {
1266   fnode *f, *r;
1267   format_data *fmt = dtp->u.p.fmt;
1268
1269   dtp->u.p.reversion_flag = 1;
1270
1271   r = NULL;
1272
1273   for (f = fmt->array.array[0].u.child; f; f = f->next)
1274     if (f->format == FMT_LPAREN)
1275       r = f;
1276
1277   /* If r is NULL because no node was found, the whole tree will be used */
1278
1279   fmt->array.array[0].current = r;
1280   fmt->array.array[0].count = 0;
1281 }
1282
1283 /* parse_format()-- Parse a format string.  */
1284
1285 void
1286 parse_format (st_parameter_dt *dtp)
1287 {
1288   format_data *fmt;
1289   bool format_cache_ok, seen_data_desc = false;
1290
1291   /* Don't cache for internal units and set an arbitrary limit on the
1292      size of format strings we will cache.  (Avoids memory issues.)
1293      Also, the format_hash_table resides in the current_unit, so
1294      child_dtio procedures would overwrite the parent table  */
1295   format_cache_ok = !is_internal_unit (dtp)
1296                     && (dtp->u.p.current_unit->child_dtio == 0);
1297
1298   /* Lookup format string to see if it has already been parsed.  */
1299   if (format_cache_ok)
1300     {
1301       dtp->u.p.fmt = find_parsed_format (dtp);
1302
1303       if (dtp->u.p.fmt != NULL)
1304         {
1305           dtp->u.p.fmt->reversion_ok = 0;
1306           dtp->u.p.fmt->saved_token = FMT_NONE;
1307           dtp->u.p.fmt->saved_format = NULL;
1308           reset_fnode_counters (dtp);
1309           return;
1310         }
1311     }
1312
1313   /* Not found so proceed as follows.  */
1314
1315   char *fmt_string = fc_strdup_notrim (dtp->format, dtp->format_len);
1316   dtp->format = fmt_string;
1317
1318   dtp->u.p.fmt = fmt = xmalloc (sizeof (format_data));
1319   fmt->format_string = dtp->format;
1320   fmt->format_string_len = dtp->format_len;
1321
1322   fmt->string = NULL;
1323   fmt->saved_token = FMT_NONE;
1324   fmt->error = NULL;
1325   fmt->value = 0;
1326
1327   /* Initialize variables used during traversal of the tree.  */
1328
1329   fmt->reversion_ok = 0;
1330   fmt->saved_format = NULL;
1331
1332   /* Initialize the fnode_array.  */
1333
1334   memset (&(fmt->array), 0, sizeof(fmt->array));
1335
1336   /* Allocate the first format node as the root of the tree.  */
1337
1338   fmt->last = &fmt->array;
1339   fmt->last->next = NULL;
1340   fmt->avail = &fmt->array.array[0];
1341
1342   memset (fmt->avail, 0, sizeof (*fmt->avail));
1343   fmt->avail->format = FMT_LPAREN;
1344   fmt->avail->repeat = 1;
1345   fmt->avail++;
1346
1347   if (format_lex (fmt) == FMT_LPAREN)
1348     fmt->array.array[0].u.child = parse_format_list (dtp, &seen_data_desc);
1349   else
1350     fmt->error = "Missing initial left parenthesis in format";
1351
1352   if (format_cache_ok)
1353     save_parsed_format (dtp);
1354   else
1355     dtp->u.p.format_not_saved = 1;
1356
1357   if (fmt->error)
1358     format_error (dtp, NULL, fmt->error);
1359 }
1360
1361
1362 /* next_format0()-- Get the next format node without worrying about
1363    reversion.  Returns NULL when we hit the end of the list.
1364    Parenthesis nodes are incremented after the list has been
1365    exhausted, other nodes are incremented before they are returned. */
1366
1367 static const fnode *
1368 next_format0 (fnode *f)
1369 {
1370   const fnode *r;
1371
1372   if (f == NULL)
1373     return NULL;
1374
1375   if (f->format != FMT_LPAREN)
1376     {
1377       f->count++;
1378       if (f->count <= f->repeat)
1379         return f;
1380
1381       f->count = 0;
1382       return NULL;
1383     }
1384
1385   /* Deal with a parenthesis node with unlimited format.  */
1386
1387   if (f->repeat == -2)  /* -2 signifies unlimited.  */
1388   for (;;)
1389     {
1390       if (f->current == NULL)
1391         f->current = f->u.child;
1392
1393       for (; f->current != NULL; f->current = f->current->next)
1394         {
1395           r = next_format0 (f->current);
1396           if (r != NULL)
1397             return r;
1398         }
1399     }
1400
1401   /* Deal with a parenthesis node with specific repeat count.  */
1402   for (; f->count < f->repeat; f->count++)
1403     {
1404       if (f->current == NULL)
1405         f->current = f->u.child;
1406
1407       for (; f->current != NULL; f->current = f->current->next)
1408         {
1409           r = next_format0 (f->current);
1410           if (r != NULL)
1411             return r;
1412         }
1413     }
1414
1415   f->count = 0;
1416   return NULL;
1417 }
1418
1419
1420 /* next_format()-- Return the next format node.  If the format list
1421    ends up being exhausted, we do reversion.  Reversion is only
1422    allowed if we've seen a data descriptor since the
1423    initialization or the last reversion.  We return NULL if there
1424    are no more data descriptors to return (which is an error
1425    condition).  */
1426
1427 const fnode *
1428 next_format (st_parameter_dt *dtp)
1429 {
1430   format_token t;
1431   const fnode *f;
1432   format_data *fmt = dtp->u.p.fmt;
1433
1434   if (fmt->saved_format != NULL)
1435     {                           /* Deal with a pushed-back format node */
1436       f = fmt->saved_format;
1437       fmt->saved_format = NULL;
1438       goto done;
1439     }
1440
1441   f = next_format0 (&fmt->array.array[0]);
1442   if (f == NULL)
1443     {
1444       if (!fmt->reversion_ok)
1445         return NULL;
1446
1447       fmt->reversion_ok = 0;
1448       revert (dtp);
1449
1450       f = next_format0 (&fmt->array.array[0]);
1451       if (f == NULL)
1452         {
1453           format_error (dtp, NULL, reversion_error);
1454           return NULL;
1455         }
1456
1457       /* Push the first reverted token and return a colon node in case
1458          there are no more data items.  */
1459
1460       fmt->saved_format = f;
1461       return &colon_node;
1462     }
1463
1464   /* If this is a data edit descriptor, then reversion has become OK. */
1465  done:
1466   t = f->format;
1467
1468   if (!fmt->reversion_ok &&
1469       (t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F ||
1470        t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
1471        t == FMT_A || t == FMT_D || t == FMT_DT))
1472     fmt->reversion_ok = 1;
1473   return f;
1474 }
1475
1476
1477 /* unget_format()-- Push the given format back so that it will be
1478    returned on the next call to next_format() without affecting
1479    counts.  This is necessary when we've encountered a data
1480    descriptor, but don't know what the data item is yet.  The format
1481    node is pushed back, and we return control to the main program,
1482    which calls the library back with the data item (or not). */
1483
1484 void
1485 unget_format (st_parameter_dt *dtp, const fnode *f)
1486 {
1487   dtp->u.p.fmt->saved_format = f;
1488 }
1489