OSDN Git Service

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