libgfortran/io/format.c

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