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
 945         {
 946           if (u != FMT_POSINT)
 947             {
 948               fmt->error = posint_required;
 949               goto finished;
 950             }
 951         }
 952
 953       tail->u.real.w = fmt->value;
 954       t2 = t;
 955       t = format_lex (fmt);
 956       if (t != FMT_PERIOD)
 957         {
 958           /* We treat a missing decimal descriptor as 0.  Note: This is only
 959              allowed if -std=legacy, otherwise an error occurs.  */
 960           if (compile_options.warn_std != 0)
 961             {
 962               fmt->error = period_required;
 963               goto finished;
 964             }
 965           fmt->saved_token = t;
 966           tail->u.real.d = 0;
 967           tail->u.real.e = -1;
 968           break;
 969         }
 970
 971       t = format_lex (fmt);
 972       if (t != FMT_ZERO && t != FMT_POSINT)
 973         {
 974           fmt->error = nonneg_required;
 975           goto finished;
 976         }
 977
 978       tail->u.real.d = fmt->value;
 979       tail->u.real.e = -1;
 980
 981       if (t2 == FMT_D || t2 == FMT_F)
 982         break;
 983
 984
 985       /* Look for optional exponent */
 986       t = format_lex (fmt);
 987       if (t != FMT_E)
 988         fmt->saved_token = t;
 989       else
 990         {
 991           t = format_lex (fmt);
 992           if (t != FMT_POSINT)
 993             {
 994               fmt->error = "Positive exponent width required in format";
 995               goto finished;
 996             }
 997
 998           tail->u.real.e = fmt->value;
 999         }
1000
1001       break;
1002
1003     case FMT_H:
1004       if (repeat > fmt->format_string_len)
1005         {
1006           fmt->error = bad_hollerith;
1007           goto finished;
1008         }
1009
1010       get_fnode (fmt, &head, &tail, FMT_STRING);
1011       tail->u.string.p = fmt->format_string;
1012       tail->u.string.length = repeat;
1013       tail->repeat = 1;
1014
1015       fmt->format_string += fmt->value;
1016       fmt->format_string_len -= repeat;
1017
1018       break;
1019
1020     case FMT_I:
1021     case FMT_B:
1022     case FMT_O:
1023     case FMT_Z:
1024       get_fnode (fmt, &head, &tail, t);
1025       tail->repeat = repeat;
1026
1027       t = format_lex (fmt);
1028
1029       if (dtp->u.p.mode == READING)
1030         {
1031           if (t != FMT_POSINT)
1032             {
1033               fmt->error = posint_required;
1034               goto finished;
1035             }
1036         }
1037       else
1038         {
1039           if (t != FMT_ZERO && t != FMT_POSINT)
1040             {
1041               fmt->error = nonneg_required;
1042               goto finished;
1043             }
1044         }
1045
1046       tail->u.integer.w = fmt->value;
1047       tail->u.integer.m = -1;
1048
1049       t = format_lex (fmt);
1050       if (t != FMT_PERIOD)
1051         {
1052           fmt->saved_token = t;
1053         }
1054       else
1055         {
1056           t = format_lex (fmt);
1057           if (t != FMT_ZERO && t != FMT_POSINT)
1058             {
1059               fmt->error = nonneg_required;
1060               goto finished;
1061             }
1062
1063           tail->u.integer.m = fmt->value;
1064         }
1065
1066       if (tail->u.integer.w != 0 && tail->u.integer.m > tail->u.integer.w)
1067         {
1068           fmt->error = "Minimum digits exceeds field width";
1069           goto finished;
1070         }
1071
1072       break;
1073
1074     default:
1075       fmt->error = unexpected_element;
1076       goto finished;
1077     }
1078
1079   /* Between a descriptor and what comes next */
1080  between_desc:
1081   t = format_lex (fmt);
1082   switch (t)
1083     {
1084     case FMT_COMMA:
1085       goto format_item;
1086
1087     case FMT_RPAREN:
1088       goto finished;
1089
1090     case FMT_SLASH:
1091     case FMT_COLON:
1092       get_fnode (fmt, &head, &tail, t);
1093       tail->repeat = 1;
1094       goto optional_comma;
1095
1096     case FMT_END:
1097       fmt->error = unexpected_end;
1098       goto finished;
1099
1100     default:
1101       /* Assume a missing comma, this is a GNU extension */
1102       goto format_item_1;
1103     }
1104
1105   /* Optional comma is a weird between state where we've just finished
1106      reading a colon, slash or P descriptor. */
1107  optional_comma:
1108   t = format_lex (fmt);
1109   switch (t)
1110     {
1111     case FMT_COMMA:
1112       break;
1113
1114     case FMT_RPAREN:
1115       goto finished;
1116
1117     default:                    /* Assume that we have another format item */
1118       fmt->saved_token = t;
1119       break;
1120     }
1121
1122   goto format_item;
1123
1124  finished:
1125
1126   *save_ok = saveit;
1127
1128   return head;
1129 }
1130
1131
1132 /* format_error()-- Generate an error message for a format statement.
1133  * If the node that gives the location of the error is NULL, the error
1134  * is assumed to happen at parse time, and the current location of the
1135  * parser is shown.
1136  *
1137  * We generate a message showing where the problem is.  We take extra
1138  * care to print only the relevant part of the format if it is longer
1139  * than a standard 80 column display. */
1140
1141 void
1142 format_error (st_parameter_dt *dtp, const fnode *f, const char *message)
1143 {
1144   int width, i, j, offset;
1145   char *p, buffer[300];
1146   format_data *fmt = dtp->u.p.fmt;
1147
1148   if (f != NULL)
1149     fmt->format_string = f->source;
1150
1151   if (message == unexpected_element)
1152     sprintf (buffer, message, fmt->error_element);
1153   else
1154     sprintf (buffer, "%s\n", message);
1155
1156   j = fmt->format_string - dtp->format;
1157
1158   offset = (j > 60) ? j - 40 : 0;
1159
1160   j -= offset;
1161   width = dtp->format_len - offset;
1162
1163   if (width > 80)
1164     width = 80;
1165
1166   /* Show the format */
1167
1168   p = strchr (buffer, '\0');
1169
1170   memcpy (p, dtp->format + offset, width);
1171
1172   p += width;
1173   *p++ = '\n';
1174
1175   /* Show where the problem is */
1176
1177   for (i = 1; i < j; i++)
1178     *p++ = ' ';
1179
1180   *p++ = '^';
1181   *p = '\0';
1182
1183   generate_error (&dtp->common, LIBERROR_FORMAT, buffer);
1184 }
1185
1186
1187 /* revert()-- Do reversion of the format.  Control reverts to the left
1188  * parenthesis that matches the rightmost right parenthesis.  From our
1189  * tree structure, we are looking for the rightmost parenthesis node
1190  * at the second level, the first level always being a single
1191  * parenthesis node.  If this node doesn't exit, we use the top
1192  * level. */
1193
1194 static void
1195 revert (st_parameter_dt *dtp)
1196 {
1197   fnode *f, *r;
1198   format_data *fmt = dtp->u.p.fmt;
1199
1200   dtp->u.p.reversion_flag = 1;
1201
1202   r = NULL;
1203
1204   for (f = fmt->array.array[0].u.child; f; f = f->next)
1205     if (f->format == FMT_LPAREN)
1206       r = f;
1207
1208   /* If r is NULL because no node was found, the whole tree will be used */
1209
1210   fmt->array.array[0].current = r;
1211   fmt->array.array[0].count = 0;
1212 }
1213
1214 /* parse_format()-- Parse a format string.  */
1215
1216 void
1217 parse_format (st_parameter_dt *dtp)
1218 {
1219   format_data *fmt;
1220   bool format_cache_ok;
1221
1222   format_cache_ok = !is_internal_unit (dtp);
1223
1224   /* Lookup format string to see if it has already been parsed.  */
1225   if (format_cache_ok)
1226     {
1227       dtp->u.p.fmt = find_parsed_format (dtp);
1228
1229       if (dtp->u.p.fmt != NULL)
1230         {
1231           dtp->u.p.fmt->reversion_ok = 0;
1232           dtp->u.p.fmt->saved_token = FMT_NONE;
1233           dtp->u.p.fmt->saved_format = NULL;
1234           reset_fnode_counters (dtp);
1235           return;
1236         }
1237     }
1238
1239   /* Not found so proceed as follows.  */
1240
1241   dtp->u.p.fmt = fmt = get_mem (sizeof (format_data));
1242   fmt->format_string = dtp->format;
1243   fmt->format_string_len = dtp->format_len;
1244
1245   fmt->string = NULL;
1246   fmt->saved_token = FMT_NONE;
1247   fmt->error = NULL;
1248   fmt->value = 0;
1249
1250   /* Initialize variables used during traversal of the tree.  */
1251
1252   fmt->reversion_ok = 0;
1253   fmt->saved_format = NULL;
1254
1255   /* Allocate the first format node as the root of the tree.  */
1256
1257   fmt->last = &fmt->array;
1258   fmt->last->next = NULL;
1259   fmt->avail = &fmt->array.array[0];
1260
1261   memset (fmt->avail, 0, sizeof (*fmt->avail));
1262   fmt->avail->format = FMT_LPAREN;
1263   fmt->avail->repeat = 1;
1264   fmt->avail++;
1265
1266   if (format_lex (fmt) == FMT_LPAREN)
1267     fmt->array.array[0].u.child = parse_format_list (dtp, &format_cache_ok);
1268   else
1269     fmt->error = "Missing initial left parenthesis in format";
1270
1271   if (fmt->error)
1272     {
1273       format_error (dtp, NULL, fmt->error);
1274       free_format_hash_table (dtp->u.p.current_unit);
1275       return;
1276     }
1277
1278   if (format_cache_ok)
1279     save_parsed_format (dtp);
1280   else
1281     dtp->u.p.format_not_saved = 1;
1282 }
1283
1284
1285 /* next_format0()-- Get the next format node without worrying about
1286  * reversion.  Returns NULL when we hit the end of the list.
1287  * Parenthesis nodes are incremented after the list has been
1288  * exhausted, other nodes are incremented before they are returned. */
1289
1290 static const fnode *
1291 next_format0 (fnode * f)
1292 {
1293   const fnode *r;
1294
1295   if (f == NULL)
1296     return NULL;
1297
1298   if (f->format != FMT_LPAREN)
1299     {
1300       f->count++;
1301       if (f->count <= f->repeat)
1302         return f;
1303
1304       f->count = 0;
1305       return NULL;
1306     }
1307
1308   /* Deal with a parenthesis node with unlimited format.  */
1309
1310   if (f->repeat == -2)  /* -2 signifies unlimited.  */
1311   for (;;)
1312     {
1313       if (f->current == NULL)
1314         f->current = f->u.child;
1315
1316       for (; f->current != NULL; f->current = f->current->next)
1317         {
1318           r = next_format0 (f->current);
1319           if (r != NULL)
1320             return r;
1321         }
1322     }
1323
1324   /* Deal with a parenthesis node with specific repeat count.  */
1325   for (; f->count < f->repeat; f->count++)
1326     {
1327       if (f->current == NULL)
1328         f->current = f->u.child;
1329
1330       for (; f->current != NULL; f->current = f->current->next)
1331         {
1332           r = next_format0 (f->current);
1333           if (r != NULL)
1334             return r;
1335         }
1336     }
1337
1338   f->count = 0;
1339   return NULL;
1340 }
1341
1342
1343 /* next_format()-- Return the next format node.  If the format list
1344  * ends up being exhausted, we do reversion.  Reversion is only
1345  * allowed if we've seen a data descriptor since the
1346  * initialization or the last reversion.  We return NULL if there
1347  * are no more data descriptors to return (which is an error
1348  * condition). */
1349
1350 const fnode *
1351 next_format (st_parameter_dt *dtp)
1352 {
1353   format_token t;
1354   const fnode *f;
1355   format_data *fmt = dtp->u.p.fmt;
1356
1357   if (fmt->saved_format != NULL)
1358     {                           /* Deal with a pushed-back format node */
1359       f = fmt->saved_format;
1360       fmt->saved_format = NULL;
1361       goto done;
1362     }
1363
1364   f = next_format0 (&fmt->array.array[0]);
1365   if (f == NULL)
1366     {
1367       if (!fmt->reversion_ok)
1368         return NULL;
1369
1370       fmt->reversion_ok = 0;
1371       revert (dtp);
1372
1373       f = next_format0 (&fmt->array.array[0]);
1374       if (f == NULL)
1375         {
1376           format_error (dtp, NULL, reversion_error);
1377           return NULL;
1378         }
1379
1380       /* Push the first reverted token and return a colon node in case
1381        * there are no more data items. */
1382
1383       fmt->saved_format = f;
1384       return &colon_node;
1385     }
1386
1387   /* If this is a data edit descriptor, then reversion has become OK. */
1388  done:
1389   t = f->format;
1390
1391   if (!fmt->reversion_ok &&
1392       (t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F ||
1393        t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
1394        t == FMT_A || t == FMT_D))
1395     fmt->reversion_ok = 1;
1396   return f;
1397 }
1398
1399
1400 /* unget_format()-- Push the given format back so that it will be
1401  * returned on the next call to next_format() without affecting
1402  * counts.  This is necessary when we've encountered a data
1403  * descriptor, but don't know what the data item is yet.  The format
1404  * node is pushed back, and we return control to the main program,
1405  * which calls the library back with the data item (or not). */
1406
1407 void
1408 unget_format (st_parameter_dt *dtp, const fnode *f)
1409 {
1410   dtp->u.p.fmt->saved_format = f;
1411 }
1412