]>
gcc.gnu.org Git - gcc.git/blob - libgfortran/io/format.c
1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
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 */
39 #define FARRAY_SIZE 64
41 typedef struct fnode_array
43 struct fnode_array
*next
;
44 fnode array
[FARRAY_SIZE
];
48 typedef struct format_data
50 char *format_string
, *string
;
52 format_token saved_token
;
53 int value
, format_string_len
, reversion_ok
;
55 const fnode
*saved_format
;
61 static const fnode colon_node
= { FMT_COLON
, 0, NULL
, NULL
, {{ 0, 0, 0 }}, 0,
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 in format",
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";
76 /* next_char()-- Return the next character in the format string.
77 * Returns -1 when the string is done. If the literal flag is set,
78 * spaces are significant, otherwise they are not. */
81 next_char (format_data
*fmt
, int literal
)
87 if (fmt
->format_string_len
== 0)
90 fmt
->format_string_len
--;
91 c
= toupper (*fmt
->format_string
++);
93 while ((c
== ' ' || c
== '\t') && !literal
);
99 /* unget_char()-- Back up one character position. */
101 #define unget_char(fmt) \
102 { fmt->format_string--; fmt->format_string_len++; }
105 /* get_fnode()-- Allocate a new format node, inserting it into the
106 * current singly linked list. These are initially allocated from the
110 get_fnode (format_data
*fmt
, fnode
**head
, fnode
**tail
, format_token t
)
114 if (fmt
->avail
== &fmt
->last
->array
[FARRAY_SIZE
])
116 fmt
->last
->next
= get_mem (sizeof (fnode_array
));
117 fmt
->last
= fmt
->last
->next
;
118 fmt
->last
->next
= NULL
;
119 fmt
->avail
= &fmt
->last
->array
[0];
122 memset (f
, '\0', sizeof (fnode
));
134 f
->source
= fmt
->format_string
;
139 /* free_format_data()-- Free all allocated format data. */
142 free_format_data (st_parameter_dt
*dtp
)
144 fnode_array
*fa
, *fa_next
;
145 format_data
*fmt
= dtp
->u
.p
.fmt
;
150 for (fa
= fmt
->array
.next
; fa
; fa
= fa_next
)
161 /* format_lex()-- Simple lexical analyzer for getting the next token
162 * in a FORMAT string. We support a one-level token pushback in the
163 * fmt->saved_token variable. */
166 format_lex (format_data
*fmt
)
173 if (fmt
->saved_token
!= FMT_NONE
)
175 token
= fmt
->saved_token
;
176 fmt
->saved_token
= FMT_NONE
;
181 c
= next_char (fmt
, 0);
190 c
= next_char (fmt
, 0);
197 fmt
->value
= c
- '0';
201 c
= next_char (fmt
, 0);
205 fmt
->value
= 10 * fmt
->value
+ c
- '0';
211 fmt
->value
= -fmt
->value
;
212 token
= FMT_SIGNED_INT
;
225 fmt
->value
= c
- '0';
229 c
= next_char (fmt
, 0);
233 fmt
->value
= 10 * fmt
->value
+ c
- '0';
237 token
= (fmt
->value
== 0) ? FMT_ZERO
: FMT_POSINT
;
261 switch (next_char (fmt
, 0))
290 switch (next_char (fmt
, 0))
307 switch (next_char (fmt
, 0))
327 fmt
->string
= fmt
->format_string
;
328 fmt
->value
= 0; /* This is the length of the string */
332 c
= next_char (fmt
, 1);
335 token
= FMT_BADSTRING
;
336 fmt
->error
= bad_string
;
342 c
= next_char (fmt
, 1);
346 token
= FMT_BADSTRING
;
347 fmt
->error
= bad_string
;
385 switch (next_char (fmt
, 0))
434 /* parse_format_list()-- Parse a format list. Assumes that a left
435 * paren has already been seen. Returns a list representing the
436 * parenthesis node which contains the rest of the list. */
439 parse_format_list (st_parameter_dt
*dtp
)
442 format_token t
, u
, t2
;
444 format_data
*fmt
= dtp
->u
.p
.fmt
;
448 /* Get the next format item */
450 t
= format_lex (fmt
);
457 t
= format_lex (fmt
);
461 get_fnode (fmt
, &head
, &tail
, FMT_LPAREN
);
462 tail
->repeat
= repeat
;
463 tail
->u
.child
= parse_format_list (dtp
);
464 if (fmt
->error
!= NULL
)
470 get_fnode (fmt
, &head
, &tail
, FMT_SLASH
);
471 tail
->repeat
= repeat
;
475 get_fnode (fmt
, &head
, &tail
, FMT_X
);
477 tail
->u
.k
= fmt
->value
;
488 get_fnode (fmt
, &head
, &tail
, FMT_LPAREN
);
490 tail
->u
.child
= parse_format_list (dtp
);
491 if (fmt
->error
!= NULL
)
496 case FMT_SIGNED_INT
: /* Signed integer can only precede a P format. */
497 case FMT_ZERO
: /* Same for zero. */
498 t
= format_lex (fmt
);
501 fmt
->error
= "Expected P edit descriptor in format";
506 get_fnode (fmt
, &head
, &tail
, FMT_P
);
507 tail
->u
.k
= fmt
->value
;
510 t
= format_lex (fmt
);
511 if (t
== FMT_F
|| t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_D
512 || t
== FMT_G
|| t
== FMT_E
)
518 fmt
->saved_token
= t
;
521 case FMT_P
: /* P and X require a prior number */
522 fmt
->error
= "P descriptor requires leading scale factor";
529 If we would be pedantic in the library, we would have to reject
530 an X descriptor without an integer prefix:
532 fmt->error = "X descriptor requires leading space count";
535 However, this is an extension supported by many Fortran compilers,
536 including Cray, HP, AIX, and IRIX. Therefore, we allow it in the
537 runtime library, and make the front end reject it if the compiler
538 is in pedantic mode. The interpretation of 'X' is '1X'.
540 get_fnode (fmt
, &head
, &tail
, FMT_X
);
546 get_fnode (fmt
, &head
, &tail
, FMT_STRING
);
548 tail
->u
.string
.p
= fmt
->string
;
549 tail
->u
.string
.length
= fmt
->value
;
558 get_fnode (fmt
, &head
, &tail
, t
);
563 get_fnode (fmt
, &head
, &tail
, FMT_COLON
);
568 get_fnode (fmt
, &head
, &tail
, FMT_SLASH
);
574 get_fnode (fmt
, &head
, &tail
, FMT_DOLLAR
);
576 notify_std (&dtp
->common
, GFC_STD_GNU
, "Extension: $ descriptor");
582 t2
= format_lex (fmt
);
583 if (t2
!= FMT_POSINT
)
585 fmt
->error
= posint_required
;
588 get_fnode (fmt
, &head
, &tail
, t
);
589 tail
->u
.n
= fmt
->value
;
609 get_fnode (fmt
, &head
, &tail
, FMT_STRING
);
611 if (fmt
->format_string_len
< 1)
613 fmt
->error
= bad_hollerith
;
617 tail
->u
.string
.p
= fmt
->format_string
;
618 tail
->u
.string
.length
= 1;
621 fmt
->format_string
++;
622 fmt
->format_string_len
--;
627 fmt
->error
= unexpected_end
;
637 fmt
->error
= unexpected_element
;
641 /* In this state, t must currently be a data descriptor. Deal with
642 things that can/must follow the descriptor */
647 t
= format_lex (fmt
);
650 fmt
->error
= "Repeat count cannot follow P descriptor";
654 fmt
->saved_token
= t
;
655 get_fnode (fmt
, &head
, &tail
, FMT_P
);
660 t
= format_lex (fmt
);
663 if (notification_std(GFC_STD_GNU
) == ERROR
)
665 fmt
->error
= posint_required
;
670 fmt
->saved_token
= t
;
671 fmt
->value
= 1; /* Default width */
672 notify_std (&dtp
->common
, GFC_STD_GNU
, posint_required
);
676 get_fnode (fmt
, &head
, &tail
, FMT_L
);
677 tail
->u
.n
= fmt
->value
;
678 tail
->repeat
= repeat
;
682 t
= format_lex (fmt
);
685 fmt
->saved_token
= t
;
686 fmt
->value
= -1; /* Width not present */
689 get_fnode (fmt
, &head
, &tail
, FMT_A
);
690 tail
->repeat
= repeat
;
691 tail
->u
.n
= fmt
->value
;
700 get_fnode (fmt
, &head
, &tail
, t
);
701 tail
->repeat
= repeat
;
703 u
= format_lex (fmt
);
704 if (t
== FMT_F
|| dtp
->u
.p
.mode
== WRITING
)
706 if (u
!= FMT_POSINT
&& u
!= FMT_ZERO
)
708 fmt
->error
= nonneg_required
;
716 fmt
->error
= posint_required
;
721 tail
->u
.real
.w
= fmt
->value
;
723 t
= format_lex (fmt
);
726 /* We treat a missing decimal descriptor as 0. Note: This is only
727 allowed if -std=legacy, otherwise an error occurs. */
728 if (compile_options
.warn_std
!= 0)
730 fmt
->error
= period_required
;
733 fmt
->saved_token
= t
;
738 t
= format_lex (fmt
);
739 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
741 fmt
->error
= nonneg_required
;
745 tail
->u
.real
.d
= fmt
->value
;
747 if (t
== FMT_D
|| t
== FMT_F
)
752 /* Look for optional exponent */
753 t
= format_lex (fmt
);
755 fmt
->saved_token
= t
;
758 t
= format_lex (fmt
);
761 fmt
->error
= "Positive exponent width required in format";
765 tail
->u
.real
.e
= fmt
->value
;
771 if (repeat
> fmt
->format_string_len
)
773 fmt
->error
= bad_hollerith
;
777 get_fnode (fmt
, &head
, &tail
, FMT_STRING
);
779 tail
->u
.string
.p
= fmt
->format_string
;
780 tail
->u
.string
.length
= repeat
;
783 fmt
->format_string
+= fmt
->value
;
784 fmt
->format_string_len
-= repeat
;
792 get_fnode (fmt
, &head
, &tail
, t
);
793 tail
->repeat
= repeat
;
795 t
= format_lex (fmt
);
797 if (dtp
->u
.p
.mode
== READING
)
801 fmt
->error
= posint_required
;
807 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
809 fmt
->error
= nonneg_required
;
814 tail
->u
.integer
.w
= fmt
->value
;
815 tail
->u
.integer
.m
= -1;
817 t
= format_lex (fmt
);
820 fmt
->saved_token
= t
;
824 t
= format_lex (fmt
);
825 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
827 fmt
->error
= nonneg_required
;
831 tail
->u
.integer
.m
= fmt
->value
;
834 if (tail
->u
.integer
.w
!= 0 && tail
->u
.integer
.m
> tail
->u
.integer
.w
)
836 fmt
->error
= "Minimum digits exceeds field width";
843 fmt
->error
= unexpected_element
;
847 /* Between a descriptor and what comes next */
849 t
= format_lex (fmt
);
860 get_fnode (fmt
, &head
, &tail
, t
);
865 fmt
->error
= unexpected_end
;
869 /* Assume a missing comma, this is a GNU extension */
873 /* Optional comma is a weird between state where we've just finished
874 reading a colon, slash or P descriptor. */
876 t
= format_lex (fmt
);
885 default: /* Assume that we have another format item */
886 fmt
->saved_token
= t
;
897 /* format_error()-- Generate an error message for a format statement.
898 * If the node that gives the location of the error is NULL, the error
899 * is assumed to happen at parse time, and the current location of the
902 * We generate a message showing where the problem is. We take extra
903 * care to print only the relevant part of the format if it is longer
904 * than a standard 80 column display. */
907 format_error (st_parameter_dt
*dtp
, const fnode
*f
, const char *message
)
909 int width
, i
, j
, offset
;
910 char *p
, buffer
[300];
911 format_data
*fmt
= dtp
->u
.p
.fmt
;
914 fmt
->format_string
= f
->source
;
916 sprintf (buffer
, "%s\n", message
);
918 j
= fmt
->format_string
- dtp
->format
;
920 offset
= (j
> 60) ? j
- 40 : 0;
923 width
= dtp
->format_len
- offset
;
928 /* Show the format */
930 p
= strchr (buffer
, '\0');
932 memcpy (p
, dtp
->format
+ offset
, width
);
937 /* Show where the problem is */
939 for (i
= 1; i
< j
; i
++)
945 generate_error (&dtp
->common
, LIBERROR_FORMAT
, buffer
);
949 /* parse_format()-- Parse a format string. */
952 parse_format (st_parameter_dt
*dtp
)
956 dtp
->u
.p
.fmt
= fmt
= get_mem (sizeof (format_data
));
957 fmt
->format_string
= dtp
->format
;
958 fmt
->format_string_len
= dtp
->format_len
;
961 fmt
->saved_token
= FMT_NONE
;
965 /* Initialize variables used during traversal of the tree */
967 fmt
->reversion_ok
= 0;
968 fmt
->saved_format
= NULL
;
970 /* Allocate the first format node as the root of the tree */
972 fmt
->last
= &fmt
->array
;
973 fmt
->last
->next
= NULL
;
974 fmt
->avail
= &fmt
->array
.array
[0];
976 memset (fmt
->avail
, 0, sizeof (*fmt
->avail
));
977 fmt
->avail
->format
= FMT_LPAREN
;
978 fmt
->avail
->repeat
= 1;
981 if (format_lex (fmt
) == FMT_LPAREN
)
982 fmt
->array
.array
[0].u
.child
= parse_format_list (dtp
);
984 fmt
->error
= "Missing initial left parenthesis in format";
987 format_error (dtp
, NULL
, fmt
->error
);
991 /* revert()-- Do reversion of the format. Control reverts to the left
992 * parenthesis that matches the rightmost right parenthesis. From our
993 * tree structure, we are looking for the rightmost parenthesis node
994 * at the second level, the first level always being a single
995 * parenthesis node. If this node doesn't exit, we use the top
999 revert (st_parameter_dt
*dtp
)
1002 format_data
*fmt
= dtp
->u
.p
.fmt
;
1004 dtp
->u
.p
.reversion_flag
= 1;
1008 for (f
= fmt
->array
.array
[0].u
.child
; f
; f
= f
->next
)
1009 if (f
->format
== FMT_LPAREN
)
1012 /* If r is NULL because no node was found, the whole tree will be used */
1014 fmt
->array
.array
[0].current
= r
;
1015 fmt
->array
.array
[0].count
= 0;
1019 /* next_format0()-- Get the next format node without worrying about
1020 * reversion. Returns NULL when we hit the end of the list.
1021 * Parenthesis nodes are incremented after the list has been
1022 * exhausted, other nodes are incremented before they are returned. */
1024 static const fnode
*
1025 next_format0 (fnode
* f
)
1032 if (f
->format
!= FMT_LPAREN
)
1035 if (f
->count
<= f
->repeat
)
1042 /* Deal with a parenthesis node */
1044 for (; f
->count
< f
->repeat
; f
->count
++)
1046 if (f
->current
== NULL
)
1047 f
->current
= f
->u
.child
;
1049 for (; f
->current
!= NULL
; f
->current
= f
->current
->next
)
1051 r
= next_format0 (f
->current
);
1062 /* next_format()-- Return the next format node. If the format list
1063 * ends up being exhausted, we do reversion. Reversion is only
1064 * allowed if the we've seen a data descriptor since the
1065 * initialization or the last reversion. We return NULL if there
1066 * are no more data descriptors to return (which is an error
1070 next_format (st_parameter_dt
*dtp
)
1074 format_data
*fmt
= dtp
->u
.p
.fmt
;
1076 if (fmt
->saved_format
!= NULL
)
1077 { /* Deal with a pushed-back format node */
1078 f
= fmt
->saved_format
;
1079 fmt
->saved_format
= NULL
;
1083 f
= next_format0 (&fmt
->array
.array
[0]);
1086 if (!fmt
->reversion_ok
)
1089 fmt
->reversion_ok
= 0;
1092 f
= next_format0 (&fmt
->array
.array
[0]);
1095 format_error (dtp
, NULL
, reversion_error
);
1099 /* Push the first reverted token and return a colon node in case
1100 * there are no more data items. */
1102 fmt
->saved_format
= f
;
1106 /* If this is a data edit descriptor, then reversion has become OK. */
1110 if (!fmt
->reversion_ok
&&
1111 (t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
|| t
== FMT_Z
|| t
== FMT_F
||
1112 t
== FMT_E
|| t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
|| t
== FMT_L
||
1113 t
== FMT_A
|| t
== FMT_D
))
1114 fmt
->reversion_ok
= 1;
1119 /* unget_format()-- Push the given format back so that it will be
1120 * returned on the next call to next_format() without affecting
1121 * counts. This is necessary when we've encountered a data
1122 * descriptor, but don't know what the data item is yet. The format
1123 * node is pushed back, and we return control to the main program,
1124 * which calls the library back with the data item (or not). */
1127 unget_format (st_parameter_dt
*dtp
, const fnode
*f
)
1129 dtp
->u
.p
.fmt
->saved_format
= f
;
This page took 0.503717 seconds and 5 git commands to generate.