Mercurial > hg > CbC > CbC_gcc

comparison gcc/fortran/io.c @ 131:84e7813d76e9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc-8.2
author mir3636
date Thu, 25 Oct 2018 07:37:49 +0900
parents 04ced10e8804
children 1830386684a0
comparison
equal deleted inserted replaced
111:04ced10e8804 131:84e7813d76e9
1 /* Deal with I/O statements & related stuff. 1 /* Deal with I/O statements & related stuff.
2 Copyright (C) 2000-2017 Free Software Foundation, Inc. 2 Copyright (C) 2000-2018 Free Software Foundation, Inc.
3 Contributed by Andy Vaught 3 Contributed by Andy Vaught
4 4
5 This file is part of GCC. 5 This file is part of GCC.
6 6
7 GCC is free software; you can redistribute it and/or modify it under 7 GCC is free software; you can redistribute it and/or modify it under
23 #include "coretypes.h" 23 #include "coretypes.h"
24 #include "options.h" 24 #include "options.h"
25 #include "gfortran.h" 25 #include "gfortran.h"
26 #include "match.h" 26 #include "match.h"
27 #include "parse.h" 27 #include "parse.h"
28 #include "constructor.h"
28 29
29 gfc_st_label 30 gfc_st_label
30 format_asterisk = {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL, 31 format_asterisk = {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL,
31 0, {NULL, NULL}, NULL}; 32 0, {NULL, NULL}, NULL};
32 33
983 goto between_desc; 984 goto between_desc;
984 985
985 case FMT_COMMA: 986 case FMT_COMMA:
986 goto format_item; 987 goto format_item;
987 988
989 case FMT_COLON:
990 goto format_item_1;
991
988 case FMT_LPAREN: 992 case FMT_LPAREN:
989 993
990 dtio_vlist: 994 dtio_vlist:
991 t = format_lex (); 995 t = format_lex ();
992 if (t == FMT_ERROR) 996 if (t == FMT_ERROR)
1601 1605
1602 1606
1603 /* Resolution of the FORMAT tag, to be called from resolve_tag. */ 1607 /* Resolution of the FORMAT tag, to be called from resolve_tag. */
1604 1608
1605 static bool 1609 static bool
1606 resolve_tag_format (const gfc_expr *e) 1610 resolve_tag_format (gfc_expr *e)
1607 { 1611 {
1608 if (e->expr_type == EXPR_CONSTANT 1612 if (e->expr_type == EXPR_CONSTANT
1609 && (e->ts.type != BT_CHARACTER 1613 && (e->ts.type != BT_CHARACTER
1610 || e->ts.kind != gfc_default_character_kind)) 1614 || e->ts.kind != gfc_default_character_kind))
1611 { 1615 {
1612 gfc_error ("Constant expression in FORMAT tag at %L must be " 1616 gfc_error ("Constant expression in FORMAT tag at %L must be "
1613 "of type default CHARACTER", &e->where); 1617 "of type default CHARACTER", &e->where);
1614 return false; 1618 return false;
1619 }
1620
1621 /* Concatenate a constant character array into a single character
1622 expression. */
1623
1624 if ((e->expr_type == EXPR_ARRAY || e->rank > 0)
1625 && e->ts.type == BT_CHARACTER
1626 && gfc_is_constant_expr (e))
1627 {
1628 if (e->expr_type == EXPR_VARIABLE
1629 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
1630 gfc_simplify_expr (e, 1);
1631
1632 if (e->expr_type == EXPR_ARRAY)
1633 {
1634 gfc_constructor *c;
1635 gfc_charlen_t n, len;
1636 gfc_expr *r;
1637 gfc_char_t *dest, *src;
1638
1639 n = 0;
1640 c = gfc_constructor_first (e->value.constructor);
1641 len = c->expr->value.character.length;
1642
1643 for ( ; c; c = gfc_constructor_next (c))
1644 n += len;
1645
1646 r = gfc_get_character_expr (e->ts.kind, &e->where, NULL, n);
1647 dest = r->value.character.string;
1648
1649 for (c = gfc_constructor_first (e->value.constructor);
1650 c; c = gfc_constructor_next (c))
1651 {
1652 src = c->expr->value.character.string;
1653 for (gfc_charlen_t i = 0 ; i < len; i++)
1654 *dest++ = *src++;
1655 }
1656
1657 gfc_replace_expr (e, r);
1658 return true;
1659 }
1615 } 1660 }
1616 1661
1617 /* If e's rank is zero and e is not an element of an array, it should be 1662 /* If e's rank is zero and e is not an element of an array, it should be
1618 of integer or character type. The integer variable should be 1663 of integer or character type. The integer variable should be
1619 ASSIGNED. */ 1664 ASSIGNED. */
4244 goto cleanup; 4289 goto cleanup;
4245 if (m == MATCH_NO) 4290 if (m == MATCH_NO)
4246 goto syntax; 4291 goto syntax;
4247 } 4292 }
4248 4293
4249 /* See if we want to use defaults for missing exponents in real transfers. */ 4294 /* See if we want to use defaults for missing exponents in real transfers
4295 and other DEC runtime extensions. */
4250 if (flag_dec) 4296 if (flag_dec)
4251 dt->default_exp = 1; 4297 dt->dec_ext = 1;
4252 4298
4253 /* A full IO statement has been matched. Check the constraints. spec_end is 4299 /* A full IO statement has been matched. Check the constraints. spec_end is
4254 supplied for cases where no locus is supplied. */ 4300 supplied for cases where no locus is supplied. */
4255 m = check_io_constraints (k, dt, io_code, &spec_end); 4301 m = check_io_constraints (k, dt, io_code, &spec_end);
4256 4302