libgfortran/io/format.c

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