libgfortran/io/format.c

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