]>
git.ipfire.org Git - thirdparty/gcc.git/blob - libgfortran/io/format.c
1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006
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"
41 #define FARRAY_SIZE 64
43 typedef struct fnode_array
45 struct fnode_array
*next
;
46 fnode array
[FARRAY_SIZE
];
50 typedef struct format_data
52 char *format_string
, *string
;
54 format_token saved_token
;
55 int value
, format_string_len
, reversion_ok
;
57 const fnode
*saved_format
;
63 static const fnode colon_node
= { FMT_COLON
, 0, NULL
, NULL
, {{ 0, 0, 0 }}, 0,
68 static const char posint_required
[] = "Positive width required in format",
69 period_required
[] = "Period required in format",
70 nonneg_required
[] = "Nonnegative width required in format",
71 unexpected_element
[] = "Unexpected element in format",
72 unexpected_end
[] = "Unexpected end of format string",
73 bad_string
[] = "Unterminated character constant in format",
74 bad_hollerith
[] = "Hollerith constant extends past the end of the format",
75 reversion_error
[] = "Exhausted data descriptors in format";
78 /* next_char()-- Return the next character in the format string.
79 * Returns -1 when the string is done. If the literal flag is set,
80 * spaces are significant, otherwise they are not. */
83 next_char (format_data
*fmt
, int literal
)
89 if (fmt
->format_string_len
== 0)
92 fmt
->format_string_len
--;
93 c
= toupper (*fmt
->format_string
++);
95 while (c
== ' ' && !literal
);
101 /* unget_char()-- Back up one character position. */
103 #define unget_char(fmt) \
104 { fmt->format_string--; fmt->format_string_len++; }
107 /* get_fnode()-- Allocate a new format node, inserting it into the
108 * current singly linked list. These are initially allocated from the
112 get_fnode (format_data
*fmt
, fnode
**head
, fnode
**tail
, format_token t
)
116 if (fmt
->avail
== &fmt
->last
->array
[FARRAY_SIZE
])
118 fmt
->last
->next
= get_mem (sizeof (fnode_array
));
119 fmt
->last
= fmt
->last
->next
;
120 fmt
->last
->next
= NULL
;
121 fmt
->avail
= &fmt
->last
->array
[0];
124 memset (f
, '\0', sizeof (fnode
));
136 f
->source
= fmt
->format_string
;
141 /* free_format_data()-- Free all allocated format data. */
144 free_format_data (st_parameter_dt
*dtp
)
146 fnode_array
*fa
, *fa_next
;
147 format_data
*fmt
= dtp
->u
.p
.fmt
;
152 for (fa
= fmt
->array
.next
; fa
; fa
= fa_next
)
163 /* format_lex()-- Simple lexical analyzer for getting the next token
164 * in a FORMAT string. We support a one-level token pushback in the
165 * fmt->saved_token variable. */
168 format_lex (format_data
*fmt
)
175 if (fmt
->saved_token
!= FMT_NONE
)
177 token
= fmt
->saved_token
;
178 fmt
->saved_token
= FMT_NONE
;
183 c
= next_char (fmt
, 0);
192 c
= next_char (fmt
, 0);
199 fmt
->value
= c
- '0';
203 c
= next_char (fmt
, 0);
207 fmt
->value
= 10 * fmt
->value
+ c
- '0';
213 fmt
->value
= -fmt
->value
;
214 token
= FMT_SIGNED_INT
;
227 fmt
->value
= c
- '0';
231 c
= next_char (fmt
, 0);
235 fmt
->value
= 10 * fmt
->value
+ c
- '0';
239 token
= (fmt
->value
== 0) ? FMT_ZERO
: FMT_POSINT
;
263 switch (next_char (fmt
, 0))
292 switch (next_char (fmt
, 0))
309 switch (next_char (fmt
, 0))
329 fmt
->string
= fmt
->format_string
;
330 fmt
->value
= 0; /* This is the length of the string */
334 c
= next_char (fmt
, 1);
337 token
= FMT_BADSTRING
;
338 fmt
->error
= bad_string
;
344 c
= next_char (fmt
, 1);
348 token
= FMT_BADSTRING
;
349 fmt
->error
= bad_string
;
387 switch (next_char (fmt
, 0))
436 /* parse_format_list()-- Parse a format list. Assumes that a left
437 * paren has already been seen. Returns a list representing the
438 * parenthesis node which contains the rest of the list. */
441 parse_format_list (st_parameter_dt
*dtp
)
444 format_token t
, u
, t2
;
446 format_data
*fmt
= dtp
->u
.p
.fmt
;
450 /* Get the next format item */
452 t
= format_lex (fmt
);
459 t
= format_lex (fmt
);
463 get_fnode (fmt
, &head
, &tail
, FMT_LPAREN
);
464 tail
->repeat
= repeat
;
465 tail
->u
.child
= parse_format_list (dtp
);
466 if (fmt
->error
!= NULL
)
472 get_fnode (fmt
, &head
, &tail
, FMT_SLASH
);
473 tail
->repeat
= repeat
;
477 get_fnode (fmt
, &head
, &tail
, FMT_X
);
479 tail
->u
.k
= fmt
->value
;
490 get_fnode (fmt
, &head
, &tail
, FMT_LPAREN
);
492 tail
->u
.child
= parse_format_list (dtp
);
493 if (fmt
->error
!= NULL
)
498 case FMT_SIGNED_INT
: /* Signed integer can only precede a P format. */
499 case FMT_ZERO
: /* Same for zero. */
500 t
= format_lex (fmt
);
503 fmt
->error
= "Expected P edit descriptor in format";
508 get_fnode (fmt
, &head
, &tail
, FMT_P
);
509 tail
->u
.k
= fmt
->value
;
512 t
= format_lex (fmt
);
513 if (t
== FMT_F
|| t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_D
514 || t
== FMT_G
|| t
== FMT_E
)
520 fmt
->saved_token
= t
;
523 case FMT_P
: /* P and X require a prior number */
524 fmt
->error
= "P descriptor requires leading scale factor";
531 If we would be pedantic in the library, we would have to reject
532 an X descriptor without an integer prefix:
534 fmt->error = "X descriptor requires leading space count";
537 However, this is an extension supported by many Fortran compilers,
538 including Cray, HP, AIX, and IRIX. Therefore, we allow it in the
539 runtime library, and make the front end reject it if the compiler
540 is in pedantic mode. The interpretation of 'X' is '1X'.
542 get_fnode (fmt
, &head
, &tail
, FMT_X
);
548 get_fnode (fmt
, &head
, &tail
, FMT_STRING
);
550 tail
->u
.string
.p
= fmt
->string
;
551 tail
->u
.string
.length
= fmt
->value
;
560 get_fnode (fmt
, &head
, &tail
, t
);
565 get_fnode (fmt
, &head
, &tail
, FMT_COLON
);
570 get_fnode (fmt
, &head
, &tail
, FMT_SLASH
);
576 get_fnode (fmt
, &head
, &tail
, FMT_DOLLAR
);
578 notify_std (GFC_STD_GNU
, "Extension: $ descriptor");
584 t2
= format_lex (fmt
);
585 if (t2
!= FMT_POSINT
)
587 fmt
->error
= posint_required
;
590 get_fnode (fmt
, &head
, &tail
, t
);
591 tail
->u
.n
= fmt
->value
;
611 get_fnode (fmt
, &head
, &tail
, FMT_STRING
);
613 if (fmt
->format_string_len
< 1)
615 fmt
->error
= bad_hollerith
;
619 tail
->u
.string
.p
= fmt
->format_string
;
620 tail
->u
.string
.length
= 1;
623 fmt
->format_string
++;
624 fmt
->format_string_len
--;
629 fmt
->error
= unexpected_end
;
639 fmt
->error
= unexpected_element
;
643 /* In this state, t must currently be a data descriptor. Deal with
644 things that can/must follow the descriptor */
649 t
= format_lex (fmt
);
652 fmt
->error
= "Repeat count cannot follow P descriptor";
656 fmt
->saved_token
= t
;
657 get_fnode (fmt
, &head
, &tail
, FMT_P
);
662 t
= format_lex (fmt
);
665 if (notification_std(GFC_STD_GNU
) == ERROR
)
667 fmt
->error
= posint_required
;
672 fmt
->saved_token
= t
;
673 fmt
->value
= 1; /* Default width */
674 notify_std(GFC_STD_GNU
, posint_required
);
678 get_fnode (fmt
, &head
, &tail
, FMT_L
);
679 tail
->u
.n
= fmt
->value
;
680 tail
->repeat
= repeat
;
684 t
= format_lex (fmt
);
687 fmt
->saved_token
= t
;
688 fmt
->value
= -1; /* Width not present */
691 get_fnode (fmt
, &head
, &tail
, FMT_A
);
692 tail
->repeat
= repeat
;
693 tail
->u
.n
= fmt
->value
;
702 get_fnode (fmt
, &head
, &tail
, t
);
703 tail
->repeat
= repeat
;
705 u
= format_lex (fmt
);
706 if (t
== FMT_F
|| dtp
->u
.p
.mode
== WRITING
)
708 if (u
!= FMT_POSINT
&& u
!= FMT_ZERO
)
710 fmt
->error
= nonneg_required
;
718 fmt
->error
= posint_required
;
723 tail
->u
.real
.w
= fmt
->value
;
725 t
= format_lex (fmt
);
728 /* We treat a missing decimal descriptor as 0. Note: This is only
729 allowed if -std=legacy, otherwise an error occurs. */
730 if (compile_options
.warn_std
!= 0)
732 fmt
->error
= period_required
;
735 fmt
->saved_token
= t
;
740 t
= format_lex (fmt
);
741 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
743 fmt
->error
= nonneg_required
;
747 tail
->u
.real
.d
= fmt
->value
;
749 if (t
== FMT_D
|| t
== FMT_F
)
754 /* Look for optional exponent */
755 t
= format_lex (fmt
);
757 fmt
->saved_token
= t
;
760 t
= format_lex (fmt
);
763 fmt
->error
= "Positive exponent width required in format";
767 tail
->u
.real
.e
= fmt
->value
;
773 if (repeat
> fmt
->format_string_len
)
775 fmt
->error
= bad_hollerith
;
779 get_fnode (fmt
, &head
, &tail
, FMT_STRING
);
781 tail
->u
.string
.p
= fmt
->format_string
;
782 tail
->u
.string
.length
= repeat
;
785 fmt
->format_string
+= fmt
->value
;
786 fmt
->format_string_len
-= repeat
;
794 get_fnode (fmt
, &head
, &tail
, t
);
795 tail
->repeat
= repeat
;
797 t
= format_lex (fmt
);
799 if (dtp
->u
.p
.mode
== READING
)
803 fmt
->error
= posint_required
;
809 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
811 fmt
->error
= nonneg_required
;
816 tail
->u
.integer
.w
= fmt
->value
;
817 tail
->u
.integer
.m
= -1;
819 t
= format_lex (fmt
);
822 fmt
->saved_token
= t
;
826 t
= format_lex (fmt
);
827 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
829 fmt
->error
= nonneg_required
;
833 tail
->u
.integer
.m
= fmt
->value
;
836 if (tail
->u
.integer
.w
!= 0 && tail
->u
.integer
.m
> tail
->u
.integer
.w
)
838 fmt
->error
= "Minimum digits exceeds field width";
845 fmt
->error
= unexpected_element
;
849 /* Between a descriptor and what comes next */
851 t
= format_lex (fmt
);
861 get_fnode (fmt
, &head
, &tail
, FMT_SLASH
);
870 fmt
->error
= unexpected_end
;
874 /* Assume a missing comma, this is a GNU extension */
878 /* Optional comma is a weird between state where we've just finished
879 reading a colon, slash or P descriptor. */
881 t
= format_lex (fmt
);
890 default: /* Assume that we have another format item */
891 fmt
->saved_token
= t
;
902 /* format_error()-- Generate an error message for a format statement.
903 * If the node that gives the location of the error is NULL, the error
904 * is assumed to happen at parse time, and the current location of the
907 * We generate a message showing where the problem is. We take extra
908 * care to print only the relevant part of the format if it is longer
909 * than a standard 80 column display. */
912 format_error (st_parameter_dt
*dtp
, const fnode
*f
, const char *message
)
914 int width
, i
, j
, offset
;
915 char *p
, buffer
[300];
916 format_data
*fmt
= dtp
->u
.p
.fmt
;
919 fmt
->format_string
= f
->source
;
921 st_sprintf (buffer
, "%s\n", message
);
923 j
= fmt
->format_string
- dtp
->format
;
925 offset
= (j
> 60) ? j
- 40 : 0;
928 width
= dtp
->format_len
- offset
;
933 /* Show the format */
935 p
= strchr (buffer
, '\0');
937 memcpy (p
, dtp
->format
+ offset
, width
);
942 /* Show where the problem is */
944 for (i
= 1; i
< j
; i
++)
950 generate_error (&dtp
->common
, ERROR_FORMAT
, buffer
);
954 /* parse_format()-- Parse a format string. */
957 parse_format (st_parameter_dt
*dtp
)
961 dtp
->u
.p
.fmt
= fmt
= get_mem (sizeof (format_data
));
962 fmt
->format_string
= dtp
->format
;
963 fmt
->format_string_len
= dtp
->format_len
;
966 fmt
->saved_token
= FMT_NONE
;
970 /* Initialize variables used during traversal of the tree */
972 fmt
->reversion_ok
= 0;
973 fmt
->saved_format
= NULL
;
975 /* Allocate the first format node as the root of the tree */
977 fmt
->last
= &fmt
->array
;
978 fmt
->last
->next
= NULL
;
979 fmt
->avail
= &fmt
->array
.array
[0];
981 memset (fmt
->avail
, 0, sizeof (*fmt
->avail
));
982 fmt
->avail
->format
= FMT_LPAREN
;
983 fmt
->avail
->repeat
= 1;
986 if (format_lex (fmt
) == FMT_LPAREN
)
987 fmt
->array
.array
[0].u
.child
= parse_format_list (dtp
);
989 fmt
->error
= "Missing initial left parenthesis in format";
992 format_error (dtp
, NULL
, fmt
->error
);
996 /* revert()-- Do reversion of the format. Control reverts to the left
997 * parenthesis that matches the rightmost right parenthesis. From our
998 * tree structure, we are looking for the rightmost parenthesis node
999 * at the second level, the first level always being a single
1000 * parenthesis node. If this node doesn't exit, we use the top
1004 revert (st_parameter_dt
*dtp
)
1007 format_data
*fmt
= dtp
->u
.p
.fmt
;
1009 dtp
->u
.p
.reversion_flag
= 1;
1013 for (f
= fmt
->array
.array
[0].u
.child
; f
; f
= f
->next
)
1014 if (f
->format
== FMT_LPAREN
)
1017 /* If r is NULL because no node was found, the whole tree will be used */
1019 fmt
->array
.array
[0].current
= r
;
1020 fmt
->array
.array
[0].count
= 0;
1024 /* next_format0()-- Get the next format node without worrying about
1025 * reversion. Returns NULL when we hit the end of the list.
1026 * Parenthesis nodes are incremented after the list has been
1027 * exhausted, other nodes are incremented before they are returned. */
1029 static const fnode
*
1030 next_format0 (fnode
* f
)
1037 if (f
->format
!= FMT_LPAREN
)
1040 if (f
->count
<= f
->repeat
)
1047 /* Deal with a parenthesis node */
1049 for (; f
->count
< f
->repeat
; f
->count
++)
1051 if (f
->current
== NULL
)
1052 f
->current
= f
->u
.child
;
1054 for (; f
->current
!= NULL
; f
->current
= f
->current
->next
)
1056 r
= next_format0 (f
->current
);
1067 /* next_format()-- Return the next format node. If the format list
1068 * ends up being exhausted, we do reversion. Reversion is only
1069 * allowed if the we've seen a data descriptor since the
1070 * initialization or the last reversion. We return NULL if there
1071 * are no more data descriptors to return (which is an error
1075 next_format (st_parameter_dt
*dtp
)
1079 format_data
*fmt
= dtp
->u
.p
.fmt
;
1081 if (fmt
->saved_format
!= NULL
)
1082 { /* Deal with a pushed-back format node */
1083 f
= fmt
->saved_format
;
1084 fmt
->saved_format
= NULL
;
1088 f
= next_format0 (&fmt
->array
.array
[0]);
1091 if (!fmt
->reversion_ok
)
1094 fmt
->reversion_ok
= 0;
1097 f
= next_format0 (&fmt
->array
.array
[0]);
1100 format_error (dtp
, NULL
, reversion_error
);
1104 /* Push the first reverted token and return a colon node in case
1105 * there are no more data items. */
1107 fmt
->saved_format
= f
;
1111 /* If this is a data edit descriptor, then reversion has become OK. */
1115 if (!fmt
->reversion_ok
&&
1116 (t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
|| t
== FMT_Z
|| t
== FMT_F
||
1117 t
== FMT_E
|| t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
|| t
== FMT_L
||
1118 t
== FMT_A
|| t
== FMT_D
))
1119 fmt
->reversion_ok
= 1;
1124 /* unget_format()-- Push the given format back so that it will be
1125 * returned on the next call to next_format() without affecting
1126 * counts. This is necessary when we've encountered a data
1127 * descriptor, but don't know what the data item is yet. The format
1128 * node is pushed back, and we return control to the main program,
1129 * which calls the library back with the data item (or not). */
1132 unget_format (st_parameter_dt
*dtp
, const fnode
*f
)
1134 dtp
->u
.p
.fmt
->saved_format
= f
;