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