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_LPAREN;
 318       break;
 319
 320     case ')':
 321       token = FMT_RPAREN;
 322       break;
 323
 324     case '-':
 325       negative_flag = 1;
 326       /* Fall Through */
 327
 328     case '+':
 329       c = next_char (fmt, 0);
 330       if (!isdigit (c))
 331         {
 332           token = FMT_UNKNOWN;
 333           break;
 334         }
 335
 336       fmt->value = c - '0';
 337
 338       for (;;)
 339         {
 340           c = next_char (fmt, 0);
 341           if (!isdigit (c))
 342             break;
 343
 344           fmt->value = 10 * fmt->value + c - '0';
 345         }
 346
 347       unget_char (fmt);
 348
 349       if (negative_flag)
 350         fmt->value = -fmt->value;
 351       token = FMT_SIGNED_INT;
 352       break;
 353
 354     case '0':
 355     case '1':
 356     case '2':
 357     case '3':
 358     case '4':
 359     case '5':
 360     case '6':
 361     case '7':
 362     case '8':
 363     case '9':
 364       fmt->value = c - '0';
 365
 366       for (;;)
 367         {
 368           c = next_char (fmt, 0);
 369           if (!isdigit (c))
 370             break;
 371
 372           fmt->value = 10 * fmt->value + c - '0';
 373         }
 374
 375       unget_char (fmt);
 376       token = (fmt->value == 0) ? FMT_ZERO : FMT_POSINT;
 377       break;
 378
 379     case '.':
 380       token = FMT_PERIOD;
 381       break;
 382
 383     case ',':
 384       token = FMT_COMMA;
 385       break;
 386
 387     case ':':
 388       token = FMT_COLON;
 389       break;
 390
 391     case '/':
 392       token = FMT_SLASH;
 393       break;
 394
 395     case '$':
 396       token = FMT_DOLLAR;
 397       break;
 398
 399     case 'T':
 400       switch (next_char (fmt, 0))
 401         {
 402         case 'L':
 403           token = FMT_TL;
 404           break;
 405         case 'R':
 406           token = FMT_TR;
 407           break;
 408         default:
 409           token = FMT_T;
 410           unget_char (fmt);
 411           break;
 412         }
 413
 414       break;
 415
 416     case 'X':
 417       token = FMT_X;
 418       break;
 419
 420     case 'S':
 421       switch (next_char (fmt, 0))
 422         {
 423         case 'S':
 424           token = FMT_SS;
 425           break;
 426         case 'P':
 427           token = FMT_SP;
 428           break;
 429         default:
 430           token = FMT_S;
 431           unget_char (fmt);
 432           break;
 433         }
 434
 435       break;
 436
 437     case 'B':
 438       switch (next_char (fmt, 0))
 439         {
 440         case 'N':
 441           token = FMT_BN;
 442           break;
 443         case 'Z':
 444           token = FMT_BZ;
 445           break;
 446         default:
 447           token = FMT_B;
 448           unget_char (fmt);
 449           break;
 450         }
 451
 452       break;
 453
 454     case '\'':
 455     case '"':
 456       delim = c;
 457
 458       fmt->string = fmt->format_string;
 459       fmt->value = 0;           /* This is the length of the string */
 460
 461       for (;;)
 462         {
 463           c = next_char (fmt, 1);
 464           if (c == -1)
 465             {
 466               token = FMT_BADSTRING;
 467               fmt->error = bad_string;
 468               break;
 469             }
 470
 471           if (c == delim)
 472             {
 473               c = next_char (fmt, 1);
 474
 475               if (c == -1)
 476                 {
 477                   token = FMT_BADSTRING;
 478                   fmt->error = bad_string;
 479                   break;
 480                 }
 481
 482               if (c != delim)
 483                 {
 484                   unget_char (fmt);
 485                   token = FMT_STRING;
 486                   break;
 487                 }
 488             }
 489
 490           fmt->value++;
 491         }
 492
 493       break;
 494
 495     case 'P':
 496       token = FMT_P;
 497       break;
 498
 499     case 'I':
 500       token = FMT_I;
 501       break;
 502
 503     case 'O':
 504       token = FMT_O;
 505       break;
 506
 507     case 'Z':
 508       token = FMT_Z;
 509       break;
 510
 511     case 'F':
 512       token = FMT_F;
 513       break;
 514
 515     case 'E':
 516       switch (next_char (fmt, 0))
 517         {
 518         case 'N':
 519           token = FMT_EN;
 520           break;
 521         case 'S':
 522           token = FMT_ES;
 523           break;
 524         default:
 525           token = FMT_E;
 526           unget_char (fmt);
 527           break;
 528         }
 529       break;
 530
 531     case 'G':
 532       token = FMT_G;
 533       break;
 534
 535     case 'H':
 536       token = FMT_H;
 537       break;
 538
 539     case 'L':
 540       token = FMT_L;
 541       break;
 542
 543     case 'A':
 544       token = FMT_A;
 545       break;
 546
 547     case 'D':
 548       switch (next_char (fmt, 0))
 549         {
 550         case 'P':
 551           token = FMT_DP;
 552           break;
 553         case 'C':
 554           token = FMT_DC;
 555           break;
 556         default:
 557           token = FMT_D;
 558           unget_char (fmt);
 559           break;
 560         }
 561       break;
 562
 563     case -1:
 564       token = FMT_END;
 565       break;
 566
 567     default:
 568       token = FMT_UNKNOWN;
 569       break;
 570     }
 571
 572   return token;
 573 }
 574
 575
 576 /* parse_format_list()-- Parse a format list.  Assumes that a left
 577  * paren has already been seen.  Returns a list representing the
 578  * parenthesis node which contains the rest of the list. */
 579
 580 static fnode *
 581 parse_format_list (st_parameter_dt *dtp, bool *save_ok)
 582 {
 583   fnode *head, *tail;
 584   format_token t, u, t2;
 585   int repeat;
 586   format_data *fmt = dtp->u.p.fmt;
 587   bool saveit;
 588
 589   head = tail = NULL;
 590   saveit = *save_ok;
 591
 592   /* Get the next format item */
 593  format_item:
 594   t = format_lex (fmt);
 595  format_item_1:
 596   switch (t)
 597     {
 598     case FMT_POSINT:
 599       repeat = fmt->value;
 600
 601       t = format_lex (fmt);
 602       switch (t)
 603         {
 604         case FMT_LPAREN:
 605           get_fnode (fmt, &head, &tail, FMT_LPAREN);
 606           tail->repeat = repeat;
 607           tail->u.child = parse_format_list (dtp, &saveit);
 608           if (fmt->error != NULL)
 609             goto finished;
 610
 611           goto between_desc;
 612
 613         case FMT_SLASH:
 614           get_fnode (fmt, &head, &tail, FMT_SLASH);
 615           tail->repeat = repeat;
 616           goto optional_comma;
 617
 618         case FMT_X:
 619           get_fnode (fmt, &head, &tail, FMT_X);
 620           tail->repeat = 1;
 621           tail->u.k = fmt->value;
 622           goto between_desc;
 623
 624         case FMT_P:
 625           goto p_descriptor;
 626
 627         default:
 628           goto data_desc;
 629         }
 630
 631     case FMT_LPAREN:
 632       get_fnode (fmt, &head, &tail, FMT_LPAREN);
 633       tail->repeat = 1;
 634       tail->u.child = parse_format_list (dtp, &saveit);
 635       if (fmt->error != NULL)
 636         goto finished;
 637
 638       goto between_desc;
 639
 640     case FMT_SIGNED_INT:        /* Signed integer can only precede a P format.  */
 641     case FMT_ZERO:              /* Same for zero.  */
 642       t = format_lex (fmt);
 643       if (t != FMT_P)
 644         {
 645           fmt->error = "Expected P edit descriptor in format";
 646           goto finished;
 647         }
 648
 649     p_descriptor:
 650       get_fnode (fmt, &head, &tail, FMT_P);
 651       tail->u.k = fmt->value;
 652       tail->repeat = 1;
 653
 654       t = format_lex (fmt);
 655       if (t == FMT_F || t == FMT_EN || t == FMT_ES || t == FMT_D
 656           || t == FMT_G || t == FMT_E)
 657         {
 658           repeat = 1;
 659           goto data_desc;
 660         }
 661
 662       fmt->saved_token = t;
 663       goto optional_comma;
 664
 665     case FMT_P:         /* P and X require a prior number */
 666       fmt->error = "P descriptor requires leading scale factor";
 667       goto finished;
 668
 669     case FMT_X:
 670 /*
 671    EXTENSION!
 672
 673    If we would be pedantic in the library, we would have to reject
 674    an X descriptor without an integer prefix:
 675
 676       fmt->error = "X descriptor requires leading space count";
 677       goto finished;
 678
 679    However, this is an extension supported by many Fortran compilers,
 680    including Cray, HP, AIX, and IRIX.  Therefore, we allow it in the
 681    runtime library, and make the front end reject it if the compiler
 682    is in pedantic mode.  The interpretation of 'X' is '1X'.
 683 */
 684       get_fnode (fmt, &head, &tail, FMT_X);
 685       tail->repeat = 1;
 686       tail->u.k = 1;
 687       goto between_desc;
 688
 689     case FMT_STRING:
 690       /* TODO: Find out why is is necessary to turn off format caching.  */
 691       saveit = false;
 692       get_fnode (fmt, &head, &tail, FMT_STRING);
 693       tail->u.string.p = fmt->string;
 694       tail->u.string.length = fmt->value;
 695       tail->repeat = 1;
 696       goto optional_comma;
 697
 698     case FMT_DC:
 699     case FMT_DP:
 700       notify_std (&dtp->common, GFC_STD_F2003, "Fortran 2003: DC or DP "
 701                   "descriptor not allowed");
 702     /* Fall through.  */
 703     case FMT_S:
 704     case FMT_SS:
 705     case FMT_SP:
 706     case FMT_BN:
 707     case FMT_BZ:
 708       get_fnode (fmt, &head, &tail, t);
 709       tail->repeat = 1;
 710       goto between_desc;
 711
 712     case FMT_COLON:
 713       get_fnode (fmt, &head, &tail, FMT_COLON);
 714       tail->repeat = 1;
 715       goto optional_comma;
 716
 717     case FMT_SLASH:
 718       get_fnode (fmt, &head, &tail, FMT_SLASH);
 719       tail->repeat = 1;
 720       tail->u.r = 1;
 721       goto optional_comma;
 722
 723     case FMT_DOLLAR:
 724       get_fnode (fmt, &head, &tail, FMT_DOLLAR);
 725       tail->repeat = 1;
 726       notify_std (&dtp->common, GFC_STD_GNU, "Extension: $ descriptor");
 727       goto between_desc;
 728
 729     case FMT_T:
 730     case FMT_TL:
 731     case FMT_TR:
 732       t2 = format_lex (fmt);
 733       if (t2 != FMT_POSINT)
 734         {
 735           fmt->error = posint_required;
 736           goto finished;
 737         }
 738       get_fnode (fmt, &head, &tail, t);
 739       tail->u.n = fmt->value;
 740       tail->repeat = 1;
 741       goto between_desc;
 742
 743     case FMT_I:
 744     case FMT_B:
 745     case FMT_O:
 746     case FMT_Z:
 747     case FMT_E:
 748     case FMT_EN:
 749     case FMT_ES:
 750     case FMT_D:
 751     case FMT_L:
 752     case FMT_A:
 753     case FMT_F:
 754     case FMT_G:
 755       repeat = 1;
 756       goto data_desc;
 757
 758     case FMT_H:
 759       get_fnode (fmt, &head, &tail, FMT_STRING);
 760       if (fmt->format_string_len < 1)
 761         {
 762           fmt->error = bad_hollerith;
 763           goto finished;
 764         }
 765
 766       tail->u.string.p = fmt->format_string;
 767       tail->u.string.length = 1;
 768       tail->repeat = 1;
 769
 770       fmt->format_string++;
 771       fmt->format_string_len--;
 772
 773       goto between_desc;
 774
 775     case FMT_END:
 776       fmt->error = unexpected_end;
 777       goto finished;
 778
 779     case FMT_BADSTRING:
 780       goto finished;
 781
 782     case FMT_RPAREN:
 783       goto finished;
 784
 785     default:
 786       fmt->error = unexpected_element;
 787       goto finished;
 788     }
 789
 790   /* In this state, t must currently be a data descriptor.  Deal with
 791      things that can/must follow the descriptor */
 792  data_desc:
 793   switch (t)
 794     {
 795     case FMT_P:
 796       t = format_lex (fmt);
 797       if (t == FMT_POSINT)
 798         {
 799           fmt->error = "Repeat count cannot follow P descriptor";
 800           goto finished;
 801         }
 802
 803       fmt->saved_token = t;
 804       get_fnode (fmt, &head, &tail, FMT_P);
 805
 806       goto optional_comma;
 807
 808     case FMT_L:
 809       t = format_lex (fmt);
 810       if (t != FMT_POSINT)
 811         {
 812           if (notification_std(GFC_STD_GNU) == ERROR)
 813             {
 814               fmt->error = posint_required;
 815               goto finished;
 816             }
 817           else
 818             {
 819               fmt->saved_token = t;
 820               fmt->value = 1;   /* Default width */
 821               notify_std (&dtp->common, GFC_STD_GNU, posint_required);
 822             }
 823         }
 824
 825       get_fnode (fmt, &head, &tail, FMT_L);
 826       tail->u.n = fmt->value;
 827       tail->repeat = repeat;
 828       break;
 829
 830     case FMT_A:
 831       t = format_lex (fmt);
 832       if (t == FMT_ZERO)
 833         {
 834           fmt->error = zero_width;
 835           goto finished;
 836         }
 837
 838       if (t != FMT_POSINT)
 839         {
 840           fmt->saved_token = t;
 841           fmt->value = -1;              /* Width not present */
 842         }
 843
 844       get_fnode (fmt, &head, &tail, FMT_A);
 845       tail->repeat = repeat;
 846       tail->u.n = fmt->value;
 847       break;
 848
 849     case FMT_D:
 850     case FMT_E:
 851     case FMT_F:
 852     case FMT_G:
 853     case FMT_EN:
 854     case FMT_ES:
 855       get_fnode (fmt, &head, &tail, t);
 856       tail->repeat = repeat;
 857
 858       u = format_lex (fmt);
 859       if (t == FMT_G && u == FMT_ZERO)
 860         {
 861           if (notification_std (GFC_STD_F2008) == ERROR
 862               || dtp->u.p.mode == READING)
 863             {
 864               fmt->error = zero_width;
 865               goto finished;
 866             }
 867           tail->u.real.w = 0;
 868           u = format_lex (fmt);
 869           if (u != FMT_PERIOD)
 870             {
 871               fmt->saved_token = u;
 872               break;
 873             }
 874
 875           u = format_lex (fmt);
 876           if (u != FMT_POSINT)
 877             {
 878               fmt->error = posint_required;
 879               goto finished;
 880             }
 881           tail->u.real.d = fmt->value;
 882           break;
 883         }
 884       if (t == FMT_F || dtp->u.p.mode == WRITING)
 885         {
 886           if (u != FMT_POSINT && u != FMT_ZERO)
 887             {
 888               fmt->error = nonneg_required;
 889               goto finished;
 890             }
 891         }
 892       else
 893         {
 894           if (u != FMT_POSINT)
 895             {
 896               fmt->error = posint_required;
 897               goto finished;
 898             }
 899         }
 900
 901       tail->u.real.w = fmt->value;
 902       t2 = t;
 903       t = format_lex (fmt);
 904       if (t != FMT_PERIOD)
 905         {
 906           /* We treat a missing decimal descriptor as 0.  Note: This is only
 907              allowed if -std=legacy, otherwise an error occurs.  */
 908           if (compile_options.warn_std != 0)
 909             {
 910               fmt->error = period_required;
 911               goto finished;
 912             }
 913           fmt->saved_token = t;
 914           tail->u.real.d = 0;
 915           break;
 916         }
 917
 918       t = format_lex (fmt);
 919       if (t != FMT_ZERO && t != FMT_POSINT)
 920         {
 921           fmt->error = nonneg_required;
 922           goto finished;
 923         }
 924
 925       tail->u.real.d = fmt->value;
 926
 927       if (t == FMT_D || t == FMT_F)
 928         break;
 929
 930       tail->u.real.e = -1;
 931
 932       /* Look for optional exponent */
 933       t = format_lex (fmt);
 934       if (t != FMT_E)
 935         fmt->saved_token = t;
 936       else
 937         {
 938           t = format_lex (fmt);
 939           if (t != FMT_POSINT)
 940             {
 941               fmt->error = "Positive exponent width required in format";
 942               goto finished;
 943             }
 944
 945           tail->u.real.e = fmt->value;
 946         }
 947
 948       break;
 949
 950     case FMT_H:
 951       if (repeat > fmt->format_string_len)
 952         {
 953           fmt->error = bad_hollerith;
 954           goto finished;
 955         }
 956
 957       get_fnode (fmt, &head, &tail, FMT_STRING);
 958       tail->u.string.p = fmt->format_string;
 959       tail->u.string.length = repeat;
 960       tail->repeat = 1;
 961
 962       fmt->format_string += fmt->value;
 963       fmt->format_string_len -= repeat;
 964
 965       break;
 966
 967     case FMT_I:
 968     case FMT_B:
 969     case FMT_O:
 970     case FMT_Z:
 971       get_fnode (fmt, &head, &tail, t);
 972       tail->repeat = repeat;
 973
 974       t = format_lex (fmt);
 975
 976       if (dtp->u.p.mode == READING)
 977         {
 978           if (t != FMT_POSINT)
 979             {
 980               fmt->error = posint_required;
 981               goto finished;
 982             }
 983         }
 984       else
 985         {
 986           if (t != FMT_ZERO && t != FMT_POSINT)
 987             {
 988               fmt->error = nonneg_required;
 989               goto finished;
 990             }
 991         }
 992
 993       tail->u.integer.w = fmt->value;
 994       tail->u.integer.m = -1;
 995
 996       t = format_lex (fmt);
 997       if (t != FMT_PERIOD)
 998         {
 999           fmt->saved_token = t;
1000         }
1001       else
1002         {
1003           t = format_lex (fmt);
1004           if (t != FMT_ZERO && t != FMT_POSINT)
1005             {
1006               fmt->error = nonneg_required;
1007               goto finished;
1008             }
1009
1010           tail->u.integer.m = fmt->value;
1011         }
1012
1013       if (tail->u.integer.w != 0 && tail->u.integer.m > tail->u.integer.w)
1014         {
1015           fmt->error = "Minimum digits exceeds field width";
1016           goto finished;
1017         }
1018
1019       break;
1020
1021     default:
1022       fmt->error = unexpected_element;
1023       goto finished;
1024     }
1025
1026   /* Between a descriptor and what comes next */
1027  between_desc:
1028   t = format_lex (fmt);
1029   switch (t)
1030     {
1031     case FMT_COMMA:
1032       goto format_item;
1033
1034     case FMT_RPAREN:
1035       goto finished;
1036
1037     case FMT_SLASH:
1038     case FMT_COLON:
1039       get_fnode (fmt, &head, &tail, t);
1040       tail->repeat = 1;
1041       goto optional_comma;
1042
1043     case FMT_END:
1044       fmt->error = unexpected_end;
1045       goto finished;
1046
1047     default:
1048       /* Assume a missing comma, this is a GNU extension */
1049       goto format_item_1;
1050     }
1051
1052   /* Optional comma is a weird between state where we've just finished
1053      reading a colon, slash or P descriptor. */
1054  optional_comma:
1055   t = format_lex (fmt);
1056   switch (t)
1057     {
1058     case FMT_COMMA:
1059       break;
1060
1061     case FMT_RPAREN:
1062       goto finished;
1063
1064     default:                    /* Assume that we have another format item */
1065       fmt->saved_token = t;
1066       break;
1067     }
1068
1069   goto format_item;
1070
1071  finished:
1072
1073   *save_ok = saveit;
1074
1075   return head;
1076 }
1077
1078
1079 /* format_error()-- Generate an error message for a format statement.
1080  * If the node that gives the location of the error is NULL, the error
1081  * is assumed to happen at parse time, and the current location of the
1082  * parser is shown.
1083  *
1084  * We generate a message showing where the problem is.  We take extra
1085  * care to print only the relevant part of the format if it is longer
1086  * than a standard 80 column display. */
1087
1088 void
1089 format_error (st_parameter_dt *dtp, const fnode *f, const char *message)
1090 {
1091   int width, i, j, offset;
1092   char *p, buffer[300];
1093   format_data *fmt = dtp->u.p.fmt;
1094
1095   if (f != NULL)
1096     fmt->format_string = f->source;
1097
1098   if (message == unexpected_element)
1099     sprintf (buffer, message, fmt->error_element);
1100   else
1101     sprintf (buffer, "%s\n", message);
1102
1103   j = fmt->format_string - dtp->format;
1104
1105   offset = (j > 60) ? j - 40 : 0;
1106
1107   j -= offset;
1108   width = dtp->format_len - offset;
1109
1110   if (width > 80)
1111     width = 80;
1112
1113   /* Show the format */
1114
1115   p = strchr (buffer, '\0');
1116
1117   memcpy (p, dtp->format + offset, width);
1118
1119   p += width;
1120   *p++ = '\n';
1121
1122   /* Show where the problem is */
1123
1124   for (i = 1; i < j; i++)
1125     *p++ = ' ';
1126
1127   *p++ = '^';
1128   *p = '\0';
1129
1130   generate_error (&dtp->common, LIBERROR_FORMAT, buffer);
1131 }
1132
1133
1134 /* revert()-- Do reversion of the format.  Control reverts to the left
1135  * parenthesis that matches the rightmost right parenthesis.  From our
1136  * tree structure, we are looking for the rightmost parenthesis node
1137  * at the second level, the first level always being a single
1138  * parenthesis node.  If this node doesn't exit, we use the top
1139  * level. */
1140
1141 static void
1142 revert (st_parameter_dt *dtp)
1143 {
1144   fnode *f, *r;
1145   format_data *fmt = dtp->u.p.fmt;
1146
1147   dtp->u.p.reversion_flag = 1;
1148
1149   r = NULL;
1150
1151   for (f = fmt->array.array[0].u.child; f; f = f->next)
1152     if (f->format == FMT_LPAREN)
1153       r = f;
1154
1155   /* If r is NULL because no node was found, the whole tree will be used */
1156
1157   fmt->array.array[0].current = r;
1158   fmt->array.array[0].count = 0;
1159 }
1160
1161 /* parse_format()-- Parse a format string.  */
1162
1163 void
1164 parse_format (st_parameter_dt *dtp)
1165 {
1166   format_data *fmt;
1167   bool format_cache_ok;
1168
1169   format_cache_ok = !is_internal_unit (dtp);
1170
1171   /* Lookup format string to see if it has already been parsed.  */
1172   if (format_cache_ok)
1173     {
1174       dtp->u.p.fmt = find_parsed_format (dtp);
1175
1176       if (dtp->u.p.fmt != NULL)
1177         {
1178           dtp->u.p.fmt->reversion_ok = 0;
1179           dtp->u.p.fmt->saved_token = FMT_NONE;
1180           dtp->u.p.fmt->saved_format = NULL;
1181           reset_fnode_counters (dtp);
1182           return;
1183         }
1184     }
1185
1186   /* Not found so proceed as follows.  */
1187
1188   dtp->u.p.fmt = fmt = get_mem (sizeof (format_data));
1189   fmt->format_string = dtp->format;
1190   fmt->format_string_len = dtp->format_len;
1191
1192   fmt->string = NULL;
1193   fmt->saved_token = FMT_NONE;
1194   fmt->error = NULL;
1195   fmt->value = 0;
1196
1197   /* Initialize variables used during traversal of the tree.  */
1198
1199   fmt->reversion_ok = 0;
1200   fmt->saved_format = NULL;
1201
1202   /* Allocate the first format node as the root of the tree.  */
1203
1204   fmt->last = &fmt->array;
1205   fmt->last->next = NULL;
1206   fmt->avail = &fmt->array.array[0];
1207
1208   memset (fmt->avail, 0, sizeof (*fmt->avail));
1209   fmt->avail->format = FMT_LPAREN;
1210   fmt->avail->repeat = 1;
1211   fmt->avail++;
1212
1213   if (format_lex (fmt) == FMT_LPAREN)
1214     fmt->array.array[0].u.child = parse_format_list (dtp, &format_cache_ok);
1215   else
1216     fmt->error = "Missing initial left parenthesis in format";
1217
1218   if (fmt->error)
1219     {
1220       format_error (dtp, NULL, fmt->error);
1221       free_format_hash_table (dtp->u.p.current_unit);
1222       return;
1223     }
1224
1225   if (format_cache_ok)
1226     save_parsed_format (dtp);
1227   else
1228     dtp->u.p.format_not_saved = 1;
1229 }
1230
1231
1232 /* next_format0()-- Get the next format node without worrying about
1233  * reversion.  Returns NULL when we hit the end of the list.
1234  * Parenthesis nodes are incremented after the list has been
1235  * exhausted, other nodes are incremented before they are returned. */
1236
1237 static const fnode *
1238 next_format0 (fnode * f)
1239 {
1240   const fnode *r;
1241
1242   if (f == NULL)
1243     return NULL;
1244
1245   if (f->format != FMT_LPAREN)
1246     {
1247       f->count++;
1248       if (f->count <= f->repeat)
1249         return f;
1250
1251       f->count = 0;
1252       return NULL;
1253     }
1254
1255   /* Deal with a parenthesis node */
1256
1257   for (; f->count < f->repeat; f->count++)
1258     {
1259       if (f->current == NULL)
1260         f->current = f->u.child;
1261
1262       for (; f->current != NULL; f->current = f->current->next)
1263         {
1264           r = next_format0 (f->current);
1265           if (r != NULL)
1266             return r;
1267         }
1268     }
1269
1270   f->count = 0;
1271   return NULL;
1272 }
1273
1274
1275 /* next_format()-- Return the next format node.  If the format list
1276  * ends up being exhausted, we do reversion.  Reversion is only
1277  * allowed if we've seen a data descriptor since the
1278  * initialization or the last reversion.  We return NULL if there
1279  * are no more data descriptors to return (which is an error
1280  * condition). */
1281
1282 const fnode *
1283 next_format (st_parameter_dt *dtp)
1284 {
1285   format_token t;
1286   const fnode *f;
1287   format_data *fmt = dtp->u.p.fmt;
1288
1289   if (fmt->saved_format != NULL)
1290     {                           /* Deal with a pushed-back format node */
1291       f = fmt->saved_format;
1292       fmt->saved_format = NULL;
1293       goto done;
1294     }
1295
1296   f = next_format0 (&fmt->array.array[0]);
1297   if (f == NULL)
1298     {
1299       if (!fmt->reversion_ok)
1300         return NULL;
1301
1302       fmt->reversion_ok = 0;
1303       revert (dtp);
1304
1305       f = next_format0 (&fmt->array.array[0]);
1306       if (f == NULL)
1307         {
1308           format_error (dtp, NULL, reversion_error);
1309           return NULL;
1310         }
1311
1312       /* Push the first reverted token and return a colon node in case
1313        * there are no more data items. */
1314
1315       fmt->saved_format = f;
1316       return &colon_node;
1317     }
1318
1319   /* If this is a data edit descriptor, then reversion has become OK. */
1320  done:
1321   t = f->format;
1322
1323   if (!fmt->reversion_ok &&
1324       (t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F ||
1325        t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
1326        t == FMT_A || t == FMT_D))
1327     fmt->reversion_ok = 1;
1328   return f;
1329 }
1330
1331
1332 /* unget_format()-- Push the given format back so that it will be
1333  * returned on the next call to next_format() without affecting
1334  * counts.  This is necessary when we've encountered a data
1335  * descriptor, but don't know what the data item is yet.  The format
1336  * node is pushed back, and we return control to the main program,
1337  * which calls the library back with the data item (or not). */
1338
1339 void
1340 unget_format (st_parameter_dt *dtp, const fnode *f)
1341 {
1342   dtp->u.p.fmt->saved_format = f;
1343 }
1344