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