libgfortran/io/format.c

   1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
   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 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 "format.h"
  33 #include <ctype.h>
  34 #include <string.h>
  35 #include <stdbool.h>
  36 #include <stdlib.h>
  37
  38
  39 static const fnode colon_node = { FMT_COLON, 0, NULL, NULL, {{ 0, 0, 0 }}, 0,
  40                                   NULL };
  41
  42 /* Error messages. */
  43
  44 static const char posint_required[] = "Positive width required in format",
  45   period_required[] = "Period required in format",
  46   nonneg_required[] = "Nonnegative width required in format",
  47   unexpected_element[] = "Unexpected element '%c' in format\n",
  48   unexpected_end[] = "Unexpected end of format string",
  49   bad_string[] = "Unterminated character constant in format",
  50   bad_hollerith[] = "Hollerith constant extends past the end of the format",
  51   reversion_error[] = "Exhausted data descriptors in format",
  52   zero_width[] = "Zero width in format descriptor";
  53
  54 /* The following routines support caching format data from parsed format strings
  55    into a hash table.  This avoids repeatedly parsing duplicate format strings
  56    or format strings in I/O statements that are repeated in loops.  */
  57
  58
  59 /* Traverse the table and free all data.  */
  60
  61 void
  62 free_format_hash_table (gfc_unit *u)
  63 {
  64   size_t i;
  65
  66   /* free_format_data handles any NULL pointers.  */
  67   for (i = 0; i < FORMAT_HASH_SIZE; i++)
  68     {
  69       if (u->format_hash_table[i].hashed_fmt != NULL)
  70         {
  71           free_format_data (u->format_hash_table[i].hashed_fmt);
  72           free (u->format_hash_table[i].key);
  73         }
  74       u->format_hash_table[i].key = NULL;
  75       u->format_hash_table[i].key_len = 0;
  76       u->format_hash_table[i].hashed_fmt = NULL;
  77     }
  78 }
  79
  80 /* Traverse the format_data structure and reset the fnode counters.  */
  81
  82 static void
  83 reset_node (fnode *fn)
  84 {
  85   fnode *f;
  86
  87   fn->count = 0;
  88   fn->current = NULL;
  89
  90   if (fn->format != FMT_LPAREN)
  91     return;
  92
  93   for (f = fn->u.child; f; f = f->next)
  94     {
  95       if (f->format == FMT_RPAREN)
  96         break;
  97       reset_node (f);
  98     }
  99 }
 100
 101 static void
 102 reset_fnode_counters (st_parameter_dt *dtp)
 103 {
 104   fnode *f;
 105   format_data *fmt;
 106
 107   fmt = dtp->u.p.fmt;
 108
 109   /* Clear this pointer at the head so things start at the right place.  */
 110   fmt->array.array[0].current = NULL;
 111
 112   for (f = fmt->array.array[0].u.child; f; f = f->next)
 113     reset_node (f);
 114 }
 115
 116
 117 /* A simple hashing function to generate an index into the hash table.  */
 118
 119 static inline
 120 uint32_t format_hash (st_parameter_dt *dtp)
 121 {
 122   char *key;
 123   gfc_charlen_type key_len;
 124   uint32_t hash = 0;
 125   gfc_charlen_type i;
 126
 127   /* Hash the format string. Super simple, but what the heck!  */
 128   key = dtp->format;
 129   key_len = dtp->format_len;
 130   for (i = 0; i < key_len; i++)
 131     hash ^= key[i];
 132   hash &= (FORMAT_HASH_SIZE - 1);
 133   return hash;
 134 }
 135
 136
 137 static void
 138 save_parsed_format (st_parameter_dt *dtp)
 139 {
 140   uint32_t hash;
 141   gfc_unit *u;
 142
 143   hash = format_hash (dtp);
 144   u = dtp->u.p.current_unit;
 145
 146   /* Index into the hash table.  We are simply replacing whatever is there
 147      relying on probability.  */
 148   if (u->format_hash_table[hash].hashed_fmt != NULL)
 149     free_format_data (u->format_hash_table[hash].hashed_fmt);
 150   u->format_hash_table[hash].hashed_fmt = NULL;
 151
 152   if (u->format_hash_table[hash].key != NULL)
 153     free (u->format_hash_table[hash].key);
 154   u->format_hash_table[hash].key = get_mem (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 = get_mem (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   char *p, buffer[300];
1131   format_data *fmt = dtp->u.p.fmt;
1132
1133   if (f != NULL)
1134     fmt->format_string = f->source;
1135
1136   if (message == unexpected_element)
1137     sprintf (buffer, message, fmt->error_element);
1138   else
1139     sprintf (buffer, "%s\n", message);
1140
1141   j = fmt->format_string - dtp->format;
1142
1143   offset = (j > 60) ? j - 40 : 0;
1144
1145   j -= offset;
1146   width = dtp->format_len - offset;
1147
1148   if (width > 80)
1149     width = 80;
1150
1151   /* Show the format */
1152
1153   p = strchr (buffer, '\0');
1154
1155   memcpy (p, dtp->format + offset, width);
1156
1157   p += width;
1158   *p++ = '\n';
1159
1160   /* Show where the problem is */
1161
1162   for (i = 1; i < j; i++)
1163     *p++ = ' ';
1164
1165   *p++ = '^';
1166   *p = '\0';
1167
1168   generate_error (&dtp->common, LIBERROR_FORMAT, buffer);
1169 }
1170
1171
1172 /* revert()-- Do reversion of the format.  Control reverts to the left
1173  * parenthesis that matches the rightmost right parenthesis.  From our
1174  * tree structure, we are looking for the rightmost parenthesis node
1175  * at the second level, the first level always being a single
1176  * parenthesis node.  If this node doesn't exit, we use the top
1177  * level. */
1178
1179 static void
1180 revert (st_parameter_dt *dtp)
1181 {
1182   fnode *f, *r;
1183   format_data *fmt = dtp->u.p.fmt;
1184
1185   dtp->u.p.reversion_flag = 1;
1186
1187   r = NULL;
1188
1189   for (f = fmt->array.array[0].u.child; f; f = f->next)
1190     if (f->format == FMT_LPAREN)
1191       r = f;
1192
1193   /* If r is NULL because no node was found, the whole tree will be used */
1194
1195   fmt->array.array[0].current = r;
1196   fmt->array.array[0].count = 0;
1197 }
1198
1199 /* parse_format()-- Parse a format string.  */
1200
1201 void
1202 parse_format (st_parameter_dt *dtp)
1203 {
1204   format_data *fmt;
1205   bool format_cache_ok, seen_data_desc = false;
1206
1207   /* Don't cache for internal units and set an arbitrary limit on the size of
1208      format strings we will cache.  (Avoids memory issues.)  */
1209   format_cache_ok = !is_internal_unit (dtp);
1210
1211   /* Lookup format string to see if it has already been parsed.  */
1212   if (format_cache_ok)
1213     {
1214       dtp->u.p.fmt = find_parsed_format (dtp);
1215
1216       if (dtp->u.p.fmt != NULL)
1217         {
1218           dtp->u.p.fmt->reversion_ok = 0;
1219           dtp->u.p.fmt->saved_token = FMT_NONE;
1220           dtp->u.p.fmt->saved_format = NULL;
1221           reset_fnode_counters (dtp);
1222           return;
1223         }
1224     }
1225
1226   /* Not found so proceed as follows.  */
1227
1228   dtp->u.p.fmt = fmt = get_mem (sizeof (format_data));
1229   fmt->format_string = dtp->format;
1230   fmt->format_string_len = dtp->format_len;
1231
1232   fmt->string = NULL;
1233   fmt->saved_token = FMT_NONE;
1234   fmt->error = NULL;
1235   fmt->value = 0;
1236
1237   /* Initialize variables used during traversal of the tree.  */
1238
1239   fmt->reversion_ok = 0;
1240   fmt->saved_format = NULL;
1241
1242   /* Allocate the first format node as the root of the tree.  */
1243
1244   fmt->last = &fmt->array;
1245   fmt->last->next = NULL;
1246   fmt->avail = &fmt->array.array[0];
1247
1248   memset (fmt->avail, 0, sizeof (*fmt->avail));
1249   fmt->avail->format = FMT_LPAREN;
1250   fmt->avail->repeat = 1;
1251   fmt->avail++;
1252
1253   if (format_lex (fmt) == FMT_LPAREN)
1254     fmt->array.array[0].u.child = parse_format_list (dtp, &format_cache_ok,
1255                                                      &seen_data_desc);
1256   else
1257     fmt->error = "Missing initial left parenthesis in format";
1258
1259   if (fmt->error)
1260     {
1261       format_error (dtp, NULL, fmt->error);
1262       free_format_hash_table (dtp->u.p.current_unit);
1263       return;
1264     }
1265
1266   if (format_cache_ok)
1267     save_parsed_format (dtp);
1268   else
1269     dtp->u.p.format_not_saved = 1;
1270 }
1271
1272
1273 /* next_format0()-- Get the next format node without worrying about
1274  * reversion.  Returns NULL when we hit the end of the list.
1275  * Parenthesis nodes are incremented after the list has been
1276  * exhausted, other nodes are incremented before they are returned. */
1277
1278 static const fnode *
1279 next_format0 (fnode * f)
1280 {
1281   const fnode *r;
1282
1283   if (f == NULL)
1284     return NULL;
1285
1286   if (f->format != FMT_LPAREN)
1287     {
1288       f->count++;
1289       if (f->count <= f->repeat)
1290         return f;
1291
1292       f->count = 0;
1293       return NULL;
1294     }
1295
1296   /* Deal with a parenthesis node with unlimited format.  */
1297
1298   if (f->repeat == -2)  /* -2 signifies unlimited.  */
1299   for (;;)
1300     {
1301       if (f->current == NULL)
1302         f->current = f->u.child;
1303
1304       for (; f->current != NULL; f->current = f->current->next)
1305         {
1306           r = next_format0 (f->current);
1307           if (r != NULL)
1308             return r;
1309         }
1310     }
1311
1312   /* Deal with a parenthesis node with specific repeat count.  */
1313   for (; f->count < f->repeat; f->count++)
1314     {
1315       if (f->current == NULL)
1316         f->current = f->u.child;
1317
1318       for (; f->current != NULL; f->current = f->current->next)
1319         {
1320           r = next_format0 (f->current);
1321           if (r != NULL)
1322             return r;
1323         }
1324     }
1325
1326   f->count = 0;
1327   return NULL;
1328 }
1329
1330
1331 /* next_format()-- Return the next format node.  If the format list
1332  * ends up being exhausted, we do reversion.  Reversion is only
1333  * allowed if we've seen a data descriptor since the
1334  * initialization or the last reversion.  We return NULL if there
1335  * are no more data descriptors to return (which is an error
1336  * condition). */
1337
1338 const fnode *
1339 next_format (st_parameter_dt *dtp)
1340 {
1341   format_token t;
1342   const fnode *f;
1343   format_data *fmt = dtp->u.p.fmt;
1344
1345   if (fmt->saved_format != NULL)
1346     {                           /* Deal with a pushed-back format node */
1347       f = fmt->saved_format;
1348       fmt->saved_format = NULL;
1349       goto done;
1350     }
1351
1352   f = next_format0 (&fmt->array.array[0]);
1353   if (f == NULL)
1354     {
1355       if (!fmt->reversion_ok)
1356         return NULL;
1357
1358       fmt->reversion_ok = 0;
1359       revert (dtp);
1360
1361       f = next_format0 (&fmt->array.array[0]);
1362       if (f == NULL)
1363         {
1364           format_error (dtp, NULL, reversion_error);
1365           return NULL;
1366         }
1367
1368       /* Push the first reverted token and return a colon node in case
1369        * there are no more data items. */
1370
1371       fmt->saved_format = f;
1372       return &colon_node;
1373     }
1374
1375   /* If this is a data edit descriptor, then reversion has become OK. */
1376  done:
1377   t = f->format;
1378
1379   if (!fmt->reversion_ok &&
1380       (t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F ||
1381        t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
1382        t == FMT_A || t == FMT_D))
1383     fmt->reversion_ok = 1;
1384   return f;
1385 }
1386
1387
1388 /* unget_format()-- Push the given format back so that it will be
1389  * returned on the next call to next_format() without affecting
1390  * counts.  This is necessary when we've encountered a data
1391  * descriptor, but don't know what the data item is yet.  The format
1392  * node is pushed back, and we return control to the main program,
1393  * which calls the library back with the data item (or not). */
1394
1395 void
1396 unget_format (st_parameter_dt *dtp, const fnode *f)
1397 {
1398   dtp->u.p.fmt->saved_format = f;
1399 }
1400