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       goto between_desc;
 583
 584     case FMT_T:
 585     case FMT_TL:
 586     case FMT_TR:
 587       t2 = format_lex ();
 588       if (t2 != FMT_POSINT)
 589         {
 590           error = posint_required;
 591           goto finished;
 592         }
 593       get_fnode (&head, &tail, t);
 594       tail->u.n = value;
 595       tail->repeat = 1;
 596       goto between_desc;
 597
 598     case FMT_I:
 599     case FMT_B:
 600     case FMT_O:
 601     case FMT_Z:
 602     case FMT_E:
 603     case FMT_EN:
 604     case FMT_ES:
 605     case FMT_D:
 606     case FMT_L:
 607     case FMT_A:
 608     case FMT_F:
 609     case FMT_G:
 610       repeat = 1;
 611       goto data_desc;
 612
 613     case FMT_H:
 614       get_fnode (&head, &tail, FMT_STRING);
 615
 616       if (format_string_len < 1)
 617         {
 618           error = bad_hollerith;
 619           goto finished;
 620         }
 621
 622       tail->u.string.p = format_string;
 623       tail->u.string.length = 1;
 624       tail->repeat = 1;
 625
 626       format_string++;
 627       format_string_len--;
 628
 629       goto between_desc;
 630
 631     case FMT_END:
 632       error = unexpected_end;
 633       goto finished;
 634
 635     case FMT_BADSTRING:
 636       goto finished;
 637
 638     case FMT_RPAREN:
 639       goto finished;
 640
 641     default:
 642       error = unexpected_element;
 643       goto finished;
 644     }
 645
 646   /* In this state, t must currently be a data descriptor.  Deal with
 647      things that can/must follow the descriptor */
 648  data_desc:
 649   switch (t)
 650     {
 651     case FMT_P:
 652       t = format_lex ();
 653       if (t == FMT_POSINT)
 654         {
 655           error = "Repeat count cannot follow P descriptor";
 656           goto finished;
 657         }
 658
 659       saved_token = t;
 660       get_fnode (&head, &tail, FMT_P);
 661
 662       goto optional_comma;
 663
 664     case FMT_L:
 665       t = format_lex ();
 666       if (t != FMT_POSINT)
 667         {
 668           error = posint_required;
 669           goto finished;
 670         }
 671
 672       get_fnode (&head, &tail, FMT_L);
 673       tail->u.n = value;
 674       tail->repeat = repeat;
 675       break;
 676
 677     case FMT_A:
 678       t = format_lex ();
 679       if (t != FMT_POSINT)
 680         {
 681           saved_token = t;
 682           value = -1;           /* Width not present */
 683         }
 684
 685       get_fnode (&head, &tail, FMT_A);
 686       tail->repeat = repeat;
 687       tail->u.n = value;
 688       break;
 689
 690     case FMT_D:
 691     case FMT_E:
 692     case FMT_F:
 693     case FMT_G:
 694     case FMT_EN:
 695     case FMT_ES:
 696       get_fnode (&head, &tail, t);
 697       tail->repeat = repeat;
 698
 699       u = format_lex ();
 700       if (t == FMT_F || g.mode == WRITING)
 701         {
 702           if (u != FMT_POSINT && u != FMT_ZERO)
 703             {
 704               error = nonneg_required;
 705               goto finished;
 706             }
 707         }
 708       else
 709         {
 710           if (u != FMT_POSINT)
 711             {
 712               error = posint_required;
 713               goto finished;
 714             }
 715         }
 716
 717       tail->u.real.w = value;
 718       t2 = t;
 719       t = format_lex ();
 720       if (t != FMT_PERIOD)
 721         {
 722           error = period_required;
 723           goto finished;
 724         }
 725
 726       t = format_lex ();
 727       if (t != FMT_ZERO && t != FMT_POSINT)
 728         {
 729           error = nonneg_required;
 730           goto finished;
 731         }
 732
 733       tail->u.real.d = value;
 734
 735       if (t == FMT_D || t == FMT_F)
 736         break;
 737
 738       tail->u.real.e = -1;
 739
 740       /* Look for optional exponent */
 741       t = format_lex ();
 742       if (t != FMT_E)
 743         saved_token = t;
 744       else
 745         {
 746           t = format_lex ();
 747           if (t != FMT_POSINT)
 748             {
 749               error = "Positive exponent width required in format";
 750               goto finished;
 751             }
 752
 753           tail->u.real.e = value;
 754         }
 755
 756       break;
 757
 758     case FMT_H:
 759       if (repeat > format_string_len)
 760         {
 761           error = bad_hollerith;
 762           goto finished;
 763         }
 764
 765       get_fnode (&head, &tail, FMT_STRING);
 766
 767       tail->u.string.p = format_string;
 768       tail->u.string.length = repeat;
 769       tail->repeat = 1;
 770
 771       format_string += value;
 772       format_string_len -= repeat;
 773
 774       break;
 775
 776     case FMT_I:
 777     case FMT_B:
 778     case FMT_O:
 779     case FMT_Z:
 780       get_fnode (&head, &tail, t);
 781       tail->repeat = repeat;
 782
 783       t = format_lex ();
 784
 785       if (g.mode == READING)
 786         {
 787           if (t != FMT_POSINT)
 788             {
 789               error = posint_required;
 790               goto finished;
 791             }
 792         }
 793       else
 794         {
 795           if (t != FMT_ZERO && t != FMT_POSINT)
 796             {
 797               error = nonneg_required;
 798               goto finished;
 799             }
 800         }
 801
 802       tail->u.integer.w = value;
 803       tail->u.integer.m = -1;
 804
 805       t = format_lex ();
 806       if (t != FMT_PERIOD)
 807         {
 808           saved_token = t;
 809         }
 810       else
 811         {
 812           t = format_lex ();
 813           if (t != FMT_ZERO && t != FMT_POSINT)
 814             {
 815               error = nonneg_required;
 816               goto finished;
 817             }
 818
 819           tail->u.integer.m = value;
 820         }
 821
 822       if (tail->u.integer.w != 0 && tail->u.integer.m > tail->u.integer.w)
 823         {
 824           error = "Minimum digits exceeds field width";
 825           goto finished;
 826         }
 827
 828       break;
 829
 830     default:
 831       error = unexpected_element;
 832       goto finished;
 833     }
 834
 835   /* Between a descriptor and what comes next */
 836  between_desc:
 837   t = format_lex ();
 838   switch (t)
 839     {
 840     case FMT_COMMA:
 841       goto format_item;
 842
 843     case FMT_RPAREN:
 844       goto finished;
 845
 846     case FMT_SLASH:
 847       get_fnode (&head, &tail, FMT_SLASH);
 848       tail->repeat = 1;
 849
 850       /* Fall Through */
 851
 852     case FMT_COLON:
 853       goto optional_comma;
 854
 855     case FMT_END:
 856       error = unexpected_end;
 857       goto finished;
 858
 859     default:
 860       /* Assume a missing comma, this is a GNU extension */
 861       goto format_item_1;
 862     }
 863
 864   /* Optional comma is a weird between state where we've just finished
 865      reading a colon, slash or P descriptor. */
 866  optional_comma:
 867   t = format_lex ();
 868   switch (t)
 869     {
 870     case FMT_COMMA:
 871       break;
 872
 873     case FMT_RPAREN:
 874       goto finished;
 875
 876     default:                    /* Assume that we have another format item */
 877       saved_token = t;
 878       break;
 879     }
 880
 881   goto format_item;
 882
 883  finished:
 884   return head;
 885 }
 886
 887
 888 /* format_error()-- Generate an error message for a format statement.
 889  * If the node that gives the location of the error is NULL, the error
 890  * is assumed to happen at parse time, and the current location of the
 891  * parser is shown.
 892  *
 893  * After freeing any dynamically allocated fnodes, generate a message
 894  * showing where the problem is.  We take extra care to print only the
 895  * relevant part of the format if it is longer than a standard 80
 896  * column display. */
 897
 898 void
 899 format_error (fnode * f, const char *message)
 900 {
 901   int width, i, j, offset;
 902   char *p, buffer[300];
 903
 904   if (f != NULL)
 905     format_string = f->source;
 906
 907   free_fnodes ();
 908
 909   st_sprintf (buffer, "%s\n", message);
 910
 911   j = format_string - ioparm.format;
 912
 913   offset = (j > 60) ? j - 40 : 0;
 914
 915   j -= offset;
 916   width = ioparm.format_len - offset;
 917
 918   if (width > 80)
 919     width = 80;
 920
 921   /* Show the format */
 922
 923   p = strchr (buffer, '\0');
 924
 925   memcpy (p, ioparm.format + offset, width);
 926
 927   p += width;
 928   *p++ = '\n';
 929
 930   /* Show where the problem is */
 931
 932   for (i = 1; i < j; i++)
 933     *p++ = ' ';
 934
 935   *p++ = '^';
 936   *p = '\0';
 937
 938   generate_error (ERROR_FORMAT, buffer);
 939 }
 940
 941
 942 /* parse_format()-- Parse a format string.  */
 943
 944 void
 945 parse_format (void)
 946 {
 947   format_string = ioparm.format;
 948   format_string_len = ioparm.format_len;
 949
 950   saved_token = FMT_NONE;
 951   error = NULL;
 952
 953   /* Initialize variables used during traversal of the tree */
 954
 955   reversion_ok = 0;
 956   g.reversion_flag = 0;
 957   saved_format = NULL;
 958
 959   /* Allocate the first format node as the root of the tree */
 960
 961   avail = array;
 962
 963   avail->format = FMT_LPAREN;
 964   avail->repeat = 1;
 965   avail++;
 966
 967   if (format_lex () == FMT_LPAREN)
 968     array[0].u.child = parse_format_list ();
 969   else
 970     error = "Missing initial left parenthesis in format";
 971
 972   if (error)
 973     format_error (NULL, error);
 974 }
 975
 976
 977 /* revert()-- Do reversion of the format.  Control reverts to the left
 978  * parenthesis that matches the rightmost right parenthesis.  From our
 979  * tree structure, we are looking for the rightmost parenthesis node
 980  * at the second level, the first level always being a single
 981  * parenthesis node.  If this node doesn't exit, we use the top
 982  * level. */
 983
 984 static void
 985 revert (void)
 986 {
 987   fnode *f, *r;
 988
 989   g.reversion_flag = 1;
 990
 991   r = NULL;
 992
 993   for (f = array[0].u.child; f; f = f->next)
 994     if (f->format == FMT_LPAREN)
 995       r = f;
 996
 997   /* If r is NULL because no node was found, the whole tree will be used */
 998
 999   array[0].current = r;
1000   array[0].count = 0;
1001 }
1002
1003
1004 /* next_format0()-- Get the next format node without worrying about
1005  * reversion.  Returns NULL when we hit the end of the list.
1006  * Parenthesis nodes are incremented after the list has been
1007  * exhausted, other nodes are incremented before they are returned. */
1008
1009 static fnode *
1010 next_format0 (fnode * f)
1011 {
1012   fnode *r;
1013
1014   if (f == NULL)
1015     return NULL;
1016
1017   if (f->format != FMT_LPAREN)
1018     {
1019       f->count++;
1020       if (f->count <= f->repeat)
1021         return f;
1022
1023       f->count = 0;
1024       return NULL;
1025     }
1026
1027   /* Deal with a parenthesis node */
1028
1029   for (; f->count < f->repeat; f->count++)
1030     {
1031       if (f->current == NULL)
1032         f->current = f->u.child;
1033
1034       for (; f->current != NULL; f->current = f->current->next)
1035         {
1036           r = next_format0 (f->current);
1037           if (r != NULL)
1038             return r;
1039         }
1040     }
1041
1042   f->count = 0;
1043   return NULL;
1044 }
1045
1046
1047 /* next_format()-- Return the next format node.  If the format list
1048  * ends up being exhausted, we do reversion.  Reversion is only
1049  * allowed if the we've seen a data descriptor since the
1050  * initialization or the last reversion.  We return NULL if the there
1051  * are no more data descriptors to return (which is an error
1052  * condition). */
1053
1054 fnode *
1055 next_format (void)
1056 {
1057   format_token t;
1058   fnode *f;
1059
1060   if (saved_format != NULL)
1061     {                           /* Deal with a pushed-back format node */
1062       f = saved_format;
1063       saved_format = NULL;
1064       goto done;
1065     }
1066
1067   f = next_format0 (&array[0]);
1068   if (f == NULL)
1069     {
1070       if (!reversion_ok)
1071         {
1072           return NULL;
1073         }
1074
1075       reversion_ok = 0;
1076       revert ();
1077
1078       f = next_format0 (&array[0]);
1079       if (f == NULL)
1080         {
1081           format_error (NULL, reversion_error);
1082           return NULL;
1083         }
1084
1085       /* Push the first reverted token and return a colon node in case
1086        * there are no more data items. */
1087
1088       saved_format = f;
1089       return &colon_node;
1090     }
1091
1092   /* If this is a data edit descriptor, then reversion has become OK. */
1093  done:
1094   t = f->format;
1095
1096   if (!reversion_ok &&
1097       (t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F ||
1098        t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
1099        t == FMT_A || t == FMT_D))
1100     reversion_ok = 1;
1101   return f;
1102 }
1103
1104
1105 /* unget_format()-- Push the given format back so that it will be
1106  * returned on the next call to next_format() without affecting
1107  * counts.  This is necessary when we've encountered a data
1108  * descriptor, but don't know what the data item is yet.  The format
1109  * node is pushed back, and we return control to the main program,
1110  * which calls the library back with the data item (or not). */
1111
1112 void
1113 unget_format (fnode * f)
1114 {
1115   saved_format = f;
1116 }
1117
1118
1119
1120
1121 #if 0
1122
1123 static void dump_format1 (fnode * f);
1124
1125 /* dump_format0()-- Dump a single format node */
1126
1127 void
1128 dump_format0 (fnode * f)
1129 {
1130   char *p;
1131   int i;
1132
1133   switch (f->format)
1134     {
1135     case FMT_COLON:
1136       st_printf (" :");
1137       break;
1138     case FMT_SLASH:
1139       st_printf (" %d/", f->u.r);
1140       break;
1141     case FMT_DOLLAR:
1142       st_printf (" $");
1143       break;
1144     case FMT_T:
1145       st_printf (" T%d", f->u.n);
1146       break;
1147     case FMT_TR:
1148       st_printf (" TR%d", f->u.n);
1149       break;
1150     case FMT_TL:
1151       st_printf (" TL%d", f->u.n);
1152       break;
1153     case FMT_X:
1154       st_printf (" %dX", f->u.n);
1155       break;
1156     case FMT_S:
1157       st_printf (" S");
1158       break;
1159     case FMT_SS:
1160       st_printf (" SS");
1161       break;
1162     case FMT_SP:
1163       st_printf (" SP");
1164       break;
1165
1166     case FMT_LPAREN:
1167       if (f->repeat == 1)
1168         st_printf (" (");
1169       else
1170         st_printf (" %d(", f->repeat);
1171
1172       dump_format1 (f->u.child);
1173       st_printf (" )");
1174       break;
1175
1176     case FMT_STRING:
1177       st_printf (" '");
1178       p = f->u.string.p;
1179       for (i = f->u.string.length; i > 0; i--)
1180         st_printf ("%c", *p++);
1181
1182       st_printf ("'");
1183       break;
1184
1185     case FMT_P:
1186       st_printf (" %dP", f->u.k);
1187       break;
1188     case FMT_I:
1189       st_printf (" %dI%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
1190       break;
1191
1192     case FMT_B:
1193       st_printf (" %dB%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
1194       break;
1195
1196     case FMT_O:
1197       st_printf (" %dO%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
1198       break;
1199
1200     case FMT_Z:
1201       st_printf (" %dZ%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
1202       break;
1203
1204     case FMT_BN:
1205       st_printf (" BN");
1206       break;
1207     case FMT_BZ:
1208       st_printf (" BZ");
1209       break;
1210     case FMT_D:
1211       st_printf (" %dD%d.%d", f->repeat, f->u.real.w, f->u.real.d);
1212       break;
1213
1214     case FMT_EN:
1215       st_printf (" %dEN%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
1216                  f->u.real.e);
1217       break;
1218
1219     case FMT_ES:
1220       st_printf (" %dES%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
1221                  f->u.real.e);
1222       break;
1223
1224     case FMT_F:
1225       st_printf (" %dF%d.%d", f->repeat, f->u.real.w, f->u.real.d);
1226       break;
1227
1228     case FMT_E:
1229       st_printf (" %dE%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
1230                  f->u.real.e);
1231       break;
1232
1233     case FMT_G:
1234       st_printf (" %dG%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
1235                  f->u.real.e);
1236       break;
1237
1238     case FMT_L:
1239       st_printf (" %dL%d", f->repeat, f->u.w);
1240       break;
1241     case FMT_A:
1242       st_printf (" %dA%d", f->repeat, f->u.w);
1243       break;
1244
1245     default:
1246       st_printf (" ???");
1247       break;
1248     }
1249 }
1250
1251
1252 /* dump_format1()-- Dump a string of format nodes */
1253
1254 static void
1255 dump_format1 (fnode * f)
1256 {
1257   for (; f; f = f->next)
1258     dump_format1 (f);
1259 }
1260
1261 /* dump_format()-- Dump the whole format node tree */
1262
1263 void
1264 dump_format (void)
1265 {
1266   st_printf ("format = ");
1267   dump_format0 (&array[0]);
1268   st_printf ("\n");
1269 }
1270
1271
1272 void
1273 next_test (void)
1274 {
1275   fnode *f;
1276   int i;
1277
1278   for (i = 0; i < 20; i++)
1279     {
1280       f = next_format ();
1281       if (f == NULL)
1282         {
1283           st_printf ("No format!\n");
1284           break;
1285         }
1286
1287       dump_format1 (f);
1288       st_printf ("\n");
1289     }
1290 }
1291
1292 #endif