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