libgfortran/io/format.c

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