libgfortran/io/format.c

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