libgfortran/io/format.c

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