libgfortran/io/format.c

   1 /* Copyright (C) 2002-2016 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 #include <stdlib.h>
  35
  36
  37 static const fnode colon_node = { FMT_COLON, 0, NULL, NULL, {{ 0, 0, 0 }}, 0,
  38                                   NULL };
  39
  40 /* Error messages. */
  41
  42 static const char posint_required[] = "Positive width required in format",
  43   period_required[] = "Period required in format",
  44   nonneg_required[] = "Nonnegative width required in format",
  45   unexpected_element[] = "Unexpected element '%c' in format\n",
  46   unexpected_end[] = "Unexpected end of format string",
  47   bad_string[] = "Unterminated character constant in format",
  48   bad_hollerith[] = "Hollerith constant extends past the end of the format",
  49   reversion_error[] = "Exhausted data descriptors in format",
  50   zero_width[] = "Zero width in format descriptor";
  51
  52 /* The following routines support caching format data from parsed format strings
  53    into a hash table.  This avoids repeatedly parsing duplicate format strings
  54    or format strings in I/O statements that are repeated in loops.  */
  55
  56
  57 /* Traverse the table and free all data.  */
  58
  59 void
  60 free_format_hash_table (gfc_unit *u)
  61 {
  62   size_t i;
  63
  64   /* free_format_data handles any NULL pointers.  */
  65   for (i = 0; i < FORMAT_HASH_SIZE; i++)
  66     {
  67       if (u->format_hash_table[i].hashed_fmt != NULL)
  68         {
  69           free_format_data (u->format_hash_table[i].hashed_fmt);
  70           free (u->format_hash_table[i].key);
  71         }
  72       u->format_hash_table[i].key = NULL;
  73       u->format_hash_table[i].key_len = 0;
  74       u->format_hash_table[i].hashed_fmt = NULL;
  75     }
  76 }
  77
  78 /* Traverse the format_data structure and reset the fnode counters.  */
  79
  80 static void
  81 reset_node (fnode *fn)
  82 {
  83   fnode *f;
  84
  85   fn->count = 0;
  86   fn->current = NULL;
  87
  88   if (fn->format != FMT_LPAREN)
  89     return;
  90
  91   for (f = fn->u.child; f; f = f->next)
  92     {
  93       if (f->format == FMT_RPAREN)
  94         break;
  95       reset_node (f);
  96     }
  97 }
  98
  99 static void
 100 reset_fnode_counters (st_parameter_dt *dtp)
 101 {
 102   fnode *f;
 103   format_data *fmt;
 104
 105   fmt = dtp->u.p.fmt;
 106
 107   /* Clear this pointer at the head so things start at the right place.  */
 108   fmt->array.array[0].current = NULL;
 109
 110   for (f = fmt->array.array[0].u.child; f; f = f->next)
 111     reset_node (f);
 112 }
 113
 114
 115 /* A simple hashing function to generate an index into the hash table.  */
 116
 117 static uint32_t
 118 format_hash (st_parameter_dt *dtp)
 119 {
 120   char *key;
 121   gfc_charlen_type key_len;
 122   uint32_t hash = 0;
 123   gfc_charlen_type i;
 124
 125   /* Hash the format string. Super simple, but what the heck!  */
 126   key = dtp->format;
 127   key_len = dtp->format_len;
 128   for (i = 0; i < key_len; i++)
 129     hash ^= key[i];
 130   hash &= (FORMAT_HASH_SIZE - 1);
 131   return hash;
 132 }
 133
 134
 135 static void
 136 save_parsed_format (st_parameter_dt *dtp)
 137 {
 138   uint32_t hash;
 139   gfc_unit *u;
 140
 141   hash = format_hash (dtp);
 142   u = dtp->u.p.current_unit;
 143
 144   /* Index into the hash table.  We are simply replacing whatever is there
 145      relying on probability.  */
 146   if (u->format_hash_table[hash].hashed_fmt != NULL)
 147     free_format_data (u->format_hash_table[hash].hashed_fmt);
 148   u->format_hash_table[hash].hashed_fmt = NULL;
 149
 150   free (u->format_hash_table[hash].key);
 151   u->format_hash_table[hash].key = dtp->format;
 152
 153   u->format_hash_table[hash].key_len = dtp->format_len;
 154   u->format_hash_table[hash].hashed_fmt = dtp->u.p.fmt;
 155 }
 156
 157
 158 static format_data *
 159 find_parsed_format (st_parameter_dt *dtp)
 160 {
 161   uint32_t hash;
 162   gfc_unit *u;
 163
 164   hash = format_hash (dtp);
 165   u = dtp->u.p.current_unit;
 166
 167   if (u->format_hash_table[hash].key != NULL)
 168     {
 169       /* See if it matches.  */
 170       if (u->format_hash_table[hash].key_len == dtp->format_len)
 171         {
 172           /* So far so good.  */
 173           if (strncmp (u->format_hash_table[hash].key,
 174               dtp->format, dtp->format_len) == 0)
 175             return u->format_hash_table[hash].hashed_fmt;
 176         }
 177     }
 178   return NULL;
 179 }
 180
 181
 182 /* next_char()-- Return the next character in the format string.
 183  * Returns -1 when the string is done.  If the literal flag is set,
 184  * spaces are significant, otherwise they are not. */
 185
 186 static int
 187 next_char (format_data *fmt, int literal)
 188 {
 189   int c;
 190
 191   do
 192     {
 193       if (fmt->format_string_len == 0)
 194         return -1;
 195
 196       fmt->format_string_len--;
 197       c = toupper (*fmt->format_string++);
 198       fmt->error_element = c;
 199     }
 200   while ((c == ' ' || c == '\t') && !literal);
 201
 202   return c;
 203 }
 204
 205
 206 /* unget_char()-- Back up one character position. */
 207
 208 #define unget_char(fmt) \
 209   { fmt->format_string--; fmt->format_string_len++; }
 210
 211
 212 /* get_fnode()-- Allocate a new format node, inserting it into the
 213  * current singly linked list.  These are initially allocated from the
 214  * static buffer. */
 215
 216 static fnode *
 217 get_fnode (format_data *fmt, fnode **head, fnode **tail, format_token t)
 218 {
 219   fnode *f;
 220
 221   if (fmt->avail == &fmt->last->array[FARRAY_SIZE])
 222     {
 223       fmt->last->next = xmalloc (sizeof (fnode_array));
 224       fmt->last = fmt->last->next;
 225       fmt->last->next = NULL;
 226       fmt->avail = &fmt->last->array[0];
 227     }
 228   f = fmt->avail++;
 229   memset (f, '\0', sizeof (fnode));
 230
 231   if (*head == NULL)
 232     *head = *tail = f;
 233   else
 234     {
 235       (*tail)->next = f;
 236       *tail = f;
 237     }
 238
 239   f->format = t;
 240   f->repeat = -1;
 241   f->source = fmt->format_string;
 242   return f;
 243 }
 244
 245
 246 /* free_format()-- Free allocated format string.  */
 247 void
 248 free_format (st_parameter_dt *dtp)
 249 {
 250   if ((dtp->common.flags & IOPARM_DT_HAS_FORMAT) && dtp->format)
 251     {
 252       free (dtp->format);
 253       dtp->format = NULL;
 254     }
 255 }
 256
 257
 258 /* free_format_data()-- Free all allocated format data.  */
 259
 260 void
 261 free_format_data (format_data *fmt)
 262 {
 263   fnode_array *fa, *fa_next;
 264   fnode *fnp;
 265
 266   if (fmt == NULL)
 267     return;
 268
 269   /* Free vlist descriptors in the fnode_array if one was allocated.  */
 270   for (fnp = fmt->array.array; fnp->format != FMT_NONE; fnp++)
 271     if (fnp->format == FMT_DT)
 272         {
 273           if (GFC_DESCRIPTOR_DATA(fnp->u.udf.vlist))
 274             free (GFC_DESCRIPTOR_DATA(fnp->u.udf.vlist));
 275           free (fnp->u.udf.vlist);
 276         }
 277
 278   for (fa = fmt->array.next; fa; fa = fa_next)
 279     {
 280       fa_next = fa->next;
 281       free (fa);
 282     }
 283
 284   free (fmt);
 285   fmt = NULL;
 286 }
 287
 288
 289 /* format_lex()-- Simple lexical analyzer for getting the next token
 290  * in a FORMAT string.  We support a one-level token pushback in the
 291  * fmt->saved_token variable. */
 292
 293 static format_token
 294 format_lex (format_data *fmt)
 295 {
 296   format_token token;
 297   int negative_flag;
 298   int c;
 299   char delim;
 300
 301   if (fmt->saved_token != FMT_NONE)
 302     {
 303       token = fmt->saved_token;
 304       fmt->saved_token = FMT_NONE;
 305       return token;
 306     }
 307
 308   negative_flag = 0;
 309   c = next_char (fmt, 0);
 310
 311   switch (c)
 312     {
 313     case '*':
 314        token = FMT_STAR;
 315        break;
 316
 317     case '(':
 318       token = FMT_LPAREN;
 319       break;
 320
 321     case ')':
 322       token = FMT_RPAREN;
 323       break;
 324
 325     case '-':
 326       negative_flag = 1;
 327       /* Fall Through */
 328
 329     case '+':
 330       c = next_char (fmt, 0);
 331       if (!isdigit (c))
 332         {
 333           token = FMT_UNKNOWN;
 334           break;
 335         }
 336
 337       fmt->value = c - '0';
 338
 339       for (;;)
 340         {
 341           c = next_char (fmt, 0);
 342           if (!isdigit (c))
 343             break;
 344
 345           fmt->value = 10 * fmt->value + c - '0';
 346         }
 347
 348       unget_char (fmt);
 349
 350       if (negative_flag)
 351         fmt->value = -fmt->value;
 352       token = FMT_SIGNED_INT;
 353       break;
 354
 355     case '0':
 356     case '1':
 357     case '2':
 358     case '3':
 359     case '4':
 360     case '5':
 361     case '6':
 362     case '7':
 363     case '8':
 364     case '9':
 365       fmt->value = c - '0';
 366
 367       for (;;)
 368         {
 369           c = next_char (fmt, 0);
 370           if (!isdigit (c))
 371             break;
 372
 373           fmt->value = 10 * fmt->value + c - '0';
 374         }
 375
 376       unget_char (fmt);
 377       token = (fmt->value == 0) ? FMT_ZERO : FMT_POSINT;
 378       break;
 379
 380     case '.':
 381       token = FMT_PERIOD;
 382       break;
 383
 384     case ',':
 385       token = FMT_COMMA;
 386       break;
 387
 388     case ':':
 389       token = FMT_COLON;
 390       break;
 391
 392     case '/':
 393       token = FMT_SLASH;
 394       break;
 395
 396     case '$':
 397       token = FMT_DOLLAR;
 398       break;
 399
 400     case 'T':
 401       switch (next_char (fmt, 0))
 402         {
 403         case 'L':
 404           token = FMT_TL;
 405           break;
 406         case 'R':
 407           token = FMT_TR;
 408           break;
 409         default:
 410           token = FMT_T;
 411           unget_char (fmt);
 412           break;
 413         }
 414
 415       break;
 416
 417     case 'X':
 418       token = FMT_X;
 419       break;
 420
 421     case 'S':
 422       switch (next_char (fmt, 0))
 423         {
 424         case 'S':
 425           token = FMT_SS;
 426           break;
 427         case 'P':
 428           token = FMT_SP;
 429           break;
 430         default:
 431           token = FMT_S;
 432           unget_char (fmt);
 433           break;
 434         }
 435
 436       break;
 437
 438     case 'B':
 439       switch (next_char (fmt, 0))
 440         {
 441         case 'N':
 442           token = FMT_BN;
 443           break;
 444         case 'Z':
 445           token = FMT_BZ;
 446           break;
 447         default:
 448           token = FMT_B;
 449           unget_char (fmt);
 450           break;
 451         }
 452
 453       break;
 454
 455     case '\'':
 456     case '"':
 457       delim = c;
 458
 459       fmt->string = fmt->format_string;
 460       fmt->value = 0;           /* This is the length of the string */
 461
 462       for (;;)
 463         {
 464           c = next_char (fmt, 1);
 465           if (c == -1)
 466             {
 467               token = FMT_BADSTRING;
 468               fmt->error = bad_string;
 469               break;
 470             }
 471
 472           if (c == delim)
 473             {
 474               c = next_char (fmt, 1);
 475
 476               if (c == -1)
 477                 {
 478                   token = FMT_BADSTRING;
 479                   fmt->error = bad_string;
 480                   break;
 481                 }
 482
 483               if (c != delim)
 484                 {
 485                   unget_char (fmt);
 486                   token = FMT_STRING;
 487                   break;
 488                 }
 489             }
 490
 491           fmt->value++;
 492         }
 493
 494       break;
 495
 496     case 'P':
 497       token = FMT_P;
 498       break;
 499
 500     case 'I':
 501       token = FMT_I;
 502       break;
 503
 504     case 'O':
 505       token = FMT_O;
 506       break;
 507
 508     case 'Z':
 509       token = FMT_Z;
 510       break;
 511
 512     case 'F':
 513       token = FMT_F;
 514       break;
 515
 516     case 'E':
 517       switch (next_char (fmt, 0))
 518         {
 519         case 'N':
 520           token = FMT_EN;
 521           break;
 522         case 'S':
 523           token = FMT_ES;
 524           break;
 525         default:
 526           token = FMT_E;
 527           unget_char (fmt);
 528           break;
 529         }
 530       break;
 531
 532     case 'G':
 533       token = FMT_G;
 534       break;
 535
 536     case 'H':
 537       token = FMT_H;
 538       break;
 539
 540     case 'L':
 541       token = FMT_L;
 542       break;
 543
 544     case 'A':
 545       token = FMT_A;
 546       break;
 547
 548     case 'D':
 549       switch (next_char (fmt, 0))
 550         {
 551         case 'P':
 552           token = FMT_DP;
 553           break;
 554         case 'C':
 555           token = FMT_DC;
 556           break;
 557         case 'T':
 558           token = FMT_DT;
 559           break;
 560         default:
 561           token = FMT_D;
 562           unget_char (fmt);
 563           break;
 564         }
 565       break;
 566
 567     case 'R':
 568       switch (next_char (fmt, 0))
 569         {
 570         case 'C':
 571           token = FMT_RC;
 572           break;
 573         case 'D':
 574           token = FMT_RD;
 575           break;
 576         case 'N':
 577           token = FMT_RN;
 578           break;
 579         case 'P':
 580           token = FMT_RP;
 581           break;
 582         case 'U':
 583           token = FMT_RU;
 584           break;
 585         case 'Z':
 586           token = FMT_RZ;
 587           break;
 588         default:
 589           unget_char (fmt);
 590           token = FMT_UNKNOWN;
 591           break;
 592         }
 593       break;
 594
 595     case -1:
 596       token = FMT_END;
 597       break;
 598
 599     default:
 600       token = FMT_UNKNOWN;
 601       break;
 602     }
 603
 604   return token;
 605 }
 606
 607
 608 /* parse_format_list()-- Parse a format list.  Assumes that a left
 609  * paren has already been seen.  Returns a list representing the
 610  * parenthesis node which contains the rest of the list. */
 611
 612 static fnode *
 613 parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
 614 {
 615   fnode *head, *tail;
 616   format_token t, u, t2;
 617   int repeat;
 618   format_data *fmt = dtp->u.p.fmt;
 619   bool seen_data_desc = false;
 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 (notification_std(GFC_STD_GNU) == NOTIFICATION_ERROR)
 874             {
 875               fmt->error = posint_required;
 876               goto finished;
 877             }
 878           else
 879             {
 880               fmt->saved_token = t;
 881               fmt->value = 1;   /* Default width */
 882               notify_std (&dtp->common, GFC_STD_GNU, posint_required);
 883             }
 884         }
 885
 886       get_fnode (fmt, &head, &tail, FMT_L);
 887       tail->u.n = fmt->value;
 888       tail->repeat = repeat;
 889       break;
 890
 891     case FMT_A:
 892       *seen_dd = true;
 893       t = format_lex (fmt);
 894       if (t == FMT_ZERO)
 895         {
 896           fmt->error = zero_width;
 897           goto finished;
 898         }
 899
 900       if (t != FMT_POSINT)
 901         {
 902           fmt->saved_token = t;
 903           fmt->value = -1;              /* Width not present */
 904         }
 905
 906       get_fnode (fmt, &head, &tail, FMT_A);
 907       tail->repeat = repeat;
 908       tail->u.n = fmt->value;
 909       break;
 910
 911     case FMT_D:
 912     case FMT_E:
 913     case FMT_F:
 914     case FMT_G:
 915     case FMT_EN:
 916     case FMT_ES:
 917       *seen_dd = true;
 918       get_fnode (fmt, &head, &tail, t);
 919       tail->repeat = repeat;
 920
 921       u = format_lex (fmt);
 922       if (t == FMT_G && u == FMT_ZERO)
 923         {
 924           *seen_dd = true;
 925           if (notification_std (GFC_STD_F2008) == NOTIFICATION_ERROR
 926               || dtp->u.p.mode == READING)
 927             {
 928               fmt->error = zero_width;
 929               goto finished;
 930             }
 931           tail->u.real.w = 0;
 932           u = format_lex (fmt);
 933           if (u != FMT_PERIOD)
 934             {
 935               fmt->saved_token = u;
 936               break;
 937             }
 938
 939           u = format_lex (fmt);
 940           if (u != FMT_POSINT)
 941             {
 942               fmt->error = posint_required;
 943               goto finished;
 944             }
 945           tail->u.real.d = fmt->value;
 946           break;
 947         }
 948       if (t == FMT_F && dtp->u.p.mode == WRITING)
 949         {
 950           *seen_dd = true;
 951           if (u != FMT_POSINT && u != FMT_ZERO)
 952             {
 953               fmt->error = nonneg_required;
 954               goto finished;
 955             }
 956         }
 957       else if (u != FMT_POSINT)
 958         {
 959           fmt->error = posint_required;
 960           goto finished;
 961         }
 962
 963       tail->u.real.w = fmt->value;
 964       t2 = t;
 965       t = format_lex (fmt);
 966       if (t != FMT_PERIOD)
 967         {
 968           /* We treat a missing decimal descriptor as 0.  Note: This is only
 969              allowed if -std=legacy, otherwise an error occurs.  */
 970           if (compile_options.warn_std != 0)
 971             {
 972               fmt->error = period_required;
 973               goto finished;
 974             }
 975           fmt->saved_token = t;
 976           tail->u.real.d = 0;
 977           tail->u.real.e = -1;
 978           break;
 979         }
 980
 981       t = format_lex (fmt);
 982       if (t != FMT_ZERO && t != FMT_POSINT)
 983         {
 984           fmt->error = nonneg_required;
 985           goto finished;
 986         }
 987
 988       tail->u.real.d = fmt->value;
 989       tail->u.real.e = -1;
 990
 991       if (t2 == FMT_D || t2 == FMT_F)
 992         {
 993           *seen_dd = true;
 994           break;
 995         }
 996
 997       /* Look for optional exponent */
 998       t = format_lex (fmt);
 999       if (t != FMT_E)
1000         fmt->saved_token = t;
1001       else
1002         {
1003           t = format_lex (fmt);
1004           if (t != FMT_POSINT)
1005             {
1006               fmt->error = "Positive exponent width required in format";
1007               goto finished;
1008             }
1009
1010           tail->u.real.e = fmt->value;
1011         }
1012
1013       break;
1014     case FMT_DT:
1015       *seen_dd = true;
1016       get_fnode (fmt, &head, &tail, t);
1017       tail->repeat = repeat;
1018
1019       t = format_lex (fmt);
1020
1021       /* Initialize the vlist to a zero size array.  */
1022       tail->u.udf.vlist= xmalloc (sizeof(gfc_array_i4));
1023       GFC_DESCRIPTOR_DATA(tail->u.udf.vlist) = NULL;
1024       GFC_DIMENSION_SET(tail->u.udf.vlist->dim[0],1, 0, 0);
1025
1026       if (t == FMT_STRING)
1027         {
1028           /* Get pointer to the optional format string.  */
1029           tail->u.udf.string = fmt->string;
1030           tail->u.udf.string_len = fmt->value;
1031           t = format_lex (fmt);
1032         }
1033       if (t == FMT_LPAREN)
1034         {
1035           /* Temporary buffer to hold the vlist values.  */
1036           GFC_INTEGER_4 temp[FARRAY_SIZE];
1037           int i = 0;
1038         loop:
1039           t = format_lex (fmt);
1040           if (t != FMT_POSINT)
1041             {
1042               fmt->error = posint_required;
1043               goto finished;
1044             }
1045           /* Save the positive integer value.  */
1046           temp[i++] = fmt->value;
1047           t = format_lex (fmt);
1048           if (t == FMT_COMMA)
1049             goto loop;
1050           if (t == FMT_RPAREN)
1051             {
1052               /* We have parsed the complete vlist so initialize the
1053                  array descriptor and save it in the format node.  */
1054               gfc_array_i4 *vp = tail->u.udf.vlist;
1055               GFC_DESCRIPTOR_DATA(vp) = xmalloc (i * sizeof(GFC_INTEGER_4));
1056               GFC_DIMENSION_SET(vp->dim[0],1, i, 1);
1057               memcpy (GFC_DESCRIPTOR_DATA(vp), temp, i * sizeof(GFC_INTEGER_4));
1058               break;
1059             }
1060           fmt->error = unexpected_element;
1061           goto finished;
1062         }
1063       fmt->saved_token = t;
1064       break;
1065     case FMT_H:
1066       if (repeat > fmt->format_string_len)
1067         {
1068           fmt->error = bad_hollerith;
1069           goto finished;
1070         }
1071
1072       get_fnode (fmt, &head, &tail, FMT_STRING);
1073       tail->u.string.p = fmt->format_string;
1074       tail->u.string.length = repeat;
1075       tail->repeat = 1;
1076
1077       fmt->format_string += fmt->value;
1078       fmt->format_string_len -= repeat;
1079
1080       break;
1081
1082     case FMT_I:
1083     case FMT_B:
1084     case FMT_O:
1085     case FMT_Z:
1086       *seen_dd = true;
1087       get_fnode (fmt, &head, &tail, t);
1088       tail->repeat = repeat;
1089
1090       t = format_lex (fmt);
1091
1092       if (dtp->u.p.mode == READING)
1093         {
1094           if (t != FMT_POSINT)
1095             {
1096               fmt->error = posint_required;
1097               goto finished;
1098             }
1099         }
1100       else
1101         {
1102           if (t != FMT_ZERO && t != FMT_POSINT)
1103             {
1104               fmt->error = nonneg_required;
1105               goto finished;
1106             }
1107         }
1108
1109       tail->u.integer.w = fmt->value;
1110       tail->u.integer.m = -1;
1111
1112       t = format_lex (fmt);
1113       if (t != FMT_PERIOD)
1114         {
1115           fmt->saved_token = t;
1116         }
1117       else
1118         {
1119           t = format_lex (fmt);
1120           if (t != FMT_ZERO && t != FMT_POSINT)
1121             {
1122               fmt->error = nonneg_required;
1123               goto finished;
1124             }
1125
1126           tail->u.integer.m = fmt->value;
1127         }
1128
1129       if (tail->u.integer.w != 0 && tail->u.integer.m > tail->u.integer.w)
1130         {
1131           fmt->error = "Minimum digits exceeds field width";
1132           goto finished;
1133         }
1134
1135       break;
1136
1137     default:
1138       fmt->error = unexpected_element;
1139       goto finished;
1140     }
1141
1142   /* Between a descriptor and what comes next */
1143  between_desc:
1144   t = format_lex (fmt);
1145   switch (t)
1146     {
1147     case FMT_COMMA:
1148       goto format_item;
1149
1150     case FMT_RPAREN:
1151       goto finished;
1152
1153     case FMT_SLASH:
1154     case FMT_COLON:
1155       get_fnode (fmt, &head, &tail, t);
1156       tail->repeat = 1;
1157       goto optional_comma;
1158
1159     case FMT_END:
1160       fmt->error = unexpected_end;
1161       goto finished;
1162
1163     default:
1164       /* Assume a missing comma, this is a GNU extension */
1165       goto format_item_1;
1166     }
1167
1168   /* Optional comma is a weird between state where we've just finished
1169      reading a colon, slash or P descriptor. */
1170  optional_comma:
1171   t = format_lex (fmt);
1172   switch (t)
1173     {
1174     case FMT_COMMA:
1175       break;
1176
1177     case FMT_RPAREN:
1178       goto finished;
1179
1180     default:                    /* Assume that we have another format item */
1181       fmt->saved_token = t;
1182       break;
1183     }
1184
1185   goto format_item;
1186
1187  finished:
1188
1189   return head;
1190 }
1191
1192
1193 /* format_error()-- Generate an error message for a format statement.
1194  * If the node that gives the location of the error is NULL, the error
1195  * is assumed to happen at parse time, and the current location of the
1196  * parser is shown.
1197  *
1198  * We generate a message showing where the problem is.  We take extra
1199  * care to print only the relevant part of the format if it is longer
1200  * than a standard 80 column display. */
1201
1202 void
1203 format_error (st_parameter_dt *dtp, const fnode *f, const char *message)
1204 {
1205   int width, i, offset;
1206 #define BUFLEN 300
1207   char *p, buffer[BUFLEN];
1208   format_data *fmt = dtp->u.p.fmt;
1209
1210   if (f != NULL)
1211     p = f->source;
1212   else                /* This should not happen.  */
1213     p = dtp->format;
1214
1215   if (message == unexpected_element)
1216     snprintf (buffer, BUFLEN, message, fmt->error_element);
1217   else
1218     snprintf (buffer, BUFLEN, "%s\n", message);
1219
1220   /* Get the offset into the format string where the error occurred.  */
1221   offset = dtp->format_len - (fmt->reversion_ok ?
1222                               (int) strlen(p) : fmt->format_string_len);
1223
1224   width = dtp->format_len;
1225
1226   if (width > 80)
1227     width = 80;
1228
1229   /* Show the format */
1230
1231   p = strchr (buffer, '\0');
1232
1233   if (dtp->format)
1234     memcpy (p, dtp->format, width);
1235
1236   p += width;
1237   *p++ = '\n';
1238
1239   /* Show where the problem is */
1240
1241   for (i = 1; i < offset; i++)
1242     *p++ = ' ';
1243
1244   *p++ = '^';
1245   *p = '\0';
1246
1247   generate_error (&dtp->common, LIBERROR_FORMAT, buffer);
1248 }
1249
1250
1251 /* revert()-- Do reversion of the format.  Control reverts to the left
1252  * parenthesis that matches the rightmost right parenthesis.  From our
1253  * tree structure, we are looking for the rightmost parenthesis node
1254  * at the second level, the first level always being a single
1255  * parenthesis node.  If this node doesn't exit, we use the top
1256  * level. */
1257
1258 static void
1259 revert (st_parameter_dt *dtp)
1260 {
1261   fnode *f, *r;
1262   format_data *fmt = dtp->u.p.fmt;
1263
1264   dtp->u.p.reversion_flag = 1;
1265
1266   r = NULL;
1267
1268   for (f = fmt->array.array[0].u.child; f; f = f->next)
1269     if (f->format == FMT_LPAREN)
1270       r = f;
1271
1272   /* If r is NULL because no node was found, the whole tree will be used */
1273
1274   fmt->array.array[0].current = r;
1275   fmt->array.array[0].count = 0;
1276 }
1277
1278 /* parse_format()-- Parse a format string.  */
1279
1280 void
1281 parse_format (st_parameter_dt *dtp)
1282 {
1283   format_data *fmt;
1284   bool format_cache_ok, seen_data_desc = false;
1285
1286   /* Don't cache for internal units and set an arbitrary limit on the
1287      size of format strings we will cache.  (Avoids memory issues.)
1288      Also, the format_hash_table resides in the current_unit, so
1289      child_dtio procedures would overwrite the parent table  */
1290   format_cache_ok = !is_internal_unit (dtp)
1291                     && (dtp->u.p.current_unit->child_dtio == 0);
1292
1293   /* Lookup format string to see if it has already been parsed.  */
1294   if (format_cache_ok)
1295     {
1296       dtp->u.p.fmt = find_parsed_format (dtp);
1297
1298       if (dtp->u.p.fmt != NULL)
1299         {
1300           dtp->u.p.fmt->reversion_ok = 0;
1301           dtp->u.p.fmt->saved_token = FMT_NONE;
1302           dtp->u.p.fmt->saved_format = NULL;
1303           reset_fnode_counters (dtp);
1304           return;
1305         }
1306     }
1307
1308   /* Not found so proceed as follows.  */
1309
1310   char *fmt_string = fc_strdup_notrim (dtp->format, dtp->format_len);
1311   dtp->format = fmt_string;
1312
1313   dtp->u.p.fmt = fmt = xmalloc (sizeof (format_data));
1314   fmt->format_string = dtp->format;
1315   fmt->format_string_len = dtp->format_len;
1316
1317   fmt->string = NULL;
1318   fmt->saved_token = FMT_NONE;
1319   fmt->error = NULL;
1320   fmt->value = 0;
1321
1322   /* Initialize variables used during traversal of the tree.  */
1323
1324   fmt->reversion_ok = 0;
1325   fmt->saved_format = NULL;
1326
1327   /* Initialize the fnode_array.  */
1328
1329   memset (&(fmt->array), 0, sizeof(fmt->array));
1330
1331   /* Allocate the first format node as the root of the tree.  */
1332
1333   fmt->last = &fmt->array;
1334   fmt->last->next = NULL;
1335   fmt->avail = &fmt->array.array[0];
1336
1337   memset (fmt->avail, 0, sizeof (*fmt->avail));
1338   fmt->avail->format = FMT_LPAREN;
1339   fmt->avail->repeat = 1;
1340   fmt->avail++;
1341
1342   if (format_lex (fmt) == FMT_LPAREN)
1343     fmt->array.array[0].u.child = parse_format_list (dtp, &seen_data_desc);
1344   else
1345     fmt->error = "Missing initial left parenthesis in format";
1346
1347   if (format_cache_ok)
1348     save_parsed_format (dtp);
1349   else
1350     dtp->u.p.format_not_saved = 1;
1351
1352   if (fmt->error)
1353     format_error (dtp, NULL, fmt->error);
1354 }
1355
1356
1357 /* next_format0()-- Get the next format node without worrying about
1358  * reversion.  Returns NULL when we hit the end of the list.
1359  * Parenthesis nodes are incremented after the list has been
1360  * exhausted, other nodes are incremented before they are returned. */
1361
1362 static const fnode *
1363 next_format0 (fnode * f)
1364 {
1365   const fnode *r;
1366
1367   if (f == NULL)
1368     return NULL;
1369
1370   if (f->format != FMT_LPAREN)
1371     {
1372       f->count++;
1373       if (f->count <= f->repeat)
1374         return f;
1375
1376       f->count = 0;
1377       return NULL;
1378     }
1379
1380   /* Deal with a parenthesis node with unlimited format.  */
1381
1382   if (f->repeat == -2)  /* -2 signifies unlimited.  */
1383   for (;;)
1384     {
1385       if (f->current == NULL)
1386         f->current = f->u.child;
1387
1388       for (; f->current != NULL; f->current = f->current->next)
1389         {
1390           r = next_format0 (f->current);
1391           if (r != NULL)
1392             return r;
1393         }
1394     }
1395
1396   /* Deal with a parenthesis node with specific repeat count.  */
1397   for (; f->count < f->repeat; f->count++)
1398     {
1399       if (f->current == NULL)
1400         f->current = f->u.child;
1401
1402       for (; f->current != NULL; f->current = f->current->next)
1403         {
1404           r = next_format0 (f->current);
1405           if (r != NULL)
1406             return r;
1407         }
1408     }
1409
1410   f->count = 0;
1411   return NULL;
1412 }
1413
1414
1415 /* next_format()-- Return the next format node.  If the format list
1416  * ends up being exhausted, we do reversion.  Reversion is only
1417  * allowed if we've seen a data descriptor since the
1418  * initialization or the last reversion.  We return NULL if there
1419  * are no more data descriptors to return (which is an error
1420  * condition). */
1421
1422 const fnode *
1423 next_format (st_parameter_dt *dtp)
1424 {
1425   format_token t;
1426   const fnode *f;
1427   format_data *fmt = dtp->u.p.fmt;
1428
1429   if (fmt->saved_format != NULL)
1430     {                           /* Deal with a pushed-back format node */
1431       f = fmt->saved_format;
1432       fmt->saved_format = NULL;
1433       goto done;
1434     }
1435
1436   f = next_format0 (&fmt->array.array[0]);
1437   if (f == NULL)
1438     {
1439       if (!fmt->reversion_ok)
1440         return NULL;
1441
1442       fmt->reversion_ok = 0;
1443       revert (dtp);
1444
1445       f = next_format0 (&fmt->array.array[0]);
1446       if (f == NULL)
1447         {
1448           format_error (dtp, NULL, reversion_error);
1449           return NULL;
1450         }
1451
1452       /* Push the first reverted token and return a colon node in case
1453        * there are no more data items. */
1454
1455       fmt->saved_format = f;
1456       return &colon_node;
1457     }
1458
1459   /* If this is a data edit descriptor, then reversion has become OK. */
1460  done:
1461   t = f->format;
1462
1463   if (!fmt->reversion_ok &&
1464       (t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F ||
1465        t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
1466        t == FMT_A || t == FMT_D || t == FMT_DT))
1467     fmt->reversion_ok = 1;
1468   return f;
1469 }
1470
1471
1472 /* unget_format()-- Push the given format back so that it will be
1473  * returned on the next call to next_format() without affecting
1474  * counts.  This is necessary when we've encountered a data
1475  * descriptor, but don't know what the data item is yet.  The format
1476  * node is pushed back, and we return control to the main program,
1477  * which calls the library back with the data item (or not). */
1478
1479 void
1480 unget_format (st_parameter_dt *dtp, const fnode *f)
1481 {
1482   dtp->u.p.fmt->saved_format = f;
1483 }
1484