Mercurial > hg > CbC > CbC_gcc

comparison gcc/fortran/arith.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 /* Compiler arithmetic 1 /* Compiler arithmetic
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
111 break; 111 break;
112 case ARITH_ASYMMETRIC: 112 case ARITH_ASYMMETRIC:
113 p = 113 p =
114 _("Integer outside symmetric range implied by Standard Fortran at %L"); 114 _("Integer outside symmetric range implied by Standard Fortran at %L");
115 break; 115 break;
116 case ARITH_WRONGCONCAT:
117 p =
118 _("Illegal type in character concatenation at %L");
119 break;
120
116 default: 121 default:
117 gfc_internal_error ("gfc_arith_error(): Bad error code"); 122 gfc_internal_error ("gfc_arith_error(): Bad error code");
118 } 123 }
119 124
120 return p; 125 return p;
553 { 558 {
554 gfc_warning (0, gfc_arith_error (val), &x->where); 559 gfc_warning (0, gfc_arith_error (val), &x->where);
555 val = ARITH_OK; 560 val = ARITH_OK;
556 } 561 }
557 562
558 if (val != ARITH_OK) 563 if (val == ARITH_OK || val == ARITH_OVERFLOW)
564 *rp = r;
565 else
559 gfc_free_expr (r); 566 gfc_free_expr (r);
560 else
561 *rp = r;
562 567
563 return val; 568 return val;
564 } 569 }
565 570
566 571
978 983
979 static arith 984 static arith
980 gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) 985 gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
981 { 986 {
982 gfc_expr *result; 987 gfc_expr *result;
983 int len; 988 size_t len;
984 989
985 gcc_assert (op1->ts.kind == op2->ts.kind); 990 /* By cleverly playing around with constructors, is is possible
991 to get mismaching types here. */
992 if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
993 || op1->ts.kind != op2->ts.kind)
994 return ARITH_WRONGCONCAT;
995
986 result = gfc_get_constant_expr (BT_CHARACTER, op1->ts.kind, 996 result = gfc_get_constant_expr (BT_CHARACTER, op1->ts.kind,
987 &op1->where); 997 &op1->where);
988 998
989 len = op1->value.character.length + op2->value.character.length; 999 len = op1->value.character.length + op2->value.character.length;
990 1000
1087 We use the processor's default collating sequence. */ 1097 We use the processor's default collating sequence. */
1088 1098
1089 int 1099 int
1090 gfc_compare_string (gfc_expr *a, gfc_expr *b) 1100 gfc_compare_string (gfc_expr *a, gfc_expr *b)
1091 { 1101 {
1092 int len, alen, blen, i; 1102 size_t len, alen, blen, i;
1093 gfc_char_t ac, bc; 1103 gfc_char_t ac, bc;
1094 1104
1095 alen = a->value.character.length; 1105 alen = a->value.character.length;
1096 blen = b->value.character.length; 1106 blen = b->value.character.length;
1097 1107
1114 1124
1115 1125
1116 int 1126 int
1117 gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive) 1127 gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
1118 { 1128 {
1119 int len, alen, blen, i; 1129 size_t len, alen, blen, i;
1120 gfc_char_t ac, bc; 1130 gfc_char_t ac, bc;
1121 1131
1122 alen = a->value.character.length; 1132 alen = a->value.character.length;
1123 blen = strlen (b); 1133 blen = strlen (b);
1124 1134
1601 return NULL; 1611 return NULL;
1602 1612
1603 if (rc != ARITH_OK) 1613 if (rc != ARITH_OK)
1604 { 1614 {
1605 gfc_error (gfc_arith_error (rc), &op1->where); 1615 gfc_error (gfc_arith_error (rc), &op1->where);
1616 if (rc == ARITH_OVERFLOW)
1617 goto done;
1606 return NULL; 1618 return NULL;
1607 } 1619 }
1620
1621 done:
1608 1622
1609 gfc_free_expr (op1); 1623 gfc_free_expr (op1);
1610 gfc_free_expr (op2); 1624 gfc_free_expr (op2);
1611 return result; 1625 return result;
1612 1626
2512 result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0); 2526 result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
2513 2527
2514 return result; 2528 return result;
2515 } 2529 }
2516 2530
2531 /* Convert character to character. We only use wide strings internally,
2532 so we only set the kind. */
2533
2534 gfc_expr *
2535 gfc_character2character (gfc_expr *src, int kind)
2536 {
2537 gfc_expr *result;
2538 result = gfc_copy_expr (src);
2539 result->ts.kind = kind;
2540
2541 return result;
2542 }
2517 2543
2518 /* Helper function to set the representation in a Hollerith conversion. 2544 /* Helper function to set the representation in a Hollerith conversion.
2519 This assumes that the ts.type and ts.kind of the result have already 2545 This assumes that the ts.type and ts.kind of the result have already
2520 been set. */ 2546 been set. */
2521 2547
2602 gfc_expr *result; 2628 gfc_expr *result;
2603 2629
2604 result = gfc_copy_expr (src); 2630 result = gfc_copy_expr (src);
2605 result->ts.type = BT_CHARACTER; 2631 result->ts.type = BT_CHARACTER;
2606 result->ts.kind = kind; 2632 result->ts.kind = kind;
2633 result->ts.u.pad = 0;
2607 2634
2608 result->value.character.length = result->representation.length; 2635 result->value.character.length = result->representation.length;
2609 result->value.character.string 2636 result->value.character.string
2610 = gfc_char_to_widechar (result->representation.string); 2637 = gfc_char_to_widechar (result->representation.string);
2611 2638