1 /* Copyright (C) 2002, 2003, 2004, 2005
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file. (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 GNU General Public License for more details.
26 You should have received a copy of the GNU General Public License
27 along with Libgfortran; see the file COPYING. If not, write to
28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA. */
32 /* format.c-- parse a FORMAT string into a binary format suitable for
33 * interpretation during I/O statements */
38 #include "libgfortran.h"
43 /* Number of format nodes that we can store statically before we have
44 * to resort to dynamic allocation. The root node is array[0]. */
46 #define FARRAY_SIZE 200
48 static fnode
*avail
, array
[FARRAY_SIZE
];
50 /* Local variables for checking format strings. The saved_token is
51 * used to back up by a single format token during the parsing process. */
53 static char *format_string
, *string
;
54 static const char *error
;
55 static format_token saved_token
;
56 static int value
, format_string_len
, reversion_ok
;
58 static fnode
*saved_format
;
59 static fnode colon_node
= { FMT_COLON
, 0, NULL
, NULL
, {{ 0, 0, 0 }}, 0,
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 in format",
68 unexpected_end
[] = "Unexpected end of format string",
69 bad_string
[] = "Unterminated character constant in format",
70 bad_hollerith
[] = "Hollerith constant extends past the end of the format",
71 reversion_error
[] = "Exhausted data descriptors in format";
74 /* next_char()-- Return the next character in the format string.
75 * Returns -1 when the string is done. If the literal flag is set,
76 * spaces are significant, otherwise they are not. */
79 next_char (int literal
)
85 if (format_string_len
== 0)
89 c
= toupper (*format_string
++);
91 while (c
== ' ' && !literal
);
97 /* unget_char()-- Back up one character position. */
99 #define unget_char() { format_string--; format_string_len++; }
102 /* get_fnode()-- Allocate a new format node, inserting it into the
103 * current singly linked list. These are initially allocated from the
107 get_fnode (fnode
** head
, fnode
** tail
, format_token t
)
111 if (avail
- array
>= FARRAY_SIZE
)
112 f
= get_mem (sizeof (fnode
));
116 memset (f
, '\0', sizeof (fnode
));
129 f
->source
= format_string
;
134 /* free_fnode()-- Recursive function to free the given fnode and
135 * everything it points to. We only have to actually free something
136 * if it is outside of the static array. */
139 free_fnode (fnode
* f
)
147 if (f
->format
== FMT_LPAREN
)
148 free_fnode (f
->u
.child
);
149 if (f
< array
|| f
>= array
+ FARRAY_SIZE
)
155 /* free_fnodes()-- Free the current tree of fnodes. We only have to
156 * traverse the tree if some nodes were allocated dynamically. */
161 if (avail
- array
>= FARRAY_SIZE
)
162 free_fnode (&array
[0]);
165 memset(array
, 0, sizeof(avail
[0]) * FARRAY_SIZE
);
169 /* format_lex()-- Simple lexical analyzer for getting the next token
170 * in a FORMAT string. We support a one-level token pushback in the
171 * saved_token variable. */
181 if (saved_token
!= FMT_NONE
)
184 saved_token
= FMT_NONE
;
213 value
= 10 * value
+ c
- '0';
220 token
= FMT_SIGNED_INT
;
241 value
= 10 * value
+ c
- '0';
245 token
= (value
== 0) ? FMT_ZERO
: FMT_POSINT
;
269 switch (next_char (0))
298 switch (next_char (0))
315 switch (next_char (0))
335 string
= format_string
;
336 value
= 0; /* This is the length of the string */
343 token
= FMT_BADSTRING
;
354 token
= FMT_BADSTRING
;
393 switch (next_char (0))
442 /* parse_format_list()-- Parse a format list. Assumes that a left
443 * paren has already been seen. Returns a list representing the
444 * parenthesis node which contains the rest of the list. */
447 parse_format_list (void)
450 format_token t
, u
, t2
;
455 /* Get the next format item */
468 get_fnode (&head
, &tail
, FMT_LPAREN
);
469 tail
->repeat
= repeat
;
470 tail
->u
.child
= parse_format_list ();
477 get_fnode (&head
, &tail
, FMT_SLASH
);
478 tail
->repeat
= repeat
;
482 get_fnode (&head
, &tail
, FMT_X
);
495 get_fnode (&head
, &tail
, FMT_LPAREN
);
497 tail
->u
.child
= parse_format_list ();
503 case FMT_SIGNED_INT
: /* Signed integer can only precede a P format. */
504 case FMT_ZERO
: /* Same for zero. */
508 error
= "Expected P edit descriptor in format";
513 get_fnode (&head
, &tail
, FMT_P
);
518 if (t
== FMT_F
|| t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_D
519 || t
== FMT_G
|| t
== FMT_E
)
528 case FMT_P
: /* P and X require a prior number */
529 error
= "P descriptor requires leading scale factor";
536 If we would be pedantic in the library, we would have to reject
537 an X descriptor without an integer prefix:
539 error = "X descriptor requires leading space count";
542 However, this is an extension supported by many Fortran compilers,
543 including Cray, HP, AIX, and IRIX. Therefore, we allow it in the
544 runtime library, and make the front end reject it if the compiler
545 is in pedantic mode. The interpretation of 'X' is '1X'.
547 get_fnode (&head
, &tail
, FMT_X
);
553 get_fnode (&head
, &tail
, FMT_STRING
);
555 tail
->u
.string
.p
= string
;
556 tail
->u
.string
.length
= value
;
565 get_fnode (&head
, &tail
, t
);
570 get_fnode (&head
, &tail
, FMT_COLON
);
575 get_fnode (&head
, &tail
, FMT_SLASH
);
581 get_fnode (&head
, &tail
, FMT_DOLLAR
);
583 notify_std (GFC_STD_GNU
, "Extension: $ descriptor");
590 if (t2
!= FMT_POSINT
)
592 error
= posint_required
;
595 get_fnode (&head
, &tail
, t
);
616 get_fnode (&head
, &tail
, FMT_STRING
);
618 if (format_string_len
< 1)
620 error
= bad_hollerith
;
624 tail
->u
.string
.p
= format_string
;
625 tail
->u
.string
.length
= 1;
634 error
= unexpected_end
;
644 error
= unexpected_element
;
648 /* In this state, t must currently be a data descriptor. Deal with
649 things that can/must follow the descriptor */
657 error
= "Repeat count cannot follow P descriptor";
662 get_fnode (&head
, &tail
, FMT_P
);
670 error
= posint_required
;
674 get_fnode (&head
, &tail
, FMT_L
);
676 tail
->repeat
= repeat
;
684 value
= -1; /* Width not present */
687 get_fnode (&head
, &tail
, FMT_A
);
688 tail
->repeat
= repeat
;
698 get_fnode (&head
, &tail
, t
);
699 tail
->repeat
= repeat
;
702 if (t
== FMT_F
|| g
.mode
== WRITING
)
704 if (u
!= FMT_POSINT
&& u
!= FMT_ZERO
)
706 error
= nonneg_required
;
714 error
= posint_required
;
719 tail
->u
.real
.w
= value
;
724 error
= period_required
;
729 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
731 error
= nonneg_required
;
735 tail
->u
.real
.d
= value
;
737 if (t
== FMT_D
|| t
== FMT_F
)
742 /* Look for optional exponent */
751 error
= "Positive exponent width required in format";
755 tail
->u
.real
.e
= value
;
761 if (repeat
> format_string_len
)
763 error
= bad_hollerith
;
767 get_fnode (&head
, &tail
, FMT_STRING
);
769 tail
->u
.string
.p
= format_string
;
770 tail
->u
.string
.length
= repeat
;
773 format_string
+= value
;
774 format_string_len
-= repeat
;
782 get_fnode (&head
, &tail
, t
);
783 tail
->repeat
= repeat
;
787 if (g
.mode
== READING
)
791 error
= posint_required
;
797 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
799 error
= nonneg_required
;
804 tail
->u
.integer
.w
= value
;
805 tail
->u
.integer
.m
= -1;
815 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
817 error
= nonneg_required
;
821 tail
->u
.integer
.m
= value
;
824 if (tail
->u
.integer
.w
!= 0 && tail
->u
.integer
.m
> tail
->u
.integer
.w
)
826 error
= "Minimum digits exceeds field width";
833 error
= unexpected_element
;
837 /* Between a descriptor and what comes next */
849 get_fnode (&head
, &tail
, FMT_SLASH
);
858 error
= unexpected_end
;
862 /* Assume a missing comma, this is a GNU extension */
866 /* Optional comma is a weird between state where we've just finished
867 reading a colon, slash or P descriptor. */
878 default: /* Assume that we have another format item */
890 /* format_error()-- Generate an error message for a format statement.
891 * If the node that gives the location of the error is NULL, the error
892 * is assumed to happen at parse time, and the current location of the
895 * After freeing any dynamically allocated fnodes, generate a message
896 * showing where the problem is. We take extra care to print only the
897 * relevant part of the format if it is longer than a standard 80
901 format_error (fnode
* f
, const char *message
)
903 int width
, i
, j
, offset
;
904 char *p
, buffer
[300];
907 format_string
= f
->source
;
911 st_sprintf (buffer
, "%s\n", message
);
913 j
= format_string
- ioparm
.format
;
915 offset
= (j
> 60) ? j
- 40 : 0;
918 width
= ioparm
.format_len
- offset
;
923 /* Show the format */
925 p
= strchr (buffer
, '\0');
927 memcpy (p
, ioparm
.format
+ offset
, width
);
932 /* Show where the problem is */
934 for (i
= 1; i
< j
; i
++)
940 generate_error (ERROR_FORMAT
, buffer
);
944 /* parse_format()-- Parse a format string. */
949 format_string
= ioparm
.format
;
950 format_string_len
= ioparm
.format_len
;
952 saved_token
= FMT_NONE
;
955 /* Initialize variables used during traversal of the tree */
958 g
.reversion_flag
= 0;
961 /* Allocate the first format node as the root of the tree */
965 avail
->format
= FMT_LPAREN
;
969 if (format_lex () == FMT_LPAREN
)
970 array
[0].u
.child
= parse_format_list ();
972 error
= "Missing initial left parenthesis in format";
975 format_error (NULL
, error
);
979 /* revert()-- Do reversion of the format. Control reverts to the left
980 * parenthesis that matches the rightmost right parenthesis. From our
981 * tree structure, we are looking for the rightmost parenthesis node
982 * at the second level, the first level always being a single
983 * parenthesis node. If this node doesn't exit, we use the top
991 g
.reversion_flag
= 1;
995 for (f
= array
[0].u
.child
; f
; f
= f
->next
)
996 if (f
->format
== FMT_LPAREN
)
999 /* If r is NULL because no node was found, the whole tree will be used */
1001 array
[0].current
= r
;
1006 /* next_format0()-- Get the next format node without worrying about
1007 * reversion. Returns NULL when we hit the end of the list.
1008 * Parenthesis nodes are incremented after the list has been
1009 * exhausted, other nodes are incremented before they are returned. */
1012 next_format0 (fnode
* f
)
1019 if (f
->format
!= FMT_LPAREN
)
1022 if (f
->count
<= f
->repeat
)
1029 /* Deal with a parenthesis node */
1031 for (; f
->count
< f
->repeat
; f
->count
++)
1033 if (f
->current
== NULL
)
1034 f
->current
= f
->u
.child
;
1036 for (; f
->current
!= NULL
; f
->current
= f
->current
->next
)
1038 r
= next_format0 (f
->current
);
1049 /* next_format()-- Return the next format node. If the format list
1050 * ends up being exhausted, we do reversion. Reversion is only
1051 * allowed if the we've seen a data descriptor since the
1052 * initialization or the last reversion. We return NULL if the there
1053 * are no more data descriptors to return (which is an error
1062 if (saved_format
!= NULL
)
1063 { /* Deal with a pushed-back format node */
1065 saved_format
= NULL
;
1069 f
= next_format0 (&array
[0]);
1080 f
= next_format0 (&array
[0]);
1083 format_error (NULL
, reversion_error
);
1087 /* Push the first reverted token and return a colon node in case
1088 * there are no more data items. */
1094 /* If this is a data edit descriptor, then reversion has become OK. */
1098 if (!reversion_ok
&&
1099 (t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
|| t
== FMT_Z
|| t
== FMT_F
||
1100 t
== FMT_E
|| t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
|| t
== FMT_L
||
1101 t
== FMT_A
|| t
== FMT_D
))
1107 /* unget_format()-- Push the given format back so that it will be
1108 * returned on the next call to next_format() without affecting
1109 * counts. This is necessary when we've encountered a data
1110 * descriptor, but don't know what the data item is yet. The format
1111 * node is pushed back, and we return control to the main program,
1112 * which calls the library back with the data item (or not). */
1115 unget_format (fnode
* f
)
1125 static void dump_format1 (fnode
* f
);
1127 /* dump_format0()-- Dump a single format node */
1130 dump_format0 (fnode
* f
)
1141 st_printf (" %d/", f
->u
.r
);
1147 st_printf (" T%d", f
->u
.n
);
1150 st_printf (" TR%d", f
->u
.n
);
1153 st_printf (" TL%d", f
->u
.n
);
1156 st_printf (" %dX", f
->u
.n
);
1172 st_printf (" %d(", f
->repeat
);
1174 dump_format1 (f
->u
.child
);
1181 for (i
= f
->u
.string
.length
; i
> 0; i
--)
1182 st_printf ("%c", *p
++);
1188 st_printf (" %dP", f
->u
.k
);
1191 st_printf (" %dI%d.%d", f
->repeat
, f
->u
.integer
.w
, f
->u
.integer
.m
);
1195 st_printf (" %dB%d.%d", f
->repeat
, f
->u
.integer
.w
, f
->u
.integer
.m
);
1199 st_printf (" %dO%d.%d", f
->repeat
, f
->u
.integer
.w
, f
->u
.integer
.m
);
1203 st_printf (" %dZ%d.%d", f
->repeat
, f
->u
.integer
.w
, f
->u
.integer
.m
);
1213 st_printf (" %dD%d.%d", f
->repeat
, f
->u
.real
.w
, f
->u
.real
.d
);
1217 st_printf (" %dEN%d.%dE%d", f
->repeat
, f
->u
.real
.w
, f
->u
.real
.d
,
1222 st_printf (" %dES%d.%dE%d", f
->repeat
, f
->u
.real
.w
, f
->u
.real
.d
,
1227 st_printf (" %dF%d.%d", f
->repeat
, f
->u
.real
.w
, f
->u
.real
.d
);
1231 st_printf (" %dE%d.%dE%d", f
->repeat
, f
->u
.real
.w
, f
->u
.real
.d
,
1236 st_printf (" %dG%d.%dE%d", f
->repeat
, f
->u
.real
.w
, f
->u
.real
.d
,
1241 st_printf (" %dL%d", f
->repeat
, f
->u
.w
);
1244 st_printf (" %dA%d", f
->repeat
, f
->u
.w
);
1254 /* dump_format1()-- Dump a string of format nodes */
1257 dump_format1 (fnode
* f
)
1259 for (; f
; f
= f
->next
)
1263 /* dump_format()-- Dump the whole format node tree */
1268 st_printf ("format = ");
1269 dump_format0 (&array
[0]);
1280 for (i
= 0; i
< 20; i
++)
1285 st_printf ("No format!\n");