libgfortran/io/format.c

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