libgfortran/io/format.c

   1 /* Copyright (C) 2002-2018 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 < &fmt->array.array[FARRAY_SIZE] &&
 270        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 (t == FMT_ZERO)
 874             {
 875               if (notification_std(GFC_STD_GNU) == NOTIFICATION_ERROR)
 876                 {
 877                   fmt->error = "Extension: Zero width after L descriptor";
 878                   goto finished;
 879                 }
 880               else
 881                 notify_std (&dtp->common, GFC_STD_GNU,
 882                             "Zero width after L descriptor");
 883             }
 884           else
 885             {
 886               fmt->saved_token = t;
 887               notify_std (&dtp->common, GFC_STD_GNU,
 888                           "Positive width required with L descriptor");
 889             }
 890           fmt->value = 1;       /* Default width */
 891         }
 892       get_fnode (fmt, &head, &tail, FMT_L);
 893       tail->u.n = fmt->value;
 894       tail->repeat = repeat;
 895       break;
 896
 897     case FMT_A:
 898       *seen_dd = true;
 899       t = format_lex (fmt);
 900       if (t == FMT_ZERO)
 901         {
 902           fmt->error = zero_width;
 903           goto finished;
 904         }
 905
 906       if (t != FMT_POSINT)
 907         {
 908           fmt->saved_token = t;
 909           fmt->value = -1;              /* Width not present */
 910         }
 911
 912       get_fnode (fmt, &head, &tail, FMT_A);
 913       tail->repeat = repeat;
 914       tail->u.n = fmt->value;
 915       break;
 916
 917     case FMT_D:
 918     case FMT_E:
 919     case FMT_F:
 920     case FMT_G:
 921     case FMT_EN:
 922     case FMT_ES:
 923       *seen_dd = true;
 924       get_fnode (fmt, &head, &tail, t);
 925       tail->repeat = repeat;
 926
 927       u = format_lex (fmt);
 928       if (t == FMT_G && u == FMT_ZERO)
 929         {
 930           *seen_dd = true;
 931           if (notification_std (GFC_STD_F2008) == NOTIFICATION_ERROR
 932               || dtp->u.p.mode == READING)
 933             {
 934               fmt->error = zero_width;
 935               goto finished;
 936             }
 937           tail->u.real.w = 0;
 938           u = format_lex (fmt);
 939           if (u != FMT_PERIOD)
 940             {
 941               fmt->saved_token = u;
 942               break;
 943             }
 944
 945           u = format_lex (fmt);
 946           if (u != FMT_POSINT)
 947             {
 948               fmt->error = posint_required;
 949               goto finished;
 950             }
 951           tail->u.real.d = fmt->value;
 952           break;
 953         }
 954       if (t == FMT_F && dtp->u.p.mode == WRITING)
 955         {
 956           *seen_dd = true;
 957           if (u != FMT_POSINT && u != FMT_ZERO)
 958             {
 959               fmt->error = nonneg_required;
 960               goto finished;
 961             }
 962         }
 963       else if (u != FMT_POSINT)
 964         {
 965           fmt->error = posint_required;
 966           goto finished;
 967         }
 968
 969       tail->u.real.w = fmt->value;
 970       t2 = t;
 971       t = format_lex (fmt);
 972       if (t != FMT_PERIOD)
 973         {
 974           /* We treat a missing decimal descriptor as 0.  Note: This is only
 975              allowed if -std=legacy, otherwise an error occurs.  */
 976           if (compile_options.warn_std != 0)
 977             {
 978               fmt->error = period_required;
 979               goto finished;
 980             }
 981           fmt->saved_token = t;
 982           tail->u.real.d = 0;
 983           tail->u.real.e = -1;
 984           break;
 985         }
 986
 987       t = format_lex (fmt);
 988       if (t != FMT_ZERO && t != FMT_POSINT)
 989         {
 990           fmt->error = nonneg_required;
 991           goto finished;
 992         }
 993
 994       tail->u.real.d = fmt->value;
 995       tail->u.real.e = -1;
 996
 997       if (t2 == FMT_D || t2 == FMT_F)
 998         {
 999           *seen_dd = true;
1000           break;
1001         }
1002
1003       /* Look for optional exponent */
1004       t = format_lex (fmt);
1005       if (t != FMT_E)
1006         fmt->saved_token = t;
1007       else
1008         {
1009           t = format_lex (fmt);
1010           if (t != FMT_POSINT)
1011             {
1012               fmt->error = "Positive exponent width required in format";
1013               goto finished;
1014             }
1015
1016           tail->u.real.e = fmt->value;
1017         }
1018
1019       break;
1020     case FMT_DT:
1021       *seen_dd = true;
1022       get_fnode (fmt, &head, &tail, t);
1023       tail->repeat = repeat;
1024
1025       t = format_lex (fmt);
1026
1027       /* Initialize the vlist to a zero size array.  */
1028       tail->u.udf.vlist= xmalloc (sizeof(gfc_array_i4));
1029       GFC_DESCRIPTOR_DATA(tail->u.udf.vlist) = NULL;
1030       GFC_DIMENSION_SET(tail->u.udf.vlist->dim[0],1, 0, 0);
1031
1032       if (t == FMT_STRING)
1033         {
1034           /* Get pointer to the optional format string.  */
1035           tail->u.udf.string = fmt->string;
1036           tail->u.udf.string_len = fmt->value;
1037           t = format_lex (fmt);
1038         }
1039       if (t == FMT_LPAREN)
1040         {
1041           /* Temporary buffer to hold the vlist values.  */
1042           GFC_INTEGER_4 temp[FARRAY_SIZE];
1043           int i = 0;
1044         loop:
1045           t = format_lex (fmt);
1046           if (t != FMT_POSINT)
1047             {
1048               fmt->error = posint_required;
1049               goto finished;
1050             }
1051           /* Save the positive integer value.  */
1052           temp[i++] = fmt->value;
1053           t = format_lex (fmt);
1054           if (t == FMT_COMMA)
1055             goto loop;
1056           if (t == FMT_RPAREN)
1057             {
1058               /* We have parsed the complete vlist so initialize the
1059                  array descriptor and save it in the format node.  */
1060               gfc_array_i4 *vp = tail->u.udf.vlist;
1061               GFC_DESCRIPTOR_DATA(vp) = xmalloc (i * sizeof(GFC_INTEGER_4));
1062               GFC_DIMENSION_SET(vp->dim[0],1, i, 1);
1063               memcpy (GFC_DESCRIPTOR_DATA(vp), temp, i * sizeof(GFC_INTEGER_4));
1064               break;
1065             }
1066           fmt->error = unexpected_element;
1067           goto finished;
1068         }
1069       fmt->saved_token = t;
1070       break;
1071     case FMT_H:
1072       if (repeat > fmt->format_string_len)
1073         {
1074           fmt->error = bad_hollerith;
1075           goto finished;
1076         }
1077
1078       get_fnode (fmt, &head, &tail, FMT_STRING);
1079       tail->u.string.p = fmt->format_string;
1080       tail->u.string.length = repeat;
1081       tail->repeat = 1;
1082
1083       fmt->format_string += fmt->value;
1084       fmt->format_string_len -= repeat;
1085
1086       break;
1087
1088     case FMT_I:
1089     case FMT_B:
1090     case FMT_O:
1091     case FMT_Z:
1092       *seen_dd = true;
1093       get_fnode (fmt, &head, &tail, t);
1094       tail->repeat = repeat;
1095
1096       t = format_lex (fmt);
1097
1098       if (dtp->u.p.mode == READING)
1099         {
1100           if (t != FMT_POSINT)
1101             {
1102               fmt->error = posint_required;
1103               goto finished;
1104             }
1105         }
1106       else
1107         {
1108           if (t != FMT_ZERO && t != FMT_POSINT)
1109             {
1110               fmt->error = nonneg_required;
1111               goto finished;
1112             }
1113         }
1114
1115       tail->u.integer.w = fmt->value;
1116       tail->u.integer.m = -1;
1117
1118       t = format_lex (fmt);
1119       if (t != FMT_PERIOD)
1120         {
1121           fmt->saved_token = t;
1122         }
1123       else
1124         {
1125           t = format_lex (fmt);
1126           if (t != FMT_ZERO && t != FMT_POSINT)
1127             {
1128               fmt->error = nonneg_required;
1129               goto finished;
1130             }
1131
1132           tail->u.integer.m = fmt->value;
1133         }
1134
1135       if (tail->u.integer.w != 0 && tail->u.integer.m > tail->u.integer.w)
1136         {
1137           fmt->error = "Minimum digits exceeds field width";
1138           goto finished;
1139         }
1140
1141       break;
1142
1143     default:
1144       fmt->error = unexpected_element;
1145       goto finished;
1146     }
1147
1148   /* Between a descriptor and what comes next */
1149  between_desc:
1150   t = format_lex (fmt);
1151   switch (t)
1152     {
1153     case FMT_COMMA:
1154       goto format_item;
1155
1156     case FMT_RPAREN:
1157       goto finished;
1158
1159     case FMT_SLASH:
1160     case FMT_COLON:
1161       get_fnode (fmt, &head, &tail, t);
1162       tail->repeat = 1;
1163       goto optional_comma;
1164
1165     case FMT_END:
1166       fmt->error = unexpected_end;
1167       goto finished;
1168
1169     default:
1170       /* Assume a missing comma, this is a GNU extension */
1171       goto format_item_1;
1172     }
1173
1174   /* Optional comma is a weird between state where we've just finished
1175      reading a colon, slash or P descriptor. */
1176  optional_comma:
1177   t = format_lex (fmt);
1178   switch (t)
1179     {
1180     case FMT_COMMA:
1181       break;
1182
1183     case FMT_RPAREN:
1184       goto finished;
1185
1186     default:                    /* Assume that we have another format item */
1187       fmt->saved_token = t;
1188       break;
1189     }
1190
1191   goto format_item;
1192
1193  finished:
1194
1195   return head;
1196 }
1197
1198
1199 /* format_error()-- Generate an error message for a format statement.
1200    If the node that gives the location of the error is NULL, the error
1201    is assumed to happen at parse time, and the current location of the
1202    parser is shown.
1203
1204    We generate a message showing where the problem is.  We take extra
1205    care to print only the relevant part of the format if it is longer
1206    than a standard 80 column display. */
1207
1208 void
1209 format_error (st_parameter_dt *dtp, const fnode *f, const char *message)
1210 {
1211   int width, i, offset;
1212 #define BUFLEN 300
1213   char *p, buffer[BUFLEN];
1214   format_data *fmt = dtp->u.p.fmt;
1215
1216   if (f != NULL)
1217     p = f->source;
1218   else                /* This should not happen.  */
1219     p = dtp->format;
1220
1221   if (message == unexpected_element)
1222     snprintf (buffer, BUFLEN, message, fmt->error_element);
1223   else
1224     snprintf (buffer, BUFLEN, "%s\n", message);
1225
1226   /* Get the offset into the format string where the error occurred.  */
1227   offset = dtp->format_len - (fmt->reversion_ok ?
1228                               (int) strlen(p) : fmt->format_string_len);
1229
1230   width = dtp->format_len;
1231
1232   if (width > 80)
1233     width = 80;
1234
1235   /* Show the format */
1236
1237   p = strchr (buffer, '\0');
1238
1239   if (dtp->format)
1240     memcpy (p, dtp->format, width);
1241
1242   p += width;
1243   *p++ = '\n';
1244
1245   /* Show where the problem is */
1246
1247   for (i = 1; i < offset; i++)
1248     *p++ = ' ';
1249
1250   *p++ = '^';
1251   *p = '\0';
1252
1253   generate_error (&dtp->common, LIBERROR_FORMAT, buffer);
1254 }
1255
1256
1257 /* revert()-- Do reversion of the format.  Control reverts to the left
1258    parenthesis that matches the rightmost right parenthesis.  From our
1259    tree structure, we are looking for the rightmost parenthesis node
1260    at the second level, the first level always being a single
1261    parenthesis node.  If this node doesn't exit, we use the top
1262    level. */
1263
1264 static void
1265 revert (st_parameter_dt *dtp)
1266 {
1267   fnode *f, *r;
1268   format_data *fmt = dtp->u.p.fmt;
1269
1270   dtp->u.p.reversion_flag = 1;
1271
1272   r = NULL;
1273
1274   for (f = fmt->array.array[0].u.child; f; f = f->next)
1275     if (f->format == FMT_LPAREN)
1276       r = f;
1277
1278   /* If r is NULL because no node was found, the whole tree will be used */
1279
1280   fmt->array.array[0].current = r;
1281   fmt->array.array[0].count = 0;
1282 }
1283
1284 /* parse_format()-- Parse a format string.  */
1285
1286 void
1287 parse_format (st_parameter_dt *dtp)
1288 {
1289   format_data *fmt;
1290   bool format_cache_ok, seen_data_desc = false;
1291
1292   /* Don't cache for internal units and set an arbitrary limit on the
1293      size of format strings we will cache.  (Avoids memory issues.)
1294      Also, the format_hash_table resides in the current_unit, so
1295      child_dtio procedures would overwrite the parent table  */
1296   format_cache_ok = !is_internal_unit (dtp)
1297                     && (dtp->u.p.current_unit->child_dtio == 0);
1298
1299   /* Lookup format string to see if it has already been parsed.  */
1300   if (format_cache_ok)
1301     {
1302       dtp->u.p.fmt = find_parsed_format (dtp);
1303
1304       if (dtp->u.p.fmt != NULL)
1305         {
1306           dtp->u.p.fmt->reversion_ok = 0;
1307           dtp->u.p.fmt->saved_token = FMT_NONE;
1308           dtp->u.p.fmt->saved_format = NULL;
1309           reset_fnode_counters (dtp);
1310           return;
1311         }
1312     }
1313
1314   /* Not found so proceed as follows.  */
1315
1316   char *fmt_string = fc_strdup_notrim (dtp->format, dtp->format_len);
1317   dtp->format = fmt_string;
1318
1319   dtp->u.p.fmt = fmt = xmalloc (sizeof (format_data));
1320   fmt->format_string = dtp->format;
1321   fmt->format_string_len = dtp->format_len;
1322
1323   fmt->string = NULL;
1324   fmt->saved_token = FMT_NONE;
1325   fmt->error = NULL;
1326   fmt->value = 0;
1327
1328   /* Initialize variables used during traversal of the tree.  */
1329
1330   fmt->reversion_ok = 0;
1331   fmt->saved_format = NULL;
1332
1333   /* Initialize the fnode_array.  */
1334
1335   memset (&(fmt->array), 0, sizeof(fmt->array));
1336
1337   /* Allocate the first format node as the root of the tree.  */
1338
1339   fmt->last = &fmt->array;
1340   fmt->last->next = NULL;
1341   fmt->avail = &fmt->array.array[0];
1342
1343   memset (fmt->avail, 0, sizeof (*fmt->avail));
1344   fmt->avail->format = FMT_LPAREN;
1345   fmt->avail->repeat = 1;
1346   fmt->avail++;
1347
1348   if (format_lex (fmt) == FMT_LPAREN)
1349     fmt->array.array[0].u.child = parse_format_list (dtp, &seen_data_desc);
1350   else
1351     fmt->error = "Missing initial left parenthesis in format";
1352
1353   if (format_cache_ok)
1354     save_parsed_format (dtp);
1355   else
1356     dtp->u.p.format_not_saved = 1;
1357
1358   if (fmt->error)
1359     format_error (dtp, NULL, fmt->error);
1360 }
1361
1362
1363 /* next_format0()-- Get the next format node without worrying about
1364    reversion.  Returns NULL when we hit the end of the list.
1365    Parenthesis nodes are incremented after the list has been
1366    exhausted, other nodes are incremented before they are returned. */
1367
1368 static const fnode *
1369 next_format0 (fnode *f)
1370 {
1371   const fnode *r;
1372
1373   if (f == NULL)
1374     return NULL;
1375
1376   if (f->format != FMT_LPAREN)
1377     {
1378       f->count++;
1379       if (f->count <= f->repeat)
1380         return f;
1381
1382       f->count = 0;
1383       return NULL;
1384     }
1385
1386   /* Deal with a parenthesis node with unlimited format.  */
1387
1388   if (f->repeat == -2)  /* -2 signifies unlimited.  */
1389   for (;;)
1390     {
1391       if (f->current == NULL)
1392         f->current = f->u.child;
1393
1394       for (; f->current != NULL; f->current = f->current->next)
1395         {
1396           r = next_format0 (f->current);
1397           if (r != NULL)
1398             return r;
1399         }
1400     }
1401
1402   /* Deal with a parenthesis node with specific repeat count.  */
1403   for (; f->count < f->repeat; f->count++)
1404     {
1405       if (f->current == NULL)
1406         f->current = f->u.child;
1407
1408       for (; f->current != NULL; f->current = f->current->next)
1409         {
1410           r = next_format0 (f->current);
1411           if (r != NULL)
1412             return r;
1413         }
1414     }
1415
1416   f->count = 0;
1417   return NULL;
1418 }
1419
1420
1421 /* next_format()-- Return the next format node.  If the format list
1422    ends up being exhausted, we do reversion.  Reversion is only
1423    allowed if we've seen a data descriptor since the
1424    initialization or the last reversion.  We return NULL if there
1425    are no more data descriptors to return (which is an error
1426    condition).  */
1427
1428 const fnode *
1429 next_format (st_parameter_dt *dtp)
1430 {
1431   format_token t;
1432   const fnode *f;
1433   format_data *fmt = dtp->u.p.fmt;
1434
1435   if (fmt->saved_format != NULL)
1436     {                           /* Deal with a pushed-back format node */
1437       f = fmt->saved_format;
1438       fmt->saved_format = NULL;
1439       goto done;
1440     }
1441
1442   f = next_format0 (&fmt->array.array[0]);
1443   if (f == NULL)
1444     {
1445       if (!fmt->reversion_ok)
1446         return NULL;
1447
1448       fmt->reversion_ok = 0;
1449       revert (dtp);
1450
1451       f = next_format0 (&fmt->array.array[0]);
1452       if (f == NULL)
1453         {
1454           format_error (dtp, NULL, reversion_error);
1455           return NULL;
1456         }
1457
1458       /* Push the first reverted token and return a colon node in case
1459          there are no more data items.  */
1460
1461       fmt->saved_format = f;
1462       return &colon_node;
1463     }
1464
1465   /* If this is a data edit descriptor, then reversion has become OK. */
1466  done:
1467   t = f->format;
1468
1469   if (!fmt->reversion_ok &&
1470       (t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F ||
1471        t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
1472        t == FMT_A || t == FMT_D || t == FMT_DT))
1473     fmt->reversion_ok = 1;
1474   return f;
1475 }
1476
1477
1478 /* unget_format()-- Push the given format back so that it will be
1479    returned on the next call to next_format() without affecting
1480    counts.  This is necessary when we've encountered a data
1481    descriptor, but don't know what the data item is yet.  The format
1482    node is pushed back, and we return control to the main program,
1483    which calls the library back with the data item (or not). */
1484
1485 void
1486 unget_format (st_parameter_dt *dtp, const fnode *f)
1487 {
1488   dtp->u.p.fmt->saved_format = f;
1489 }
1490