OSDN Git Service

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