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       if (t != FMT_COMMA && t != FMT_RPAREN && t != FMT_SLASH)
 710         {
 711           fmt->error = "Comma required after P descriptor";
 712           goto finished;
 713         }
 714
 715       fmt->saved_token = t;
 716       goto optional_comma;
 717
 718     case FMT_P:         /* P and X require a prior number */
 719       fmt->error = "P descriptor requires leading scale factor";
 720       goto finished;
 721
 722     case FMT_X:
 723 /*
 724    EXTENSION!
 725
 726    If we would be pedantic in the library, we would have to reject
 727    an X descriptor without an integer prefix:
 728
 729       fmt->error = "X descriptor requires leading space count";
 730       goto finished;
 731
 732    However, this is an extension supported by many Fortran compilers,
 733    including Cray, HP, AIX, and IRIX.  Therefore, we allow it in the
 734    runtime library, and make the front end reject it if the compiler
 735    is in pedantic mode.  The interpretation of 'X' is '1X'.
 736 */
 737       get_fnode (fmt, &head, &tail, FMT_X);
 738       tail->repeat = 1;
 739       tail->u.k = 1;
 740       goto between_desc;
 741
 742     case FMT_STRING:
 743       /* TODO: Find out why it is necessary to turn off format caching.  */
 744       saveit = false;
 745       get_fnode (fmt, &head, &tail, FMT_STRING);
 746       tail->u.string.p = fmt->string;
 747       tail->u.string.length = fmt->value;
 748       tail->repeat = 1;
 749       goto optional_comma;
 750
 751     case FMT_RC:
 752     case FMT_RD:
 753     case FMT_RN:
 754     case FMT_RP:
 755     case FMT_RU:
 756     case FMT_RZ:
 757       notify_std (&dtp->common, GFC_STD_F2003, "Fortran 2003: Round "
 758                   "descriptor not allowed");
 759       get_fnode (fmt, &head, &tail, t);
 760       tail->repeat = 1;
 761       goto between_desc;
 762
 763     case FMT_DC:
 764     case FMT_DP:
 765       notify_std (&dtp->common, GFC_STD_F2003, "Fortran 2003: DC or DP "
 766                   "descriptor not allowed");
 767     /* Fall through.  */
 768     case FMT_S:
 769     case FMT_SS:
 770     case FMT_SP:
 771     case FMT_BN:
 772     case FMT_BZ:
 773       get_fnode (fmt, &head, &tail, t);
 774       tail->repeat = 1;
 775       goto between_desc;
 776
 777     case FMT_COLON:
 778       get_fnode (fmt, &head, &tail, FMT_COLON);
 779       tail->repeat = 1;
 780       goto optional_comma;
 781
 782     case FMT_SLASH:
 783       get_fnode (fmt, &head, &tail, FMT_SLASH);
 784       tail->repeat = 1;
 785       tail->u.r = 1;
 786       goto optional_comma;
 787
 788     case FMT_DOLLAR:
 789       get_fnode (fmt, &head, &tail, FMT_DOLLAR);
 790       tail->repeat = 1;
 791       notify_std (&dtp->common, GFC_STD_GNU, "Extension: $ descriptor");
 792       goto between_desc;
 793
 794     case FMT_T:
 795     case FMT_TL:
 796     case FMT_TR:
 797       t2 = format_lex (fmt);
 798       if (t2 != FMT_POSINT)
 799         {
 800           fmt->error = posint_required;
 801           goto finished;
 802         }
 803       get_fnode (fmt, &head, &tail, t);
 804       tail->u.n = fmt->value;
 805       tail->repeat = 1;
 806       goto between_desc;
 807
 808     case FMT_I:
 809     case FMT_B:
 810     case FMT_O:
 811     case FMT_Z:
 812     case FMT_E:
 813     case FMT_EN:
 814     case FMT_ES:
 815     case FMT_D:
 816     case FMT_L:
 817     case FMT_A:
 818     case FMT_F:
 819     case FMT_G:
 820       repeat = 1;
 821       goto data_desc;
 822
 823     case FMT_H:
 824       get_fnode (fmt, &head, &tail, FMT_STRING);
 825       if (fmt->format_string_len < 1)
 826         {
 827           fmt->error = bad_hollerith;
 828           goto finished;
 829         }
 830
 831       tail->u.string.p = fmt->format_string;
 832       tail->u.string.length = 1;
 833       tail->repeat = 1;
 834
 835       fmt->format_string++;
 836       fmt->format_string_len--;
 837
 838       goto between_desc;
 839
 840     case FMT_END:
 841       fmt->error = unexpected_end;
 842       goto finished;
 843
 844     case FMT_BADSTRING:
 845       goto finished;
 846
 847     case FMT_RPAREN:
 848       goto finished;
 849
 850     default:
 851       fmt->error = unexpected_element;
 852       goto finished;
 853     }
 854
 855   /* In this state, t must currently be a data descriptor.  Deal with
 856      things that can/must follow the descriptor */
 857  data_desc:
 858   switch (t)
 859     {
 860     case FMT_L:
 861       t = format_lex (fmt);
 862       if (t != FMT_POSINT)
 863         {
 864           if (notification_std(GFC_STD_GNU) == ERROR)
 865             {
 866               fmt->error = posint_required;
 867               goto finished;
 868             }
 869           else
 870             {
 871               fmt->saved_token = t;
 872               fmt->value = 1;   /* Default width */
 873               notify_std (&dtp->common, GFC_STD_GNU, posint_required);
 874             }
 875         }
 876
 877       get_fnode (fmt, &head, &tail, FMT_L);
 878       tail->u.n = fmt->value;
 879       tail->repeat = repeat;
 880       break;
 881
 882     case FMT_A:
 883       t = format_lex (fmt);
 884       if (t == FMT_ZERO)
 885         {
 886           fmt->error = zero_width;
 887           goto finished;
 888         }
 889
 890       if (t != FMT_POSINT)
 891         {
 892           fmt->saved_token = t;
 893           fmt->value = -1;              /* Width not present */
 894         }
 895
 896       get_fnode (fmt, &head, &tail, FMT_A);
 897       tail->repeat = repeat;
 898       tail->u.n = fmt->value;
 899       break;
 900
 901     case FMT_D:
 902     case FMT_E:
 903     case FMT_F:
 904     case FMT_G:
 905     case FMT_EN:
 906     case FMT_ES:
 907       get_fnode (fmt, &head, &tail, t);
 908       tail->repeat = repeat;
 909
 910       u = format_lex (fmt);
 911       if (t == FMT_G && u == FMT_ZERO)
 912         {
 913           if (notification_std (GFC_STD_F2008) == ERROR
 914               || dtp->u.p.mode == READING)
 915             {
 916               fmt->error = zero_width;
 917               goto finished;
 918             }
 919           tail->u.real.w = 0;
 920           u = format_lex (fmt);
 921           if (u != FMT_PERIOD)
 922             {
 923               fmt->saved_token = u;
 924               break;
 925             }
 926
 927           u = format_lex (fmt);
 928           if (u != FMT_POSINT)
 929             {
 930               fmt->error = posint_required;
 931               goto finished;
 932             }
 933           tail->u.real.d = fmt->value;
 934           break;
 935         }
 936       if (t == FMT_F && dtp->u.p.mode == WRITING)
 937         {
 938           if (u != FMT_POSINT && u != FMT_ZERO)
 939             {
 940               fmt->error = nonneg_required;
 941               goto finished;
 942             }
 943         }
 944       else if (u != FMT_POSINT)
 945         {
 946           fmt->error = posint_required;
 947           goto finished;
 948         }
 949
 950       tail->u.real.w = fmt->value;
 951       t2 = t;
 952       t = format_lex (fmt);
 953       if (t != FMT_PERIOD)
 954         {
 955           /* We treat a missing decimal descriptor as 0.  Note: This is only
 956              allowed if -std=legacy, otherwise an error occurs.  */
 957           if (compile_options.warn_std != 0)
 958             {
 959               fmt->error = period_required;
 960               goto finished;
 961             }
 962           fmt->saved_token = t;
 963           tail->u.real.d = 0;
 964           tail->u.real.e = -1;
 965           break;
 966         }
 967
 968       t = format_lex (fmt);
 969       if (t != FMT_ZERO && t != FMT_POSINT)
 970         {
 971           fmt->error = nonneg_required;
 972           goto finished;
 973         }
 974
 975       tail->u.real.d = fmt->value;
 976       tail->u.real.e = -1;
 977
 978       if (t2 == FMT_D || t2 == FMT_F)
 979         break;
 980
 981
 982       /* Look for optional exponent */
 983       t = format_lex (fmt);
 984       if (t != FMT_E)
 985         fmt->saved_token = t;
 986       else
 987         {
 988           t = format_lex (fmt);
 989           if (t != FMT_POSINT)
 990             {
 991               fmt->error = "Positive exponent width required in format";
 992               goto finished;
 993             }
 994
 995           tail->u.real.e = fmt->value;
 996         }
 997
 998       break;
 999
1000     case FMT_H:
1001       if (repeat > fmt->format_string_len)
1002         {
1003           fmt->error = bad_hollerith;
1004           goto finished;
1005         }
1006
1007       get_fnode (fmt, &head, &tail, FMT_STRING);
1008       tail->u.string.p = fmt->format_string;
1009       tail->u.string.length = repeat;
1010       tail->repeat = 1;
1011
1012       fmt->format_string += fmt->value;
1013       fmt->format_string_len -= repeat;
1014
1015       break;
1016
1017     case FMT_I:
1018     case FMT_B:
1019     case FMT_O:
1020     case FMT_Z:
1021       get_fnode (fmt, &head, &tail, t);
1022       tail->repeat = repeat;
1023
1024       t = format_lex (fmt);
1025
1026       if (dtp->u.p.mode == READING)
1027         {
1028           if (t != FMT_POSINT)
1029             {
1030               fmt->error = posint_required;
1031               goto finished;
1032             }
1033         }
1034       else
1035         {
1036           if (t != FMT_ZERO && t != FMT_POSINT)
1037             {
1038               fmt->error = nonneg_required;
1039               goto finished;
1040             }
1041         }
1042
1043       tail->u.integer.w = fmt->value;
1044       tail->u.integer.m = -1;
1045
1046       t = format_lex (fmt);
1047       if (t != FMT_PERIOD)
1048         {
1049           fmt->saved_token = t;
1050         }
1051       else
1052         {
1053           t = format_lex (fmt);
1054           if (t != FMT_ZERO && t != FMT_POSINT)
1055             {
1056               fmt->error = nonneg_required;
1057               goto finished;
1058             }
1059
1060           tail->u.integer.m = fmt->value;
1061         }
1062
1063       if (tail->u.integer.w != 0 && tail->u.integer.m > tail->u.integer.w)
1064         {
1065           fmt->error = "Minimum digits exceeds field width";
1066           goto finished;
1067         }
1068
1069       break;
1070
1071     default:
1072       fmt->error = unexpected_element;
1073       goto finished;
1074     }
1075
1076   /* Between a descriptor and what comes next */
1077  between_desc:
1078   t = format_lex (fmt);
1079   switch (t)
1080     {
1081     case FMT_COMMA:
1082       goto format_item;
1083
1084     case FMT_RPAREN:
1085       goto finished;
1086
1087     case FMT_SLASH:
1088     case FMT_COLON:
1089       get_fnode (fmt, &head, &tail, t);
1090       tail->repeat = 1;
1091       goto optional_comma;
1092
1093     case FMT_END:
1094       fmt->error = unexpected_end;
1095       goto finished;
1096
1097     default:
1098       /* Assume a missing comma, this is a GNU extension */
1099       goto format_item_1;
1100     }
1101
1102   /* Optional comma is a weird between state where we've just finished
1103      reading a colon, slash or P descriptor. */
1104  optional_comma:
1105   t = format_lex (fmt);
1106   switch (t)
1107     {
1108     case FMT_COMMA:
1109       break;
1110
1111     case FMT_RPAREN:
1112       goto finished;
1113
1114     default:                    /* Assume that we have another format item */
1115       fmt->saved_token = t;
1116       break;
1117     }
1118
1119   goto format_item;
1120
1121  finished:
1122
1123   *save_ok = saveit;
1124
1125   return head;
1126 }
1127
1128
1129 /* format_error()-- Generate an error message for a format statement.
1130  * If the node that gives the location of the error is NULL, the error
1131  * is assumed to happen at parse time, and the current location of the
1132  * parser is shown.
1133  *
1134  * We generate a message showing where the problem is.  We take extra
1135  * care to print only the relevant part of the format if it is longer
1136  * than a standard 80 column display. */
1137
1138 void
1139 format_error (st_parameter_dt *dtp, const fnode *f, const char *message)
1140 {
1141   int width, i, j, offset;
1142   char *p, buffer[300];
1143   format_data *fmt = dtp->u.p.fmt;
1144
1145   if (f != NULL)
1146     fmt->format_string = f->source;
1147
1148   if (message == unexpected_element)
1149     sprintf (buffer, message, fmt->error_element);
1150   else
1151     sprintf (buffer, "%s\n", message);
1152
1153   j = fmt->format_string - dtp->format;
1154
1155   offset = (j > 60) ? j - 40 : 0;
1156
1157   j -= offset;
1158   width = dtp->format_len - offset;
1159
1160   if (width > 80)
1161     width = 80;
1162
1163   /* Show the format */
1164
1165   p = strchr (buffer, '\0');
1166
1167   memcpy (p, dtp->format + offset, width);
1168
1169   p += width;
1170   *p++ = '\n';
1171
1172   /* Show where the problem is */
1173
1174   for (i = 1; i < j; i++)
1175     *p++ = ' ';
1176
1177   *p++ = '^';
1178   *p = '\0';
1179
1180   generate_error (&dtp->common, LIBERROR_FORMAT, buffer);
1181 }
1182
1183
1184 /* revert()-- Do reversion of the format.  Control reverts to the left
1185  * parenthesis that matches the rightmost right parenthesis.  From our
1186  * tree structure, we are looking for the rightmost parenthesis node
1187  * at the second level, the first level always being a single
1188  * parenthesis node.  If this node doesn't exit, we use the top
1189  * level. */
1190
1191 static void
1192 revert (st_parameter_dt *dtp)
1193 {
1194   fnode *f, *r;
1195   format_data *fmt = dtp->u.p.fmt;
1196
1197   dtp->u.p.reversion_flag = 1;
1198
1199   r = NULL;
1200
1201   for (f = fmt->array.array[0].u.child; f; f = f->next)
1202     if (f->format == FMT_LPAREN)
1203       r = f;
1204
1205   /* If r is NULL because no node was found, the whole tree will be used */
1206
1207   fmt->array.array[0].current = r;
1208   fmt->array.array[0].count = 0;
1209 }
1210
1211 /* parse_format()-- Parse a format string.  */
1212
1213 void
1214 parse_format (st_parameter_dt *dtp)
1215 {
1216   format_data *fmt;
1217   bool format_cache_ok;
1218
1219   format_cache_ok = !is_internal_unit (dtp);
1220
1221   /* Lookup format string to see if it has already been parsed.  */
1222   if (format_cache_ok)
1223     {
1224       dtp->u.p.fmt = find_parsed_format (dtp);
1225
1226       if (dtp->u.p.fmt != NULL)
1227         {
1228           dtp->u.p.fmt->reversion_ok = 0;
1229           dtp->u.p.fmt->saved_token = FMT_NONE;
1230           dtp->u.p.fmt->saved_format = NULL;
1231           reset_fnode_counters (dtp);
1232           return;
1233         }
1234     }
1235
1236   /* Not found so proceed as follows.  */
1237
1238   dtp->u.p.fmt = fmt = get_mem (sizeof (format_data));
1239   fmt->format_string = dtp->format;
1240   fmt->format_string_len = dtp->format_len;
1241
1242   fmt->string = NULL;
1243   fmt->saved_token = FMT_NONE;
1244   fmt->error = NULL;
1245   fmt->value = 0;
1246
1247   /* Initialize variables used during traversal of the tree.  */
1248
1249   fmt->reversion_ok = 0;
1250   fmt->saved_format = NULL;
1251
1252   /* Allocate the first format node as the root of the tree.  */
1253
1254   fmt->last = &fmt->array;
1255   fmt->last->next = NULL;
1256   fmt->avail = &fmt->array.array[0];
1257
1258   memset (fmt->avail, 0, sizeof (*fmt->avail));
1259   fmt->avail->format = FMT_LPAREN;
1260   fmt->avail->repeat = 1;
1261   fmt->avail++;
1262
1263   if (format_lex (fmt) == FMT_LPAREN)
1264     fmt->array.array[0].u.child = parse_format_list (dtp, &format_cache_ok);
1265   else
1266     fmt->error = "Missing initial left parenthesis in format";
1267
1268   if (fmt->error)
1269     {
1270       format_error (dtp, NULL, fmt->error);
1271       free_format_hash_table (dtp->u.p.current_unit);
1272       return;
1273     }
1274
1275   if (format_cache_ok)
1276     save_parsed_format (dtp);
1277   else
1278     dtp->u.p.format_not_saved = 1;
1279 }
1280
1281
1282 /* next_format0()-- Get the next format node without worrying about
1283  * reversion.  Returns NULL when we hit the end of the list.
1284  * Parenthesis nodes are incremented after the list has been
1285  * exhausted, other nodes are incremented before they are returned. */
1286
1287 static const fnode *
1288 next_format0 (fnode * f)
1289 {
1290   const fnode *r;
1291
1292   if (f == NULL)
1293     return NULL;
1294
1295   if (f->format != FMT_LPAREN)
1296     {
1297       f->count++;
1298       if (f->count <= f->repeat)
1299         return f;
1300
1301       f->count = 0;
1302       return NULL;
1303     }
1304
1305   /* Deal with a parenthesis node with unlimited format.  */
1306
1307   if (f->repeat == -2)  /* -2 signifies unlimited.  */
1308   for (;;)
1309     {
1310       if (f->current == NULL)
1311         f->current = f->u.child;
1312
1313       for (; f->current != NULL; f->current = f->current->next)
1314         {
1315           r = next_format0 (f->current);
1316           if (r != NULL)
1317             return r;
1318         }
1319     }
1320
1321   /* Deal with a parenthesis node with specific repeat count.  */
1322   for (; f->count < f->repeat; f->count++)
1323     {
1324       if (f->current == NULL)
1325         f->current = f->u.child;
1326
1327       for (; f->current != NULL; f->current = f->current->next)
1328         {
1329           r = next_format0 (f->current);
1330           if (r != NULL)
1331             return r;
1332         }
1333     }
1334
1335   f->count = 0;
1336   return NULL;
1337 }
1338
1339
1340 /* next_format()-- Return the next format node.  If the format list
1341  * ends up being exhausted, we do reversion.  Reversion is only
1342  * allowed if we've seen a data descriptor since the
1343  * initialization or the last reversion.  We return NULL if there
1344  * are no more data descriptors to return (which is an error
1345  * condition). */
1346
1347 const fnode *
1348 next_format (st_parameter_dt *dtp)
1349 {
1350   format_token t;
1351   const fnode *f;
1352   format_data *fmt = dtp->u.p.fmt;
1353
1354   if (fmt->saved_format != NULL)
1355     {                           /* Deal with a pushed-back format node */
1356       f = fmt->saved_format;
1357       fmt->saved_format = NULL;
1358       goto done;
1359     }
1360
1361   f = next_format0 (&fmt->array.array[0]);
1362   if (f == NULL)
1363     {
1364       if (!fmt->reversion_ok)
1365         return NULL;
1366
1367       fmt->reversion_ok = 0;
1368       revert (dtp);
1369
1370       f = next_format0 (&fmt->array.array[0]);
1371       if (f == NULL)
1372         {
1373           format_error (dtp, NULL, reversion_error);
1374           return NULL;
1375         }
1376
1377       /* Push the first reverted token and return a colon node in case
1378        * there are no more data items. */
1379
1380       fmt->saved_format = f;
1381       return &colon_node;
1382     }
1383
1384   /* If this is a data edit descriptor, then reversion has become OK. */
1385  done:
1386   t = f->format;
1387
1388   if (!fmt->reversion_ok &&
1389       (t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F ||
1390        t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
1391        t == FMT_A || t == FMT_D))
1392     fmt->reversion_ok = 1;
1393   return f;
1394 }
1395
1396
1397 /* unget_format()-- Push the given format back so that it will be
1398  * returned on the next call to next_format() without affecting
1399  * counts.  This is necessary when we've encountered a data
1400  * descriptor, but don't know what the data item is yet.  The format
1401  * node is pushed back, and we return control to the main program,
1402  * which calls the library back with the data item (or not). */
1403
1404 void
1405 unget_format (st_parameter_dt *dtp, const fnode *f)
1406 {
1407   dtp->u.p.fmt->saved_format = f;
1408 }
1409