OSDN Git Service

3f7091e66d0d7278c486afb7826418670f09d835
[pf3gnuchains/gcc-fork.git] / 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