libgfortran/io/format.c

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