libgfortran/io/format.c

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