libgfortran/io/format.c

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