libgfortran/io/format.c

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