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 (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(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           fmt->error = period_required;
 729           goto finished;
 730         }
 731
 732       t = format_lex (fmt);
 733       if (t != FMT_ZERO && t != FMT_POSINT)
 734         {
 735           fmt->error = nonneg_required;
 736           goto finished;
 737         }
 738
 739       tail->u.real.d = fmt->value;
 740
 741       if (t == FMT_D || t == FMT_F)
 742         break;
 743
 744       tail->u.real.e = -1;
 745
 746       /* Look for optional exponent */
 747       t = format_lex (fmt);
 748       if (t != FMT_E)
 749         fmt->saved_token = t;
 750       else
 751         {
 752           t = format_lex (fmt);
 753           if (t != FMT_POSINT)
 754             {
 755               fmt->error = "Positive exponent width required in format";
 756               goto finished;
 757             }
 758
 759           tail->u.real.e = fmt->value;
 760         }
 761
 762       break;
 763
 764     case FMT_H:
 765       if (repeat > fmt->format_string_len)
 766         {
 767           fmt->error = bad_hollerith;
 768           goto finished;
 769         }
 770
 771       get_fnode (fmt, &head, &tail, FMT_STRING);
 772
 773       tail->u.string.p = fmt->format_string;
 774       tail->u.string.length = repeat;
 775       tail->repeat = 1;
 776
 777       fmt->format_string += fmt->value;
 778       fmt->format_string_len -= repeat;
 779
 780       break;
 781
 782     case FMT_I:
 783     case FMT_B:
 784     case FMT_O:
 785     case FMT_Z:
 786       get_fnode (fmt, &head, &tail, t);
 787       tail->repeat = repeat;
 788
 789       t = format_lex (fmt);
 790
 791       if (dtp->u.p.mode == READING)
 792         {
 793           if (t != FMT_POSINT)
 794             {
 795               fmt->error = posint_required;
 796               goto finished;
 797             }
 798         }
 799       else
 800         {
 801           if (t != FMT_ZERO && t != FMT_POSINT)
 802             {
 803               fmt->error = nonneg_required;
 804               goto finished;
 805             }
 806         }
 807
 808       tail->u.integer.w = fmt->value;
 809       tail->u.integer.m = -1;
 810
 811       t = format_lex (fmt);
 812       if (t != FMT_PERIOD)
 813         {
 814           fmt->saved_token = t;
 815         }
 816       else
 817         {
 818           t = format_lex (fmt);
 819           if (t != FMT_ZERO && t != FMT_POSINT)
 820             {
 821               fmt->error = nonneg_required;
 822               goto finished;
 823             }
 824
 825           tail->u.integer.m = fmt->value;
 826         }
 827
 828       if (tail->u.integer.w != 0 && tail->u.integer.m > tail->u.integer.w)
 829         {
 830           fmt->error = "Minimum digits exceeds field width";
 831           goto finished;
 832         }
 833
 834       break;
 835
 836     default:
 837       fmt->error = unexpected_element;
 838       goto finished;
 839     }
 840
 841   /* Between a descriptor and what comes next */
 842  between_desc:
 843   t = format_lex (fmt);
 844   switch (t)
 845     {
 846     case FMT_COMMA:
 847       goto format_item;
 848
 849     case FMT_RPAREN:
 850       goto finished;
 851
 852     case FMT_SLASH:
 853       get_fnode (fmt, &head, &tail, FMT_SLASH);
 854       tail->repeat = 1;
 855
 856       /* Fall Through */
 857
 858     case FMT_COLON:
 859       goto optional_comma;
 860
 861     case FMT_END:
 862       fmt->error = unexpected_end;
 863       goto finished;
 864
 865     default:
 866       /* Assume a missing comma, this is a GNU extension */
 867       goto format_item_1;
 868     }
 869
 870   /* Optional comma is a weird between state where we've just finished
 871      reading a colon, slash or P descriptor. */
 872  optional_comma:
 873   t = format_lex (fmt);
 874   switch (t)
 875     {
 876     case FMT_COMMA:
 877       break;
 878
 879     case FMT_RPAREN:
 880       goto finished;
 881
 882     default:                    /* Assume that we have another format item */
 883       fmt->saved_token = t;
 884       break;
 885     }
 886
 887   goto format_item;
 888
 889  finished:
 890   return head;
 891 }
 892
 893
 894 /* format_error()-- Generate an error message for a format statement.
 895  * If the node that gives the location of the error is NULL, the error
 896  * is assumed to happen at parse time, and the current location of the
 897  * parser is shown.
 898  *
 899  * We generate a message showing where the problem is.  We take extra
 900  * care to print only the relevant part of the format if it is longer
 901  * than a standard 80 column display. */
 902
 903 void
 904 format_error (st_parameter_dt *dtp, const fnode *f, const char *message)
 905 {
 906   int width, i, j, offset;
 907   char *p, buffer[300];
 908   format_data *fmt = dtp->u.p.fmt;
 909
 910   if (f != NULL)
 911     fmt->format_string = f->source;
 912
 913   st_sprintf (buffer, "%s\n", message);
 914
 915   j = fmt->format_string - dtp->format;
 916
 917   offset = (j > 60) ? j - 40 : 0;
 918
 919   j -= offset;
 920   width = dtp->format_len - offset;
 921
 922   if (width > 80)
 923     width = 80;
 924
 925   /* Show the format */
 926
 927   p = strchr (buffer, '\0');
 928
 929   memcpy (p, dtp->format + offset, width);
 930
 931   p += width;
 932   *p++ = '\n';
 933
 934   /* Show where the problem is */
 935
 936   for (i = 1; i < j; i++)
 937     *p++ = ' ';
 938
 939   *p++ = '^';
 940   *p = '\0';
 941
 942   generate_error (&dtp->common, ERROR_FORMAT, buffer);
 943 }
 944
 945
 946 /* parse_format()-- Parse a format string.  */
 947
 948 void
 949 parse_format (st_parameter_dt *dtp)
 950 {
 951   format_data *fmt;
 952
 953   dtp->u.p.fmt = fmt = get_mem (sizeof (format_data));
 954   fmt->format_string = dtp->format;
 955   fmt->format_string_len = dtp->format_len;
 956
 957   fmt->string = NULL;
 958   fmt->saved_token = FMT_NONE;
 959   fmt->error = NULL;
 960   fmt->value = 0;
 961
 962   /* Initialize variables used during traversal of the tree */
 963
 964   fmt->reversion_ok = 0;
 965   fmt->saved_format = NULL;
 966
 967   /* Allocate the first format node as the root of the tree */
 968
 969   fmt->last = &fmt->array;
 970   fmt->last->next = NULL;
 971   fmt->avail = &fmt->array.array[0];
 972
 973   memset (fmt->avail, 0, sizeof (*fmt->avail));
 974   fmt->avail->format = FMT_LPAREN;
 975   fmt->avail->repeat = 1;
 976   fmt->avail++;
 977
 978   if (format_lex (fmt) == FMT_LPAREN)
 979     fmt->array.array[0].u.child = parse_format_list (dtp);
 980   else
 981     fmt->error = "Missing initial left parenthesis in format";
 982
 983   if (fmt->error)
 984     format_error (dtp, NULL, fmt->error);
 985 }
 986
 987
 988 /* revert()-- Do reversion of the format.  Control reverts to the left
 989  * parenthesis that matches the rightmost right parenthesis.  From our
 990  * tree structure, we are looking for the rightmost parenthesis node
 991  * at the second level, the first level always being a single
 992  * parenthesis node.  If this node doesn't exit, we use the top
 993  * level. */
 994
 995 static void
 996 revert (st_parameter_dt *dtp)
 997 {
 998   fnode *f, *r;
 999   format_data *fmt = dtp->u.p.fmt;
1000
1001   dtp->u.p.reversion_flag = 1;
1002
1003   r = NULL;
1004
1005   for (f = fmt->array.array[0].u.child; f; f = f->next)
1006     if (f->format == FMT_LPAREN)
1007       r = f;
1008
1009   /* If r is NULL because no node was found, the whole tree will be used */
1010
1011   fmt->array.array[0].current = r;
1012   fmt->array.array[0].count = 0;
1013 }
1014
1015
1016 /* next_format0()-- Get the next format node without worrying about
1017  * reversion.  Returns NULL when we hit the end of the list.
1018  * Parenthesis nodes are incremented after the list has been
1019  * exhausted, other nodes are incremented before they are returned. */
1020
1021 static const fnode *
1022 next_format0 (fnode * f)
1023 {
1024   const fnode *r;
1025
1026   if (f == NULL)
1027     return NULL;
1028
1029   if (f->format != FMT_LPAREN)
1030     {
1031       f->count++;
1032       if (f->count <= f->repeat)
1033         return f;
1034
1035       f->count = 0;
1036       return NULL;
1037     }
1038
1039   /* Deal with a parenthesis node */
1040
1041   for (; f->count < f->repeat; f->count++)
1042     {
1043       if (f->current == NULL)
1044         f->current = f->u.child;
1045
1046       for (; f->current != NULL; f->current = f->current->next)
1047         {
1048           r = next_format0 (f->current);
1049           if (r != NULL)
1050             return r;
1051         }
1052     }
1053
1054   f->count = 0;
1055   return NULL;
1056 }
1057
1058
1059 /* next_format()-- Return the next format node.  If the format list
1060  * ends up being exhausted, we do reversion.  Reversion is only
1061  * allowed if the we've seen a data descriptor since the
1062  * initialization or the last reversion.  We return NULL if there
1063  * are no more data descriptors to return (which is an error
1064  * condition). */
1065
1066 const fnode *
1067 next_format (st_parameter_dt *dtp)
1068 {
1069   format_token t;
1070   const fnode *f;
1071   format_data *fmt = dtp->u.p.fmt;
1072
1073   if (fmt->saved_format != NULL)
1074     {                           /* Deal with a pushed-back format node */
1075       f = fmt->saved_format;
1076       fmt->saved_format = NULL;
1077       goto done;
1078     }
1079
1080   f = next_format0 (&fmt->array.array[0]);
1081   if (f == NULL)
1082     {
1083       if (!fmt->reversion_ok)
1084         return NULL;
1085
1086       fmt->reversion_ok = 0;
1087       revert (dtp);
1088
1089       f = next_format0 (&fmt->array.array[0]);
1090       if (f == NULL)
1091         {
1092           format_error (dtp, NULL, reversion_error);
1093           return NULL;
1094         }
1095
1096       /* Push the first reverted token and return a colon node in case
1097        * there are no more data items. */
1098
1099       fmt->saved_format = f;
1100       return &colon_node;
1101     }
1102
1103   /* If this is a data edit descriptor, then reversion has become OK. */
1104  done:
1105   t = f->format;
1106
1107   if (!fmt->reversion_ok &&
1108       (t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F ||
1109        t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
1110        t == FMT_A || t == FMT_D))
1111     fmt->reversion_ok = 1;
1112   return f;
1113 }
1114
1115
1116 /* unget_format()-- Push the given format back so that it will be
1117  * returned on the next call to next_format() without affecting
1118  * counts.  This is necessary when we've encountered a data
1119  * descriptor, but don't know what the data item is yet.  The format
1120  * node is pushed back, and we return control to the main program,
1121  * which calls the library back with the data item (or not). */
1122
1123 void
1124 unget_format (st_parameter_dt *dtp, const fnode *f)
1125 {
1126   dtp->u.p.fmt->saved_format = f;
1127 }
1128