OSDN Git Service

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