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