libgfortran/io/format.c

   1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006
   2    Free Software Foundation, Inc.
   3    Contributed by Andy Vaught
   4
   5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
   6
   7 Libgfortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2, or (at your option)
  10 any later version.
  11
  12 In addition to the permissions in the GNU General Public License, the
  13 Free Software Foundation gives you unlimited permission to link the
  14 compiled version of this file into combinations with other programs,
  15 and to distribute those combinations without any restriction coming
  16 from the use of this file.  (The General Public License restrictions
  17 do apply in other respects; for example, they cover modification of
  18 the file, and distribution when not linked into a combine
  19 executable.)
  20
  21 Libgfortran is distributed in the hope that it will be useful,
  22 but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 GNU General Public License for more details.
  25
  26 You should have received a copy of the GNU General Public License
  27 along with Libgfortran; see the file COPYING.  If not, write to
  28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
  29 Boston, MA 02110-1301, USA.  */
  30
  31
  32 /* format.c-- parse a FORMAT string into a binary format suitable for
  33  * interpretation during I/O statements */
  34
  35 #include "config.h"
  36 #include <ctype.h>
  37 #include <string.h>
  38 #include "libgfortran.h"
  39 #include "io.h"
  40
  41 #define FARRAY_SIZE 64
  42
  43 typedef struct fnode_array
  44 {
  45   struct fnode_array *next;
  46   fnode array[FARRAY_SIZE];
  47 }
  48 fnode_array;
  49
  50 typedef struct format_data
  51 {
  52   char *format_string, *string;
  53   const char *error;
  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 in format",
  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
  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       c = toupper (*fmt->format_string++);
  94     }
  95   while (c == ' ' && !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
 401       break;
 402
 403     case 'G':
 404       token = FMT_G;
 405       break;
 406
 407     case 'H':
 408       token = FMT_H;
 409       break;
 410
 411     case 'L':
 412       token = FMT_L;
 413       break;
 414
 415     case 'A':
 416       token = FMT_A;
 417       break;
 418
 419     case 'D':
 420       token = FMT_D;
 421       break;
 422
 423     case -1:
 424       token = FMT_END;
 425       break;
 426
 427     default:
 428       token = FMT_UNKNOWN;
 429       break;
 430     }
 431
 432   return token;
 433 }
 434
 435
 436 /* parse_format_list()-- Parse a format list.  Assumes that a left
 437  * paren has already been seen.  Returns a list representing the
 438  * parenthesis node which contains the rest of the list. */
 439
 440 static fnode *
 441 parse_format_list (st_parameter_dt *dtp)
 442 {
 443   fnode *head, *tail;
 444   format_token t, u, t2;
 445   int repeat;
 446   format_data *fmt = dtp->u.p.fmt;
 447
 448   head = tail = NULL;
 449
 450   /* Get the next format item */
 451  format_item:
 452   t = format_lex (fmt);
 453  format_item_1:
 454   switch (t)
 455     {
 456     case FMT_POSINT:
 457       repeat = fmt->value;
 458
 459       t = format_lex (fmt);
 460       switch (t)
 461         {
 462         case FMT_LPAREN:
 463           get_fnode (fmt, &head, &tail, FMT_LPAREN);
 464           tail->repeat = repeat;
 465           tail->u.child = parse_format_list (dtp);
 466           if (fmt->error != NULL)
 467             goto finished;
 468
 469           goto between_desc;
 470
 471         case FMT_SLASH:
 472           get_fnode (fmt, &head, &tail, FMT_SLASH);
 473           tail->repeat = repeat;
 474           goto optional_comma;
 475
 476         case FMT_X:
 477           get_fnode (fmt, &head, &tail, FMT_X);
 478           tail->repeat = 1;
 479           tail->u.k = fmt->value;
 480           goto between_desc;
 481
 482         case FMT_P:
 483           goto p_descriptor;
 484
 485         default:
 486           goto data_desc;
 487         }
 488
 489     case FMT_LPAREN:
 490       get_fnode (fmt, &head, &tail, FMT_LPAREN);
 491       tail->repeat = 1;
 492       tail->u.child = parse_format_list (dtp);
 493       if (fmt->error != NULL)
 494         goto finished;
 495
 496       goto between_desc;
 497
 498     case FMT_SIGNED_INT:        /* Signed integer can only precede a P format.  */
 499     case FMT_ZERO:              /* Same for zero.  */
 500       t = format_lex (fmt);
 501       if (t != FMT_P)
 502         {
 503           fmt->error = "Expected P edit descriptor in format";
 504           goto finished;
 505         }
 506
 507     p_descriptor:
 508       get_fnode (fmt, &head, &tail, FMT_P);
 509       tail->u.k = fmt->value;
 510       tail->repeat = 1;
 511
 512       t = format_lex (fmt);
 513       if (t == FMT_F || t == FMT_EN || t == FMT_ES || t == FMT_D
 514           || t == FMT_G || t == FMT_E)
 515         {
 516           repeat = 1;
 517           goto data_desc;
 518         }
 519
 520       fmt->saved_token = t;
 521       goto optional_comma;
 522
 523     case FMT_P:         /* P and X require a prior number */
 524       fmt->error = "P descriptor requires leading scale factor";
 525       goto finished;
 526
 527     case FMT_X:
 528 /*
 529    EXTENSION!
 530
 531    If we would be pedantic in the library, we would have to reject
 532    an X descriptor without an integer prefix:
 533
 534       fmt->error = "X descriptor requires leading space count";
 535       goto finished;
 536
 537    However, this is an extension supported by many Fortran compilers,
 538    including Cray, HP, AIX, and IRIX.  Therefore, we allow it in the
 539    runtime library, and make the front end reject it if the compiler
 540    is in pedantic mode.  The interpretation of 'X' is '1X'.
 541 */
 542       get_fnode (fmt, &head, &tail, FMT_X);
 543       tail->repeat = 1;
 544       tail->u.k = 1;
 545       goto between_desc;
 546
 547     case FMT_STRING:
 548       get_fnode (fmt, &head, &tail, FMT_STRING);
 549
 550       tail->u.string.p = fmt->string;
 551       tail->u.string.length = fmt->value;
 552       tail->repeat = 1;
 553       goto optional_comma;
 554
 555     case FMT_S:
 556     case FMT_SS:
 557     case FMT_SP:
 558     case FMT_BN:
 559     case FMT_BZ:
 560       get_fnode (fmt, &head, &tail, t);
 561       tail->repeat = 1;
 562       goto between_desc;
 563
 564     case FMT_COLON:
 565       get_fnode (fmt, &head, &tail, FMT_COLON);
 566       tail->repeat = 1;
 567       goto optional_comma;
 568
 569     case FMT_SLASH:
 570       get_fnode (fmt, &head, &tail, FMT_SLASH);
 571       tail->repeat = 1;
 572       tail->u.r = 1;
 573       goto optional_comma;
 574
 575     case FMT_DOLLAR:
 576       get_fnode (fmt, &head, &tail, FMT_DOLLAR);
 577       tail->repeat = 1;
 578       notify_std (&dtp->common, GFC_STD_GNU, "Extension: $ descriptor");
 579       goto between_desc;
 580
 581     case FMT_T:
 582     case FMT_TL:
 583     case FMT_TR:
 584       t2 = format_lex (fmt);
 585       if (t2 != FMT_POSINT)
 586         {
 587           fmt->error = posint_required;
 588           goto finished;
 589         }
 590       get_fnode (fmt, &head, &tail, t);
 591       tail->u.n = fmt->value;
 592       tail->repeat = 1;
 593       goto between_desc;
 594
 595     case FMT_I:
 596     case FMT_B:
 597     case FMT_O:
 598     case FMT_Z:
 599     case FMT_E:
 600     case FMT_EN:
 601     case FMT_ES:
 602     case FMT_D:
 603     case FMT_L:
 604     case FMT_A:
 605     case FMT_F:
 606     case FMT_G:
 607       repeat = 1;
 608       goto data_desc;
 609
 610     case FMT_H:
 611       get_fnode (fmt, &head, &tail, FMT_STRING);
 612
 613       if (fmt->format_string_len < 1)
 614         {
 615           fmt->error = bad_hollerith;
 616           goto finished;
 617         }
 618
 619       tail->u.string.p = fmt->format_string;
 620       tail->u.string.length = 1;
 621       tail->repeat = 1;
 622
 623       fmt->format_string++;
 624       fmt->format_string_len--;
 625
 626       goto between_desc;
 627
 628     case FMT_END:
 629       fmt->error = unexpected_end;
 630       goto finished;
 631
 632     case FMT_BADSTRING:
 633       goto finished;
 634
 635     case FMT_RPAREN:
 636       goto finished;
 637
 638     default:
 639       fmt->error = unexpected_element;
 640       goto finished;
 641     }
 642
 643   /* In this state, t must currently be a data descriptor.  Deal with
 644      things that can/must follow the descriptor */
 645  data_desc:
 646   switch (t)
 647     {
 648     case FMT_P:
 649       t = format_lex (fmt);
 650       if (t == FMT_POSINT)
 651         {
 652           fmt->error = "Repeat count cannot follow P descriptor";
 653           goto finished;
 654         }
 655
 656       fmt->saved_token = t;
 657       get_fnode (fmt, &head, &tail, FMT_P);
 658
 659       goto optional_comma;
 660
 661     case FMT_L:
 662       t = format_lex (fmt);
 663       if (t != FMT_POSINT)
 664         {
 665           if (notification_std(GFC_STD_GNU) == ERROR)
 666             {
 667               fmt->error = posint_required;
 668               goto finished;
 669             }
 670           else
 671             {
 672               fmt->saved_token = t;
 673               fmt->value = 1;   /* Default width */
 674               notify_std (&dtp->common, GFC_STD_GNU, posint_required);
 675             }
 676         }
 677
 678       get_fnode (fmt, &head, &tail, FMT_L);
 679       tail->u.n = fmt->value;
 680       tail->repeat = repeat;
 681       break;
 682
 683     case FMT_A:
 684       t = format_lex (fmt);
 685       if (t != FMT_POSINT)
 686         {
 687           fmt->saved_token = t;
 688           fmt->value = -1;              /* Width not present */
 689         }
 690
 691       get_fnode (fmt, &head, &tail, FMT_A);
 692       tail->repeat = repeat;
 693       tail->u.n = fmt->value;
 694       break;
 695
 696     case FMT_D:
 697     case FMT_E:
 698     case FMT_F:
 699     case FMT_G:
 700     case FMT_EN:
 701     case FMT_ES:
 702       get_fnode (fmt, &head, &tail, t);
 703       tail->repeat = repeat;
 704
 705       u = format_lex (fmt);
 706       if (t == FMT_F || dtp->u.p.mode == WRITING)
 707         {
 708           if (u != FMT_POSINT && u != FMT_ZERO)
 709             {
 710               fmt->error = nonneg_required;
 711               goto finished;
 712             }
 713         }
 714       else
 715         {
 716           if (u != FMT_POSINT)
 717             {
 718               fmt->error = posint_required;
 719               goto finished;
 720             }
 721         }
 722
 723       tail->u.real.w = fmt->value;
 724       t2 = t;
 725       t = format_lex (fmt);
 726       if (t != FMT_PERIOD)
 727         {
 728           /* We treat a missing decimal descriptor as 0.  Note: This is only
 729              allowed if -std=legacy, otherwise an error occurs.  */
 730           if (compile_options.warn_std != 0)
 731             {
 732               fmt->error = period_required;
 733               goto finished;
 734             }
 735           fmt->saved_token = t;
 736           tail->u.real.d = 0;
 737           break;
 738         }
 739
 740       t = format_lex (fmt);
 741       if (t != FMT_ZERO && t != FMT_POSINT)
 742         {
 743           fmt->error = nonneg_required;
 744           goto finished;
 745         }
 746
 747       tail->u.real.d = fmt->value;
 748
 749       if (t == FMT_D || t == FMT_F)
 750         break;
 751
 752       tail->u.real.e = -1;
 753
 754       /* Look for optional exponent */
 755       t = format_lex (fmt);
 756       if (t != FMT_E)
 757         fmt->saved_token = t;
 758       else
 759         {
 760           t = format_lex (fmt);
 761           if (t != FMT_POSINT)
 762             {
 763               fmt->error = "Positive exponent width required in format";
 764               goto finished;
 765             }
 766
 767           tail->u.real.e = fmt->value;
 768         }
 769
 770       break;
 771
 772     case FMT_H:
 773       if (repeat > fmt->format_string_len)
 774         {
 775           fmt->error = bad_hollerith;
 776           goto finished;
 777         }
 778
 779       get_fnode (fmt, &head, &tail, FMT_STRING);
 780
 781       tail->u.string.p = fmt->format_string;
 782       tail->u.string.length = repeat;
 783       tail->repeat = 1;
 784
 785       fmt->format_string += fmt->value;
 786       fmt->format_string_len -= repeat;
 787
 788       break;
 789
 790     case FMT_I:
 791     case FMT_B:
 792     case FMT_O:
 793     case FMT_Z:
 794       get_fnode (fmt, &head, &tail, t);
 795       tail->repeat = repeat;
 796
 797       t = format_lex (fmt);
 798
 799       if (dtp->u.p.mode == READING)
 800         {
 801           if (t != FMT_POSINT)
 802             {
 803               fmt->error = posint_required;
 804               goto finished;
 805             }
 806         }
 807       else
 808         {
 809           if (t != FMT_ZERO && t != FMT_POSINT)
 810             {
 811               fmt->error = nonneg_required;
 812               goto finished;
 813             }
 814         }
 815
 816       tail->u.integer.w = fmt->value;
 817       tail->u.integer.m = -1;
 818
 819       t = format_lex (fmt);
 820       if (t != FMT_PERIOD)
 821         {
 822           fmt->saved_token = t;
 823         }
 824       else
 825         {
 826           t = format_lex (fmt);
 827           if (t != FMT_ZERO && t != FMT_POSINT)
 828             {
 829               fmt->error = nonneg_required;
 830               goto finished;
 831             }
 832
 833           tail->u.integer.m = fmt->value;
 834         }
 835
 836       if (tail->u.integer.w != 0 && tail->u.integer.m > tail->u.integer.w)
 837         {
 838           fmt->error = "Minimum digits exceeds field width";
 839           goto finished;
 840         }
 841
 842       break;
 843
 844     default:
 845       fmt->error = unexpected_element;
 846       goto finished;
 847     }
 848
 849   /* Between a descriptor and what comes next */
 850  between_desc:
 851   t = format_lex (fmt);
 852   switch (t)
 853     {
 854     case FMT_COMMA:
 855       goto format_item;
 856
 857     case FMT_RPAREN:
 858       goto finished;
 859
 860     case FMT_SLASH:
 861     case FMT_COLON:
 862       get_fnode (fmt, &head, &tail, t);
 863       tail->repeat = 1;
 864       goto optional_comma;
 865
 866     case FMT_END:
 867       fmt->error = unexpected_end;
 868       goto finished;
 869
 870     default:
 871       /* Assume a missing comma, this is a GNU extension */
 872       goto format_item_1;
 873     }
 874
 875   /* Optional comma is a weird between state where we've just finished
 876      reading a colon, slash or P descriptor. */
 877  optional_comma:
 878   t = format_lex (fmt);
 879   switch (t)
 880     {
 881     case FMT_COMMA:
 882       break;
 883
 884     case FMT_RPAREN:
 885       goto finished;
 886
 887     default:                    /* Assume that we have another format item */
 888       fmt->saved_token = t;
 889       break;
 890     }
 891
 892   goto format_item;
 893
 894  finished:
 895   return head;
 896 }
 897
 898
 899 /* format_error()-- Generate an error message for a format statement.
 900  * If the node that gives the location of the error is NULL, the error
 901  * is assumed to happen at parse time, and the current location of the
 902  * parser is shown.
 903  *
 904  * We generate a message showing where the problem is.  We take extra
 905  * care to print only the relevant part of the format if it is longer
 906  * than a standard 80 column display. */
 907
 908 void
 909 format_error (st_parameter_dt *dtp, const fnode *f, const char *message)
 910 {
 911   int width, i, j, offset;
 912   char *p, buffer[300];
 913   format_data *fmt = dtp->u.p.fmt;
 914
 915   if (f != NULL)
 916     fmt->format_string = f->source;
 917
 918   st_sprintf (buffer, "%s\n", message);
 919
 920   j = fmt->format_string - dtp->format;
 921
 922   offset = (j > 60) ? j - 40 : 0;
 923
 924   j -= offset;
 925   width = dtp->format_len - offset;
 926
 927   if (width > 80)
 928     width = 80;
 929
 930   /* Show the format */
 931
 932   p = strchr (buffer, '\0');
 933
 934   memcpy (p, dtp->format + offset, width);
 935
 936   p += width;
 937   *p++ = '\n';
 938
 939   /* Show where the problem is */
 940
 941   for (i = 1; i < j; i++)
 942     *p++ = ' ';
 943
 944   *p++ = '^';
 945   *p = '\0';
 946
 947   generate_error (&dtp->common, ERROR_FORMAT, buffer);
 948 }
 949
 950
 951 /* parse_format()-- Parse a format string.  */
 952
 953 void
 954 parse_format (st_parameter_dt *dtp)
 955 {
 956   format_data *fmt;
 957
 958   dtp->u.p.fmt = fmt = get_mem (sizeof (format_data));
 959   fmt->format_string = dtp->format;
 960   fmt->format_string_len = dtp->format_len;
 961
 962   fmt->string = NULL;
 963   fmt->saved_token = FMT_NONE;
 964   fmt->error = NULL;
 965   fmt->value = 0;
 966
 967   /* Initialize variables used during traversal of the tree */
 968
 969   fmt->reversion_ok = 0;
 970   fmt->saved_format = NULL;
 971
 972   /* Allocate the first format node as the root of the tree */
 973
 974   fmt->last = &fmt->array;
 975   fmt->last->next = NULL;
 976   fmt->avail = &fmt->array.array[0];
 977
 978   memset (fmt->avail, 0, sizeof (*fmt->avail));
 979   fmt->avail->format = FMT_LPAREN;
 980   fmt->avail->repeat = 1;
 981   fmt->avail++;
 982
 983   if (format_lex (fmt) == FMT_LPAREN)
 984     fmt->array.array[0].u.child = parse_format_list (dtp);
 985   else
 986     fmt->error = "Missing initial left parenthesis in format";
 987
 988   if (fmt->error)
 989     format_error (dtp, NULL, fmt->error);
 990 }
 991
 992
 993 /* revert()-- Do reversion of the format.  Control reverts to the left
 994  * parenthesis that matches the rightmost right parenthesis.  From our
 995  * tree structure, we are looking for the rightmost parenthesis node
 996  * at the second level, the first level always being a single
 997  * parenthesis node.  If this node doesn't exit, we use the top
 998  * level. */
 999
1000 static void
1001 revert (st_parameter_dt *dtp)
1002 {
1003   fnode *f, *r;
1004   format_data *fmt = dtp->u.p.fmt;
1005
1006   dtp->u.p.reversion_flag = 1;
1007
1008   r = NULL;
1009
1010   for (f = fmt->array.array[0].u.child; f; f = f->next)
1011     if (f->format == FMT_LPAREN)
1012       r = f;
1013
1014   /* If r is NULL because no node was found, the whole tree will be used */
1015
1016   fmt->array.array[0].current = r;
1017   fmt->array.array[0].count = 0;
1018 }
1019
1020
1021 /* next_format0()-- Get the next format node without worrying about
1022  * reversion.  Returns NULL when we hit the end of the list.
1023  * Parenthesis nodes are incremented after the list has been
1024  * exhausted, other nodes are incremented before they are returned. */
1025
1026 static const fnode *
1027 next_format0 (fnode * f)
1028 {
1029   const fnode *r;
1030
1031   if (f == NULL)
1032     return NULL;
1033
1034   if (f->format != FMT_LPAREN)
1035     {
1036       f->count++;
1037       if (f->count <= f->repeat)
1038         return f;
1039
1040       f->count = 0;
1041       return NULL;
1042     }
1043
1044   /* Deal with a parenthesis node */
1045
1046   for (; f->count < f->repeat; f->count++)
1047     {
1048       if (f->current == NULL)
1049         f->current = f->u.child;
1050
1051       for (; f->current != NULL; f->current = f->current->next)
1052         {
1053           r = next_format0 (f->current);
1054           if (r != NULL)
1055             return r;
1056         }
1057     }
1058
1059   f->count = 0;
1060   return NULL;
1061 }
1062
1063
1064 /* next_format()-- Return the next format node.  If the format list
1065  * ends up being exhausted, we do reversion.  Reversion is only
1066  * allowed if the we've seen a data descriptor since the
1067  * initialization or the last reversion.  We return NULL if there
1068  * are no more data descriptors to return (which is an error
1069  * condition). */
1070
1071 const fnode *
1072 next_format (st_parameter_dt *dtp)
1073 {
1074   format_token t;
1075   const fnode *f;
1076   format_data *fmt = dtp->u.p.fmt;
1077
1078   if (fmt->saved_format != NULL)
1079     {                           /* Deal with a pushed-back format node */
1080       f = fmt->saved_format;
1081       fmt->saved_format = NULL;
1082       goto done;
1083     }
1084
1085   f = next_format0 (&fmt->array.array[0]);
1086   if (f == NULL)
1087     {
1088       if (!fmt->reversion_ok)
1089         return NULL;
1090
1091       fmt->reversion_ok = 0;
1092       revert (dtp);
1093
1094       f = next_format0 (&fmt->array.array[0]);
1095       if (f == NULL)
1096         {
1097           format_error (dtp, NULL, reversion_error);
1098           return NULL;
1099         }
1100
1101       /* Push the first reverted token and return a colon node in case
1102        * there are no more data items. */
1103
1104       fmt->saved_format = f;
1105       return &colon_node;
1106     }
1107
1108   /* If this is a data edit descriptor, then reversion has become OK. */
1109  done:
1110   t = f->format;
1111
1112   if (!fmt->reversion_ok &&
1113       (t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F ||
1114        t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
1115        t == FMT_A || t == FMT_D))
1116     fmt->reversion_ok = 1;
1117   return f;
1118 }
1119
1120
1121 /* unget_format()-- Push the given format back so that it will be
1122  * returned on the next call to next_format() without affecting
1123  * counts.  This is necessary when we've encountered a data
1124  * descriptor, but don't know what the data item is yet.  The format
1125  * node is pushed back, and we return control to the main program,
1126  * which calls the library back with the data item (or not). */
1127
1128 void
1129 unget_format (st_parameter_dt *dtp, const fnode *f)
1130 {
1131   dtp->u.p.fmt->saved_format = f;
1132 }
1133