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       get_fnode (fmt, &head, &tail, FMT_SLASH);
 862       tail->repeat = 1;
 863
 864       /* Fall Through */
 865
 866     case FMT_COLON:
 867       goto optional_comma;
 868
 869     case FMT_END:
 870       fmt->error = unexpected_end;
 871       goto finished;
 872
 873     default:
 874       /* Assume a missing comma, this is a GNU extension */
 875       goto format_item_1;
 876     }
 877
 878   /* Optional comma is a weird between state where we've just finished
 879      reading a colon, slash or P descriptor. */
 880  optional_comma:
 881   t = format_lex (fmt);
 882   switch (t)
 883     {
 884     case FMT_COMMA:
 885       break;
 886
 887     case FMT_RPAREN:
 888       goto finished;
 889
 890     default:                    /* Assume that we have another format item */
 891       fmt->saved_token = t;
 892       break;
 893     }
 894
 895   goto format_item;
 896
 897  finished:
 898   return head;
 899 }
 900
 901
 902 /* format_error()-- Generate an error message for a format statement.
 903  * If the node that gives the location of the error is NULL, the error
 904  * is assumed to happen at parse time, and the current location of the
 905  * parser is shown.
 906  *
 907  * We generate a message showing where the problem is.  We take extra
 908  * care to print only the relevant part of the format if it is longer
 909  * than a standard 80 column display. */
 910
 911 void
 912 format_error (st_parameter_dt *dtp, const fnode *f, const char *message)
 913 {
 914   int width, i, j, offset;
 915   char *p, buffer[300];
 916   format_data *fmt = dtp->u.p.fmt;
 917
 918   if (f != NULL)
 919     fmt->format_string = f->source;
 920
 921   st_sprintf (buffer, "%s\n", message);
 922
 923   j = fmt->format_string - dtp->format;
 924
 925   offset = (j > 60) ? j - 40 : 0;
 926
 927   j -= offset;
 928   width = dtp->format_len - offset;
 929
 930   if (width > 80)
 931     width = 80;
 932
 933   /* Show the format */
 934
 935   p = strchr (buffer, '\0');
 936
 937   memcpy (p, dtp->format + offset, width);
 938
 939   p += width;
 940   *p++ = '\n';
 941
 942   /* Show where the problem is */
 943
 944   for (i = 1; i < j; i++)
 945     *p++ = ' ';
 946
 947   *p++ = '^';
 948   *p = '\0';
 949
 950   generate_error (&dtp->common, ERROR_FORMAT, buffer);
 951 }
 952
 953
 954 /* parse_format()-- Parse a format string.  */
 955
 956 void
 957 parse_format (st_parameter_dt *dtp)
 958 {
 959   format_data *fmt;
 960
 961   dtp->u.p.fmt = fmt = get_mem (sizeof (format_data));
 962   fmt->format_string = dtp->format;
 963   fmt->format_string_len = dtp->format_len;
 964
 965   fmt->string = NULL;
 966   fmt->saved_token = FMT_NONE;
 967   fmt->error = NULL;
 968   fmt->value = 0;
 969
 970   /* Initialize variables used during traversal of the tree */
 971
 972   fmt->reversion_ok = 0;
 973   fmt->saved_format = NULL;
 974
 975   /* Allocate the first format node as the root of the tree */
 976
 977   fmt->last = &fmt->array;
 978   fmt->last->next = NULL;
 979   fmt->avail = &fmt->array.array[0];
 980
 981   memset (fmt->avail, 0, sizeof (*fmt->avail));
 982   fmt->avail->format = FMT_LPAREN;
 983   fmt->avail->repeat = 1;
 984   fmt->avail++;
 985
 986   if (format_lex (fmt) == FMT_LPAREN)
 987     fmt->array.array[0].u.child = parse_format_list (dtp);
 988   else
 989     fmt->error = "Missing initial left parenthesis in format";
 990
 991   if (fmt->error)
 992     format_error (dtp, NULL, fmt->error);
 993 }
 994
 995
 996 /* revert()-- Do reversion of the format.  Control reverts to the left
 997  * parenthesis that matches the rightmost right parenthesis.  From our
 998  * tree structure, we are looking for the rightmost parenthesis node
 999  * at the second level, the first level always being a single
1000  * parenthesis node.  If this node doesn't exit, we use the top
1001  * level. */
1002
1003 static void
1004 revert (st_parameter_dt *dtp)
1005 {
1006   fnode *f, *r;
1007   format_data *fmt = dtp->u.p.fmt;
1008
1009   dtp->u.p.reversion_flag = 1;
1010
1011   r = NULL;
1012
1013   for (f = fmt->array.array[0].u.child; f; f = f->next)
1014     if (f->format == FMT_LPAREN)
1015       r = f;
1016
1017   /* If r is NULL because no node was found, the whole tree will be used */
1018
1019   fmt->array.array[0].current = r;
1020   fmt->array.array[0].count = 0;
1021 }
1022
1023
1024 /* next_format0()-- Get the next format node without worrying about
1025  * reversion.  Returns NULL when we hit the end of the list.
1026  * Parenthesis nodes are incremented after the list has been
1027  * exhausted, other nodes are incremented before they are returned. */
1028
1029 static const fnode *
1030 next_format0 (fnode * f)
1031 {
1032   const fnode *r;
1033
1034   if (f == NULL)
1035     return NULL;
1036
1037   if (f->format != FMT_LPAREN)
1038     {
1039       f->count++;
1040       if (f->count <= f->repeat)
1041         return f;
1042
1043       f->count = 0;
1044       return NULL;
1045     }
1046
1047   /* Deal with a parenthesis node */
1048
1049   for (; f->count < f->repeat; f->count++)
1050     {
1051       if (f->current == NULL)
1052         f->current = f->u.child;
1053
1054       for (; f->current != NULL; f->current = f->current->next)
1055         {
1056           r = next_format0 (f->current);
1057           if (r != NULL)
1058             return r;
1059         }
1060     }
1061
1062   f->count = 0;
1063   return NULL;
1064 }
1065
1066
1067 /* next_format()-- Return the next format node.  If the format list
1068  * ends up being exhausted, we do reversion.  Reversion is only
1069  * allowed if the we've seen a data descriptor since the
1070  * initialization or the last reversion.  We return NULL if there
1071  * are no more data descriptors to return (which is an error
1072  * condition). */
1073
1074 const fnode *
1075 next_format (st_parameter_dt *dtp)
1076 {
1077   format_token t;
1078   const fnode *f;
1079   format_data *fmt = dtp->u.p.fmt;
1080
1081   if (fmt->saved_format != NULL)
1082     {                           /* Deal with a pushed-back format node */
1083       f = fmt->saved_format;
1084       fmt->saved_format = NULL;
1085       goto done;
1086     }
1087
1088   f = next_format0 (&fmt->array.array[0]);
1089   if (f == NULL)
1090     {
1091       if (!fmt->reversion_ok)
1092         return NULL;
1093
1094       fmt->reversion_ok = 0;
1095       revert (dtp);
1096
1097       f = next_format0 (&fmt->array.array[0]);
1098       if (f == NULL)
1099         {
1100           format_error (dtp, NULL, reversion_error);
1101           return NULL;
1102         }
1103
1104       /* Push the first reverted token and return a colon node in case
1105        * there are no more data items. */
1106
1107       fmt->saved_format = f;
1108       return &colon_node;
1109     }
1110
1111   /* If this is a data edit descriptor, then reversion has become OK. */
1112  done:
1113   t = f->format;
1114
1115   if (!fmt->reversion_ok &&
1116       (t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F ||
1117        t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
1118        t == FMT_A || t == FMT_D))
1119     fmt->reversion_ok = 1;
1120   return f;
1121 }
1122
1123
1124 /* unget_format()-- Push the given format back so that it will be
1125  * returned on the next call to next_format() without affecting
1126  * counts.  This is necessary when we've encountered a data
1127  * descriptor, but don't know what the data item is yet.  The format
1128  * node is pushed back, and we return control to the main program,
1129  * which calls the library back with the data item (or not). */
1130
1131 void
1132 unget_format (st_parameter_dt *dtp, const fnode *f)
1133 {
1134   dtp->u.p.fmt->saved_format = f;
1135 }
1136