libgfortran/io/format.c

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