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