libgfortran/io/format.c

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