Skip to content
Projects
Groups
Snippets
Help
This project
Loading...
Sign in / Register
Toggle navigation
R
riscv-gcc-1
Overview
Overview
Details
Activity
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
0
Issues
0
List
Board
Labels
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
lvzhengyang
riscv-gcc-1
Commits
74e3459c
Commit
74e3459c
authored
Jan 06, 2007
by
Steven G. Kargl
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
arith.c: Update copyright years.
* arith.c: Update copyright years. Whitespace. From-SVN: r120530
parent
2f82a97b
Show whitespace changes
Inline
Side-by-side
Showing
2 changed files
with
96 additions
and
107 deletions
+96
-107
gcc/fortran/ChangeLog
+4
-0
gcc/fortran/arith.c
+92
-107
No files found.
gcc/fortran/ChangeLog
View file @
74e3459c
2007-01-05 Steven G. Kargl <kargl@gcc.gnu.org>
* arith.c: Update copyright years. Whitespace.
2007-01-05 Roger Sayle <roger@eyesopen.com>
2007-01-05 Roger Sayle <roger@eyesopen.com>
* trans-expr.c (gfc_trans_assignment_1): New subroutine to scalarize
* trans-expr.c (gfc_trans_assignment_1): New subroutine to scalarize
...
...
gcc/fortran/arith.c
View file @
74e3459c
/* Compiler arithmetic
/* Compiler arithmetic
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
, 2007
Free Software Foundation, Inc.
Free Software Foundation, Inc.
Contributed by Andy Vaught
Contributed by Andy Vaught
...
@@ -398,13 +398,12 @@ gfc_check_real_range (mpfr_t p, int kind)
...
@@ -398,13 +398,12 @@ gfc_check_real_range (mpfr_t p, int kind)
/* Function to return a constant expression node of a given type and kind. */
/* Function to return a constant expression node of a given type and kind. */
gfc_expr
*
gfc_expr
*
gfc_constant_result
(
bt
type
,
int
kind
,
locus
*
where
)
gfc_constant_result
(
bt
type
,
int
kind
,
locus
*
where
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
if
(
!
where
)
if
(
!
where
)
gfc_internal_error
gfc_internal_error
(
"gfc_constant_result(): locus 'where' cannot be NULL"
);
(
"gfc_constant_result(): locus 'where' cannot be NULL"
);
result
=
gfc_get_expr
();
result
=
gfc_get_expr
();
...
@@ -445,7 +444,7 @@ gfc_constant_result (bt type, int kind, locus * where)
...
@@ -445,7 +444,7 @@ gfc_constant_result (bt type, int kind, locus * where)
zero raised to the zero, etc. */
zero raised to the zero, etc. */
static
arith
static
arith
gfc_arith_not
(
gfc_expr
*
op1
,
gfc_expr
**
resultp
)
gfc_arith_not
(
gfc_expr
*
op1
,
gfc_expr
**
resultp
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
...
@@ -458,7 +457,7 @@ gfc_arith_not (gfc_expr * op1, gfc_expr ** resultp)
...
@@ -458,7 +457,7 @@ gfc_arith_not (gfc_expr * op1, gfc_expr ** resultp)
static
arith
static
arith
gfc_arith_and
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
gfc_arith_and
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
...
@@ -472,7 +471,7 @@ gfc_arith_and (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
...
@@ -472,7 +471,7 @@ gfc_arith_and (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
static
arith
static
arith
gfc_arith_or
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
gfc_arith_or
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
...
@@ -486,7 +485,7 @@ gfc_arith_or (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
...
@@ -486,7 +485,7 @@ gfc_arith_or (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
static
arith
static
arith
gfc_arith_eqv
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
gfc_arith_eqv
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
...
@@ -500,7 +499,7 @@ gfc_arith_eqv (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
...
@@ -500,7 +499,7 @@ gfc_arith_eqv (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
static
arith
static
arith
gfc_arith_neqv
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
gfc_arith_neqv
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
...
@@ -518,7 +517,7 @@ gfc_arith_neqv (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
...
@@ -518,7 +517,7 @@ gfc_arith_neqv (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
but that one deals with the intrinsic RANGE function. */
but that one deals with the intrinsic RANGE function. */
arith
arith
gfc_range_check
(
gfc_expr
*
e
)
gfc_range_check
(
gfc_expr
*
e
)
{
{
arith
rc
;
arith
rc
;
...
@@ -568,7 +567,7 @@ gfc_range_check (gfc_expr * e)
...
@@ -568,7 +567,7 @@ gfc_range_check (gfc_expr * e)
check the validity of the result. Encapsulate the checking here. */
check the validity of the result. Encapsulate the checking here. */
static
arith
static
arith
check_result
(
arith
rc
,
gfc_expr
*
x
,
gfc_expr
*
r
,
gfc_expr
**
rp
)
check_result
(
arith
rc
,
gfc_expr
*
x
,
gfc_expr
*
r
,
gfc_expr
**
rp
)
{
{
arith
val
=
rc
;
arith
val
=
rc
;
...
@@ -599,7 +598,7 @@ check_result (arith rc, gfc_expr * x, gfc_expr * r, gfc_expr ** rp)
...
@@ -599,7 +598,7 @@ check_result (arith rc, gfc_expr * x, gfc_expr * r, gfc_expr ** rp)
in the code elsewhere. */
in the code elsewhere. */
static
arith
static
arith
gfc_arith_uplus
(
gfc_expr
*
op1
,
gfc_expr
**
resultp
)
gfc_arith_uplus
(
gfc_expr
*
op1
,
gfc_expr
**
resultp
)
{
{
*
resultp
=
gfc_copy_expr
(
op1
);
*
resultp
=
gfc_copy_expr
(
op1
);
return
ARITH_OK
;
return
ARITH_OK
;
...
@@ -607,7 +606,7 @@ gfc_arith_uplus (gfc_expr * op1, gfc_expr ** resultp)
...
@@ -607,7 +606,7 @@ gfc_arith_uplus (gfc_expr * op1, gfc_expr ** resultp)
static
arith
static
arith
gfc_arith_uminus
(
gfc_expr
*
op1
,
gfc_expr
**
resultp
)
gfc_arith_uminus
(
gfc_expr
*
op1
,
gfc_expr
**
resultp
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
arith
rc
;
arith
rc
;
...
@@ -640,7 +639,7 @@ gfc_arith_uminus (gfc_expr * op1, gfc_expr ** resultp)
...
@@ -640,7 +639,7 @@ gfc_arith_uminus (gfc_expr * op1, gfc_expr ** resultp)
static
arith
static
arith
gfc_arith_plus
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
gfc_arith_plus
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
arith
rc
;
arith
rc
;
...
@@ -677,7 +676,7 @@ gfc_arith_plus (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
...
@@ -677,7 +676,7 @@ gfc_arith_plus (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
static
arith
static
arith
gfc_arith_minus
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
gfc_arith_minus
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
arith
rc
;
arith
rc
;
...
@@ -714,7 +713,7 @@ gfc_arith_minus (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
...
@@ -714,7 +713,7 @@ gfc_arith_minus (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
static
arith
static
arith
gfc_arith_times
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
gfc_arith_times
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
mpfr_t
x
,
y
;
mpfr_t
x
,
y
;
...
@@ -761,7 +760,7 @@ gfc_arith_times (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
...
@@ -761,7 +760,7 @@ gfc_arith_times (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
static
arith
static
arith
gfc_arith_divide
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
gfc_arith_divide
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
mpfr_t
x
,
y
,
div
;
mpfr_t
x
,
y
,
div
;
...
@@ -785,8 +784,7 @@ gfc_arith_divide (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
...
@@ -785,8 +784,7 @@ gfc_arith_divide (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
break
;
break
;
case
BT_REAL
:
case
BT_REAL
:
if
(
mpfr_sgn
(
op2
->
value
.
real
)
==
0
if
(
mpfr_sgn
(
op2
->
value
.
real
)
==
0
&&
gfc_option
.
flag_range_check
==
1
)
&&
gfc_option
.
flag_range_check
==
1
)
{
{
rc
=
ARITH_DIV0
;
rc
=
ARITH_DIV0
;
break
;
break
;
...
@@ -845,7 +843,7 @@ gfc_arith_divide (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
...
@@ -845,7 +843,7 @@ gfc_arith_divide (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
/* Compute the reciprocal of a complex number (guaranteed nonzero). */
/* Compute the reciprocal of a complex number (guaranteed nonzero). */
static
void
static
void
complex_reciprocal
(
gfc_expr
*
op
)
complex_reciprocal
(
gfc_expr
*
op
)
{
{
mpfr_t
mod
,
a
,
re
,
im
;
mpfr_t
mod
,
a
,
re
,
im
;
...
@@ -877,7 +875,7 @@ complex_reciprocal (gfc_expr * op)
...
@@ -877,7 +875,7 @@ complex_reciprocal (gfc_expr * op)
/* Raise a complex number to positive power. */
/* Raise a complex number to positive power. */
static
void
static
void
complex_pow_ui
(
gfc_expr
*
base
,
int
power
,
gfc_expr
*
result
)
complex_pow_ui
(
gfc_expr
*
base
,
int
power
,
gfc_expr
*
result
)
{
{
mpfr_t
re
,
im
,
a
;
mpfr_t
re
,
im
,
a
;
...
@@ -916,7 +914,7 @@ complex_pow_ui (gfc_expr * base, int power, gfc_expr * result)
...
@@ -916,7 +914,7 @@ complex_pow_ui (gfc_expr * base, int power, gfc_expr * result)
/* Raise a number to an integer power. */
/* Raise a number to an integer power. */
static
arith
static
arith
gfc_arith_power
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
gfc_arith_power
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
{
{
int
power
,
apower
;
int
power
,
apower
;
gfc_expr
*
result
;
gfc_expr
*
result
;
...
@@ -1011,7 +1009,7 @@ gfc_arith_power (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
...
@@ -1011,7 +1009,7 @@ gfc_arith_power (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
/* Concatenate two string constants. */
/* Concatenate two string constants. */
static
arith
static
arith
gfc_arith_concat
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
gfc_arith_concat
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
int
len
;
int
len
;
...
@@ -1042,7 +1040,7 @@ gfc_arith_concat (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
...
@@ -1042,7 +1040,7 @@ gfc_arith_concat (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
contain two constants of the same type. */
contain two constants of the same type. */
int
int
gfc_compare_expr
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
gfc_compare_expr
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
{
{
int
rc
;
int
rc
;
...
@@ -1077,7 +1075,7 @@ gfc_compare_expr (gfc_expr * op1, gfc_expr * op2)
...
@@ -1077,7 +1075,7 @@ gfc_compare_expr (gfc_expr * op1, gfc_expr * op2)
equality and nonequality. */
equality and nonequality. */
static
int
static
int
compare_complex
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
compare_complex
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
{
{
return
(
mpfr_cmp
(
op1
->
value
.
complex
.
r
,
op2
->
value
.
complex
.
r
)
==
0
return
(
mpfr_cmp
(
op1
->
value
.
complex
.
r
,
op2
->
value
.
complex
.
r
)
==
0
&&
mpfr_cmp
(
op1
->
value
.
complex
.
i
,
op2
->
value
.
complex
.
i
)
==
0
);
&&
mpfr_cmp
(
op1
->
value
.
complex
.
i
,
op2
->
value
.
complex
.
i
)
==
0
);
...
@@ -1089,7 +1087,7 @@ compare_complex (gfc_expr * op1, gfc_expr * op2)
...
@@ -1089,7 +1087,7 @@ compare_complex (gfc_expr * op1, gfc_expr * op2)
xcoll_table is NULL, we use the processor's default collating sequence. */
xcoll_table is NULL, we use the processor's default collating sequence. */
int
int
gfc_compare_string
(
gfc_expr
*
a
,
gfc_expr
*
b
,
const
int
*
xcoll_table
)
gfc_compare_string
(
gfc_expr
*
a
,
gfc_expr
*
b
,
const
int
*
xcoll_table
)
{
{
int
len
,
alen
,
blen
,
i
,
ac
,
bc
;
int
len
,
alen
,
blen
,
i
,
ac
,
bc
;
...
@@ -1126,14 +1124,15 @@ gfc_compare_string (gfc_expr * a, gfc_expr * b, const int * xcoll_table)
...
@@ -1126,14 +1124,15 @@ gfc_compare_string (gfc_expr * a, gfc_expr * b, const int * xcoll_table)
/* Specific comparison subroutines. */
/* Specific comparison subroutines. */
static
arith
static
arith
gfc_arith_eq
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
gfc_arith_eq
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
result
=
gfc_constant_result
(
BT_LOGICAL
,
gfc_default_logical_kind
,
result
=
gfc_constant_result
(
BT_LOGICAL
,
gfc_default_logical_kind
,
&
op1
->
where
);
&
op1
->
where
);
result
->
value
.
logical
=
(
op1
->
ts
.
type
==
BT_COMPLEX
)
?
result
->
value
.
logical
=
(
op1
->
ts
.
type
==
BT_COMPLEX
)
compare_complex
(
op1
,
op2
)
:
(
gfc_compare_expr
(
op1
,
op2
)
==
0
);
?
compare_complex
(
op1
,
op2
)
:
(
gfc_compare_expr
(
op1
,
op2
)
==
0
);
*
resultp
=
result
;
*
resultp
=
result
;
return
ARITH_OK
;
return
ARITH_OK
;
...
@@ -1141,14 +1140,15 @@ gfc_arith_eq (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
...
@@ -1141,14 +1140,15 @@ gfc_arith_eq (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
static
arith
static
arith
gfc_arith_ne
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
gfc_arith_ne
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
result
=
gfc_constant_result
(
BT_LOGICAL
,
gfc_default_logical_kind
,
result
=
gfc_constant_result
(
BT_LOGICAL
,
gfc_default_logical_kind
,
&
op1
->
where
);
&
op1
->
where
);
result
->
value
.
logical
=
(
op1
->
ts
.
type
==
BT_COMPLEX
)
?
result
->
value
.
logical
=
(
op1
->
ts
.
type
==
BT_COMPLEX
)
!
compare_complex
(
op1
,
op2
)
:
(
gfc_compare_expr
(
op1
,
op2
)
!=
0
);
?
!
compare_complex
(
op1
,
op2
)
:
(
gfc_compare_expr
(
op1
,
op2
)
!=
0
);
*
resultp
=
result
;
*
resultp
=
result
;
return
ARITH_OK
;
return
ARITH_OK
;
...
@@ -1156,7 +1156,7 @@ gfc_arith_ne (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
...
@@ -1156,7 +1156,7 @@ gfc_arith_ne (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
static
arith
static
arith
gfc_arith_gt
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
gfc_arith_gt
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
...
@@ -1170,7 +1170,7 @@ gfc_arith_gt (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
...
@@ -1170,7 +1170,7 @@ gfc_arith_gt (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
static
arith
static
arith
gfc_arith_ge
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
gfc_arith_ge
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
...
@@ -1184,7 +1184,7 @@ gfc_arith_ge (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
...
@@ -1184,7 +1184,7 @@ gfc_arith_ge (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
static
arith
static
arith
gfc_arith_lt
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
gfc_arith_lt
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
...
@@ -1198,7 +1198,7 @@ gfc_arith_lt (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
...
@@ -1198,7 +1198,7 @@ gfc_arith_lt (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
static
arith
static
arith
gfc_arith_le
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
gfc_arith_le
(
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
resultp
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
...
@@ -1212,8 +1212,8 @@ gfc_arith_le (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
...
@@ -1212,8 +1212,8 @@ gfc_arith_le (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
static
arith
static
arith
reduce_unary
(
arith
(
*
eval
)
(
gfc_expr
*
,
gfc_expr
**
),
gfc_expr
*
op
,
reduce_unary
(
arith
(
*
eval
)
(
gfc_expr
*
,
gfc_expr
**
),
gfc_expr
*
op
,
gfc_expr
**
result
)
gfc_expr
**
result
)
{
{
gfc_constructor
*
c
,
*
head
;
gfc_constructor
*
c
,
*
head
;
gfc_expr
*
r
;
gfc_expr
*
r
;
...
@@ -1256,8 +1256,7 @@ reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr * op,
...
@@ -1256,8 +1256,7 @@ reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr * op,
static
arith
static
arith
reduce_binary_ac
(
arith
(
*
eval
)
(
gfc_expr
*
,
gfc_expr
*
,
gfc_expr
**
),
reduce_binary_ac
(
arith
(
*
eval
)
(
gfc_expr
*
,
gfc_expr
*
,
gfc_expr
**
),
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
result
)
gfc_expr
**
result
)
{
{
gfc_constructor
*
c
,
*
head
;
gfc_constructor
*
c
,
*
head
;
gfc_expr
*
r
;
gfc_expr
*
r
;
...
@@ -1297,8 +1296,7 @@ reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
...
@@ -1297,8 +1296,7 @@ reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
static
arith
static
arith
reduce_binary_ca
(
arith
(
*
eval
)
(
gfc_expr
*
,
gfc_expr
*
,
gfc_expr
**
),
reduce_binary_ca
(
arith
(
*
eval
)
(
gfc_expr
*
,
gfc_expr
*
,
gfc_expr
**
),
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
result
)
gfc_expr
**
result
)
{
{
gfc_constructor
*
c
,
*
head
;
gfc_constructor
*
c
,
*
head
;
gfc_expr
*
r
;
gfc_expr
*
r
;
...
@@ -1338,8 +1336,7 @@ reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
...
@@ -1338,8 +1336,7 @@ reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
static
arith
static
arith
reduce_binary_aa
(
arith
(
*
eval
)
(
gfc_expr
*
,
gfc_expr
*
,
gfc_expr
**
),
reduce_binary_aa
(
arith
(
*
eval
)
(
gfc_expr
*
,
gfc_expr
*
,
gfc_expr
**
),
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
result
)
gfc_expr
**
result
)
{
{
gfc_constructor
*
c
,
*
d
,
*
head
;
gfc_constructor
*
c
,
*
d
,
*
head
;
gfc_expr
*
r
;
gfc_expr
*
r
;
...
@@ -1355,7 +1352,6 @@ reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
...
@@ -1355,7 +1352,6 @@ reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
rc
=
ARITH_INCOMMENSURATE
;
rc
=
ARITH_INCOMMENSURATE
;
else
else
{
{
for
(
c
=
head
;
c
;
c
=
c
->
next
,
d
=
d
->
next
)
for
(
c
=
head
;
c
;
c
=
c
->
next
,
d
=
d
->
next
)
{
{
if
(
d
==
NULL
)
if
(
d
==
NULL
)
...
@@ -1397,8 +1393,7 @@ reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
...
@@ -1397,8 +1393,7 @@ reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
static
arith
static
arith
reduce_binary
(
arith
(
*
eval
)
(
gfc_expr
*
,
gfc_expr
*
,
gfc_expr
**
),
reduce_binary
(
arith
(
*
eval
)
(
gfc_expr
*
,
gfc_expr
*
,
gfc_expr
**
),
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
*
op1
,
gfc_expr
*
op2
,
gfc_expr
**
result
)
gfc_expr
**
result
)
{
{
if
(
op1
->
expr_type
==
EXPR_CONSTANT
&&
op2
->
expr_type
==
EXPR_CONSTANT
)
if
(
op1
->
expr_type
==
EXPR_CONSTANT
&&
op2
->
expr_type
==
EXPR_CONSTANT
)
return
eval
(
op1
,
op2
,
result
);
return
eval
(
op1
,
op2
,
result
);
...
@@ -1432,7 +1427,7 @@ eval_f;
...
@@ -1432,7 +1427,7 @@ eval_f;
static
gfc_expr
*
static
gfc_expr
*
eval_intrinsic
(
gfc_intrinsic_op
operator
,
eval_intrinsic
(
gfc_intrinsic_op
operator
,
eval_f
eval
,
gfc_expr
*
op1
,
gfc_expr
*
op2
)
eval_f
eval
,
gfc_expr
*
op1
,
gfc_expr
*
op2
)
{
{
gfc_expr
temp
,
*
result
;
gfc_expr
temp
,
*
result
;
int
unary
;
int
unary
;
...
@@ -1449,7 +1444,6 @@ eval_intrinsic (gfc_intrinsic_op operator,
...
@@ -1449,7 +1444,6 @@ eval_intrinsic (gfc_intrinsic_op operator,
temp
.
ts
.
type
=
BT_LOGICAL
;
temp
.
ts
.
type
=
BT_LOGICAL
;
temp
.
ts
.
kind
=
gfc_default_logical_kind
;
temp
.
ts
.
kind
=
gfc_default_logical_kind
;
unary
=
1
;
unary
=
1
;
break
;
break
;
...
@@ -1463,7 +1457,6 @@ eval_intrinsic (gfc_intrinsic_op operator,
...
@@ -1463,7 +1457,6 @@ eval_intrinsic (gfc_intrinsic_op operator,
temp
.
ts
.
type
=
BT_LOGICAL
;
temp
.
ts
.
type
=
BT_LOGICAL
;
temp
.
ts
.
kind
=
gfc_default_logical_kind
;
temp
.
ts
.
kind
=
gfc_default_logical_kind
;
unary
=
0
;
unary
=
0
;
break
;
break
;
...
@@ -1474,13 +1467,11 @@ eval_intrinsic (gfc_intrinsic_op operator,
...
@@ -1474,13 +1467,11 @@ eval_intrinsic (gfc_intrinsic_op operator,
goto
runtime
;
goto
runtime
;
temp
.
ts
=
op1
->
ts
;
temp
.
ts
=
op1
->
ts
;
unary
=
1
;
unary
=
1
;
break
;
break
;
case
INTRINSIC_PARENTHESES
:
case
INTRINSIC_PARENTHESES
:
temp
.
ts
=
op1
->
ts
;
temp
.
ts
=
op1
->
ts
;
unary
=
1
;
unary
=
1
;
break
;
break
;
...
@@ -1547,7 +1538,6 @@ eval_intrinsic (gfc_intrinsic_op operator,
...
@@ -1547,7 +1538,6 @@ eval_intrinsic (gfc_intrinsic_op operator,
temp
.
ts
.
type
=
BT_CHARACTER
;
temp
.
ts
.
type
=
BT_CHARACTER
;
temp
.
ts
.
kind
=
gfc_default_character_kind
;
temp
.
ts
.
kind
=
gfc_default_character_kind
;
unary
=
0
;
unary
=
0
;
break
;
break
;
...
@@ -1565,16 +1555,14 @@ eval_intrinsic (gfc_intrinsic_op operator,
...
@@ -1565,16 +1555,14 @@ eval_intrinsic (gfc_intrinsic_op operator,
if
(
op1
->
from_H
if
(
op1
->
from_H
||
(
op1
->
expr_type
!=
EXPR_CONSTANT
||
(
op1
->
expr_type
!=
EXPR_CONSTANT
&&
(
op1
->
expr_type
!=
EXPR_ARRAY
&&
(
op1
->
expr_type
!=
EXPR_ARRAY
||
!
gfc_is_constant_expr
(
op1
)
||
!
gfc_is_constant_expr
(
op1
)
||
!
gfc_expanded_ac
(
op1
))))
||
!
gfc_expanded_ac
(
op1
))))
goto
runtime
;
goto
runtime
;
if
(
op2
!=
NULL
if
(
op2
!=
NULL
&&
(
op2
->
from_H
&&
(
op2
->
from_H
||
(
op2
->
expr_type
!=
EXPR_CONSTANT
||
(
op2
->
expr_type
!=
EXPR_CONSTANT
&&
(
op2
->
expr_type
!=
EXPR_ARRAY
&&
(
op2
->
expr_type
!=
EXPR_ARRAY
||
!
gfc_is_constant_expr
(
op2
)
||
!
gfc_is_constant_expr
(
op2
)
||
!
gfc_expanded_ac
(
op2
)))))
||
!
gfc_expanded_ac
(
op2
)))))
goto
runtime
;
goto
runtime
;
if
(
unary
)
if
(
unary
)
...
@@ -1612,7 +1600,7 @@ runtime:
...
@@ -1612,7 +1600,7 @@ runtime:
/* Modify type of expression for zero size array. */
/* Modify type of expression for zero size array. */
static
gfc_expr
*
static
gfc_expr
*
eval_type_intrinsic0
(
gfc_intrinsic_op
operator
,
gfc_expr
*
op
)
eval_type_intrinsic0
(
gfc_intrinsic_op
operator
,
gfc_expr
*
op
)
{
{
if
(
op
==
NULL
)
if
(
op
==
NULL
)
gfc_internal_error
(
"eval_type_intrinsic0(): op NULL"
);
gfc_internal_error
(
"eval_type_intrinsic0(): op NULL"
);
...
@@ -1640,7 +1628,7 @@ eval_type_intrinsic0 (gfc_intrinsic_op operator, gfc_expr * op)
...
@@ -1640,7 +1628,7 @@ eval_type_intrinsic0 (gfc_intrinsic_op operator, gfc_expr * op)
/* Return nonzero if the expression is a zero size array. */
/* Return nonzero if the expression is a zero size array. */
static
int
static
int
gfc_zero_size_array
(
gfc_expr
*
e
)
gfc_zero_size_array
(
gfc_expr
*
e
)
{
{
if
(
e
->
expr_type
!=
EXPR_ARRAY
)
if
(
e
->
expr_type
!=
EXPR_ARRAY
)
return
0
;
return
0
;
...
@@ -1654,7 +1642,7 @@ gfc_zero_size_array (gfc_expr * e)
...
@@ -1654,7 +1642,7 @@ gfc_zero_size_array (gfc_expr * e)
operands is a zero-length array. */
operands is a zero-length array. */
static
gfc_expr
*
static
gfc_expr
*
reduce_binary0
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
reduce_binary0
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
{
{
if
(
gfc_zero_size_array
(
op1
))
if
(
gfc_zero_size_array
(
op1
))
{
{
...
@@ -1675,7 +1663,7 @@ reduce_binary0 (gfc_expr * op1, gfc_expr * op2)
...
@@ -1675,7 +1663,7 @@ reduce_binary0 (gfc_expr * op1, gfc_expr * op2)
static
gfc_expr
*
static
gfc_expr
*
eval_intrinsic_f2
(
gfc_intrinsic_op
operator
,
eval_intrinsic_f2
(
gfc_intrinsic_op
operator
,
arith
(
*
eval
)
(
gfc_expr
*
,
gfc_expr
**
),
arith
(
*
eval
)
(
gfc_expr
*
,
gfc_expr
**
),
gfc_expr
*
op1
,
gfc_expr
*
op2
)
gfc_expr
*
op1
,
gfc_expr
*
op2
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
eval_f
f
;
eval_f
f
;
...
@@ -1700,7 +1688,7 @@ eval_intrinsic_f2 (gfc_intrinsic_op operator,
...
@@ -1700,7 +1688,7 @@ eval_intrinsic_f2 (gfc_intrinsic_op operator,
static
gfc_expr
*
static
gfc_expr
*
eval_intrinsic_f3
(
gfc_intrinsic_op
operator
,
eval_intrinsic_f3
(
gfc_intrinsic_op
operator
,
arith
(
*
eval
)
(
gfc_expr
*
,
gfc_expr
*
,
gfc_expr
**
),
arith
(
*
eval
)
(
gfc_expr
*
,
gfc_expr
*
,
gfc_expr
**
),
gfc_expr
*
op1
,
gfc_expr
*
op2
)
gfc_expr
*
op1
,
gfc_expr
*
op2
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
eval_f
f
;
eval_f
f
;
...
@@ -1715,133 +1703,133 @@ eval_intrinsic_f3 (gfc_intrinsic_op operator,
...
@@ -1715,133 +1703,133 @@ eval_intrinsic_f3 (gfc_intrinsic_op operator,
gfc_expr
*
gfc_expr
*
gfc_uplus
(
gfc_expr
*
op
)
gfc_uplus
(
gfc_expr
*
op
)
{
{
return
eval_intrinsic_f2
(
INTRINSIC_UPLUS
,
gfc_arith_uplus
,
op
,
NULL
);
return
eval_intrinsic_f2
(
INTRINSIC_UPLUS
,
gfc_arith_uplus
,
op
,
NULL
);
}
}
gfc_expr
*
gfc_expr
*
gfc_uminus
(
gfc_expr
*
op
)
gfc_uminus
(
gfc_expr
*
op
)
{
{
return
eval_intrinsic_f2
(
INTRINSIC_UMINUS
,
gfc_arith_uminus
,
op
,
NULL
);
return
eval_intrinsic_f2
(
INTRINSIC_UMINUS
,
gfc_arith_uminus
,
op
,
NULL
);
}
}
gfc_expr
*
gfc_expr
*
gfc_add
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
gfc_add
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
{
{
return
eval_intrinsic_f3
(
INTRINSIC_PLUS
,
gfc_arith_plus
,
op1
,
op2
);
return
eval_intrinsic_f3
(
INTRINSIC_PLUS
,
gfc_arith_plus
,
op1
,
op2
);
}
}
gfc_expr
*
gfc_expr
*
gfc_subtract
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
gfc_subtract
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
{
{
return
eval_intrinsic_f3
(
INTRINSIC_MINUS
,
gfc_arith_minus
,
op1
,
op2
);
return
eval_intrinsic_f3
(
INTRINSIC_MINUS
,
gfc_arith_minus
,
op1
,
op2
);
}
}
gfc_expr
*
gfc_expr
*
gfc_multiply
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
gfc_multiply
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
{
{
return
eval_intrinsic_f3
(
INTRINSIC_TIMES
,
gfc_arith_times
,
op1
,
op2
);
return
eval_intrinsic_f3
(
INTRINSIC_TIMES
,
gfc_arith_times
,
op1
,
op2
);
}
}
gfc_expr
*
gfc_expr
*
gfc_divide
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
gfc_divide
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
{
{
return
eval_intrinsic_f3
(
INTRINSIC_DIVIDE
,
gfc_arith_divide
,
op1
,
op2
);
return
eval_intrinsic_f3
(
INTRINSIC_DIVIDE
,
gfc_arith_divide
,
op1
,
op2
);
}
}
gfc_expr
*
gfc_expr
*
gfc_power
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
gfc_power
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
{
{
return
eval_intrinsic_f3
(
INTRINSIC_POWER
,
gfc_arith_power
,
op1
,
op2
);
return
eval_intrinsic_f3
(
INTRINSIC_POWER
,
gfc_arith_power
,
op1
,
op2
);
}
}
gfc_expr
*
gfc_expr
*
gfc_concat
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
gfc_concat
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
{
{
return
eval_intrinsic_f3
(
INTRINSIC_CONCAT
,
gfc_arith_concat
,
op1
,
op2
);
return
eval_intrinsic_f3
(
INTRINSIC_CONCAT
,
gfc_arith_concat
,
op1
,
op2
);
}
}
gfc_expr
*
gfc_expr
*
gfc_and
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
gfc_and
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
{
{
return
eval_intrinsic_f3
(
INTRINSIC_AND
,
gfc_arith_and
,
op1
,
op2
);
return
eval_intrinsic_f3
(
INTRINSIC_AND
,
gfc_arith_and
,
op1
,
op2
);
}
}
gfc_expr
*
gfc_expr
*
gfc_or
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
gfc_or
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
{
{
return
eval_intrinsic_f3
(
INTRINSIC_OR
,
gfc_arith_or
,
op1
,
op2
);
return
eval_intrinsic_f3
(
INTRINSIC_OR
,
gfc_arith_or
,
op1
,
op2
);
}
}
gfc_expr
*
gfc_expr
*
gfc_not
(
gfc_expr
*
op1
)
gfc_not
(
gfc_expr
*
op1
)
{
{
return
eval_intrinsic_f2
(
INTRINSIC_NOT
,
gfc_arith_not
,
op1
,
NULL
);
return
eval_intrinsic_f2
(
INTRINSIC_NOT
,
gfc_arith_not
,
op1
,
NULL
);
}
}
gfc_expr
*
gfc_expr
*
gfc_eqv
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
gfc_eqv
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
{
{
return
eval_intrinsic_f3
(
INTRINSIC_EQV
,
gfc_arith_eqv
,
op1
,
op2
);
return
eval_intrinsic_f3
(
INTRINSIC_EQV
,
gfc_arith_eqv
,
op1
,
op2
);
}
}
gfc_expr
*
gfc_expr
*
gfc_neqv
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
gfc_neqv
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
{
{
return
eval_intrinsic_f3
(
INTRINSIC_NEQV
,
gfc_arith_neqv
,
op1
,
op2
);
return
eval_intrinsic_f3
(
INTRINSIC_NEQV
,
gfc_arith_neqv
,
op1
,
op2
);
}
}
gfc_expr
*
gfc_expr
*
gfc_eq
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
gfc_eq
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
{
{
return
eval_intrinsic_f3
(
INTRINSIC_EQ
,
gfc_arith_eq
,
op1
,
op2
);
return
eval_intrinsic_f3
(
INTRINSIC_EQ
,
gfc_arith_eq
,
op1
,
op2
);
}
}
gfc_expr
*
gfc_expr
*
gfc_ne
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
gfc_ne
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
{
{
return
eval_intrinsic_f3
(
INTRINSIC_NE
,
gfc_arith_ne
,
op1
,
op2
);
return
eval_intrinsic_f3
(
INTRINSIC_NE
,
gfc_arith_ne
,
op1
,
op2
);
}
}
gfc_expr
*
gfc_expr
*
gfc_gt
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
gfc_gt
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
{
{
return
eval_intrinsic_f3
(
INTRINSIC_GT
,
gfc_arith_gt
,
op1
,
op2
);
return
eval_intrinsic_f3
(
INTRINSIC_GT
,
gfc_arith_gt
,
op1
,
op2
);
}
}
gfc_expr
*
gfc_expr
*
gfc_ge
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
gfc_ge
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
{
{
return
eval_intrinsic_f3
(
INTRINSIC_GE
,
gfc_arith_ge
,
op1
,
op2
);
return
eval_intrinsic_f3
(
INTRINSIC_GE
,
gfc_arith_ge
,
op1
,
op2
);
}
}
gfc_expr
*
gfc_expr
*
gfc_lt
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
gfc_lt
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
{
{
return
eval_intrinsic_f3
(
INTRINSIC_LT
,
gfc_arith_lt
,
op1
,
op2
);
return
eval_intrinsic_f3
(
INTRINSIC_LT
,
gfc_arith_lt
,
op1
,
op2
);
}
}
gfc_expr
*
gfc_expr
*
gfc_le
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
gfc_le
(
gfc_expr
*
op1
,
gfc_expr
*
op2
)
{
{
return
eval_intrinsic_f3
(
INTRINSIC_LE
,
gfc_arith_le
,
op1
,
op2
);
return
eval_intrinsic_f3
(
INTRINSIC_LE
,
gfc_arith_le
,
op1
,
op2
);
}
}
...
@@ -1850,7 +1838,7 @@ gfc_le (gfc_expr * op1, gfc_expr * op2)
...
@@ -1850,7 +1838,7 @@ gfc_le (gfc_expr * op1, gfc_expr * op2)
/* Convert an integer string to an expression node. */
/* Convert an integer string to an expression node. */
gfc_expr
*
gfc_expr
*
gfc_convert_integer
(
const
char
*
buffer
,
int
kind
,
int
radix
,
locus
*
where
)
gfc_convert_integer
(
const
char
*
buffer
,
int
kind
,
int
radix
,
locus
*
where
)
{
{
gfc_expr
*
e
;
gfc_expr
*
e
;
const
char
*
t
;
const
char
*
t
;
...
@@ -1870,7 +1858,7 @@ gfc_convert_integer (const char * buffer, int kind, int radix, locus * where)
...
@@ -1870,7 +1858,7 @@ gfc_convert_integer (const char * buffer, int kind, int radix, locus * where)
/* Convert a real string to an expression node. */
/* Convert a real string to an expression node. */
gfc_expr
*
gfc_expr
*
gfc_convert_real
(
const
char
*
buffer
,
int
kind
,
locus
*
where
)
gfc_convert_real
(
const
char
*
buffer
,
int
kind
,
locus
*
where
)
{
{
gfc_expr
*
e
;
gfc_expr
*
e
;
...
@@ -1885,7 +1873,7 @@ gfc_convert_real (const char * buffer, int kind, locus * where)
...
@@ -1885,7 +1873,7 @@ gfc_convert_real (const char * buffer, int kind, locus * where)
complex expression node. */
complex expression node. */
gfc_expr
*
gfc_expr
*
gfc_convert_complex
(
gfc_expr
*
real
,
gfc_expr
*
imag
,
int
kind
)
gfc_convert_complex
(
gfc_expr
*
real
,
gfc_expr
*
imag
,
int
kind
)
{
{
gfc_expr
*
e
;
gfc_expr
*
e
;
...
@@ -1903,7 +1891,7 @@ gfc_convert_complex (gfc_expr * real, gfc_expr * imag, int kind)
...
@@ -1903,7 +1891,7 @@ gfc_convert_complex (gfc_expr * real, gfc_expr * imag, int kind)
/* Deal with an arithmetic error. */
/* Deal with an arithmetic error. */
static
void
static
void
arith_error
(
arith
rc
,
gfc_typespec
*
from
,
gfc_typespec
*
to
,
locus
*
where
)
arith_error
(
arith
rc
,
gfc_typespec
*
from
,
gfc_typespec
*
to
,
locus
*
where
)
{
{
switch
(
rc
)
switch
(
rc
)
{
{
...
@@ -1948,7 +1936,7 @@ arith_error (arith rc, gfc_typespec * from, gfc_typespec * to, locus * where)
...
@@ -1948,7 +1936,7 @@ arith_error (arith rc, gfc_typespec * from, gfc_typespec * to, locus * where)
/* Convert integers to integers. */
/* Convert integers to integers. */
gfc_expr
*
gfc_expr
*
gfc_int2int
(
gfc_expr
*
src
,
int
kind
)
gfc_int2int
(
gfc_expr
*
src
,
int
kind
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
arith
rc
;
arith
rc
;
...
@@ -1957,8 +1945,7 @@ gfc_int2int (gfc_expr * src, int kind)
...
@@ -1957,8 +1945,7 @@ gfc_int2int (gfc_expr * src, int kind)
mpz_set
(
result
->
value
.
integer
,
src
->
value
.
integer
);
mpz_set
(
result
->
value
.
integer
,
src
->
value
.
integer
);
if
((
rc
=
gfc_check_integer_range
(
result
->
value
.
integer
,
kind
))
if
((
rc
=
gfc_check_integer_range
(
result
->
value
.
integer
,
kind
))
!=
ARITH_OK
)
!=
ARITH_OK
)
{
{
if
(
rc
==
ARITH_ASYMMETRIC
)
if
(
rc
==
ARITH_ASYMMETRIC
)
{
{
...
@@ -1979,7 +1966,7 @@ gfc_int2int (gfc_expr * src, int kind)
...
@@ -1979,7 +1966,7 @@ gfc_int2int (gfc_expr * src, int kind)
/* Convert integers to reals. */
/* Convert integers to reals. */
gfc_expr
*
gfc_expr
*
gfc_int2real
(
gfc_expr
*
src
,
int
kind
)
gfc_int2real
(
gfc_expr
*
src
,
int
kind
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
arith
rc
;
arith
rc
;
...
@@ -2002,7 +1989,7 @@ gfc_int2real (gfc_expr * src, int kind)
...
@@ -2002,7 +1989,7 @@ gfc_int2real (gfc_expr * src, int kind)
/* Convert default integer to default complex. */
/* Convert default integer to default complex. */
gfc_expr
*
gfc_expr
*
gfc_int2complex
(
gfc_expr
*
src
,
int
kind
)
gfc_int2complex
(
gfc_expr
*
src
,
int
kind
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
arith
rc
;
arith
rc
;
...
@@ -2026,7 +2013,7 @@ gfc_int2complex (gfc_expr * src, int kind)
...
@@ -2026,7 +2013,7 @@ gfc_int2complex (gfc_expr * src, int kind)
/* Convert default real to default integer. */
/* Convert default real to default integer. */
gfc_expr
*
gfc_expr
*
gfc_real2int
(
gfc_expr
*
src
,
int
kind
)
gfc_real2int
(
gfc_expr
*
src
,
int
kind
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
arith
rc
;
arith
rc
;
...
@@ -2035,8 +2022,7 @@ gfc_real2int (gfc_expr * src, int kind)
...
@@ -2035,8 +2022,7 @@ gfc_real2int (gfc_expr * src, int kind)
gfc_mpfr_to_mpz
(
result
->
value
.
integer
,
src
->
value
.
real
);
gfc_mpfr_to_mpz
(
result
->
value
.
integer
,
src
->
value
.
real
);
if
((
rc
=
gfc_check_integer_range
(
result
->
value
.
integer
,
kind
))
if
((
rc
=
gfc_check_integer_range
(
result
->
value
.
integer
,
kind
))
!=
ARITH_OK
)
!=
ARITH_OK
)
{
{
arith_error
(
rc
,
&
src
->
ts
,
&
result
->
ts
,
&
src
->
where
);
arith_error
(
rc
,
&
src
->
ts
,
&
result
->
ts
,
&
src
->
where
);
gfc_free_expr
(
result
);
gfc_free_expr
(
result
);
...
@@ -2050,7 +2036,7 @@ gfc_real2int (gfc_expr * src, int kind)
...
@@ -2050,7 +2036,7 @@ gfc_real2int (gfc_expr * src, int kind)
/* Convert real to real. */
/* Convert real to real. */
gfc_expr
*
gfc_expr
*
gfc_real2real
(
gfc_expr
*
src
,
int
kind
)
gfc_real2real
(
gfc_expr
*
src
,
int
kind
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
arith
rc
;
arith
rc
;
...
@@ -2081,7 +2067,7 @@ gfc_real2real (gfc_expr * src, int kind)
...
@@ -2081,7 +2067,7 @@ gfc_real2real (gfc_expr * src, int kind)
/* Convert real to complex. */
/* Convert real to complex. */
gfc_expr
*
gfc_expr
*
gfc_real2complex
(
gfc_expr
*
src
,
int
kind
)
gfc_real2complex
(
gfc_expr
*
src
,
int
kind
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
arith
rc
;
arith
rc
;
...
@@ -2113,7 +2099,7 @@ gfc_real2complex (gfc_expr * src, int kind)
...
@@ -2113,7 +2099,7 @@ gfc_real2complex (gfc_expr * src, int kind)
/* Convert complex to integer. */
/* Convert complex to integer. */
gfc_expr
*
gfc_expr
*
gfc_complex2int
(
gfc_expr
*
src
,
int
kind
)
gfc_complex2int
(
gfc_expr
*
src
,
int
kind
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
arith
rc
;
arith
rc
;
...
@@ -2122,8 +2108,7 @@ gfc_complex2int (gfc_expr * src, int kind)
...
@@ -2122,8 +2108,7 @@ gfc_complex2int (gfc_expr * src, int kind)
gfc_mpfr_to_mpz
(
result
->
value
.
integer
,
src
->
value
.
complex
.
r
);
gfc_mpfr_to_mpz
(
result
->
value
.
integer
,
src
->
value
.
complex
.
r
);
if
((
rc
=
gfc_check_integer_range
(
result
->
value
.
integer
,
kind
))
if
((
rc
=
gfc_check_integer_range
(
result
->
value
.
integer
,
kind
))
!=
ARITH_OK
)
!=
ARITH_OK
)
{
{
arith_error
(
rc
,
&
src
->
ts
,
&
result
->
ts
,
&
src
->
where
);
arith_error
(
rc
,
&
src
->
ts
,
&
result
->
ts
,
&
src
->
where
);
gfc_free_expr
(
result
);
gfc_free_expr
(
result
);
...
@@ -2137,7 +2122,7 @@ gfc_complex2int (gfc_expr * src, int kind)
...
@@ -2137,7 +2122,7 @@ gfc_complex2int (gfc_expr * src, int kind)
/* Convert complex to real. */
/* Convert complex to real. */
gfc_expr
*
gfc_expr
*
gfc_complex2real
(
gfc_expr
*
src
,
int
kind
)
gfc_complex2real
(
gfc_expr
*
src
,
int
kind
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
arith
rc
;
arith
rc
;
...
@@ -2168,7 +2153,7 @@ gfc_complex2real (gfc_expr * src, int kind)
...
@@ -2168,7 +2153,7 @@ gfc_complex2real (gfc_expr * src, int kind)
/* Convert complex to complex. */
/* Convert complex to complex. */
gfc_expr
*
gfc_expr
*
gfc_complex2complex
(
gfc_expr
*
src
,
int
kind
)
gfc_complex2complex
(
gfc_expr
*
src
,
int
kind
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
arith
rc
;
arith
rc
;
...
@@ -2215,7 +2200,7 @@ gfc_complex2complex (gfc_expr * src, int kind)
...
@@ -2215,7 +2200,7 @@ gfc_complex2complex (gfc_expr * src, int kind)
/* Logical kind conversion. */
/* Logical kind conversion. */
gfc_expr
*
gfc_expr
*
gfc_log2log
(
gfc_expr
*
src
,
int
kind
)
gfc_log2log
(
gfc_expr
*
src
,
int
kind
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
...
@@ -2257,7 +2242,7 @@ gfc_int2log (gfc_expr *src, int kind)
...
@@ -2257,7 +2242,7 @@ gfc_int2log (gfc_expr *src, int kind)
/* Convert Hollerith to integer. The constant will be padded or truncated. */
/* Convert Hollerith to integer. The constant will be padded or truncated. */
gfc_expr
*
gfc_expr
*
gfc_hollerith2int
(
gfc_expr
*
src
,
int
kind
)
gfc_hollerith2int
(
gfc_expr
*
src
,
int
kind
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
int
len
;
int
len
;
...
@@ -2293,7 +2278,7 @@ gfc_hollerith2int (gfc_expr * src, int kind)
...
@@ -2293,7 +2278,7 @@ gfc_hollerith2int (gfc_expr * src, int kind)
/* Convert Hollerith to real. The constant will be padded or truncated. */
/* Convert Hollerith to real. The constant will be padded or truncated. */
gfc_expr
*
gfc_expr
*
gfc_hollerith2real
(
gfc_expr
*
src
,
int
kind
)
gfc_hollerith2real
(
gfc_expr
*
src
,
int
kind
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
int
len
;
int
len
;
...
@@ -2329,7 +2314,7 @@ gfc_hollerith2real (gfc_expr * src, int kind)
...
@@ -2329,7 +2314,7 @@ gfc_hollerith2real (gfc_expr * src, int kind)
/* Convert Hollerith to complex. The constant will be padded or truncated. */
/* Convert Hollerith to complex. The constant will be padded or truncated. */
gfc_expr
*
gfc_expr
*
gfc_hollerith2complex
(
gfc_expr
*
src
,
int
kind
)
gfc_hollerith2complex
(
gfc_expr
*
src
,
int
kind
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
int
len
;
int
len
;
...
@@ -2367,7 +2352,7 @@ gfc_hollerith2complex (gfc_expr * src, int kind)
...
@@ -2367,7 +2352,7 @@ gfc_hollerith2complex (gfc_expr * src, int kind)
/* Convert Hollerith to character. */
/* Convert Hollerith to character. */
gfc_expr
*
gfc_expr
*
gfc_hollerith2character
(
gfc_expr
*
src
,
int
kind
)
gfc_hollerith2character
(
gfc_expr
*
src
,
int
kind
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
...
@@ -2383,7 +2368,7 @@ gfc_hollerith2character (gfc_expr * src, int kind)
...
@@ -2383,7 +2368,7 @@ gfc_hollerith2character (gfc_expr * src, int kind)
/* Convert Hollerith to logical. The constant will be padded or truncated. */
/* Convert Hollerith to logical. The constant will be padded or truncated. */
gfc_expr
*
gfc_expr
*
gfc_hollerith2logical
(
gfc_expr
*
src
,
int
kind
)
gfc_hollerith2logical
(
gfc_expr
*
src
,
int
kind
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
int
len
;
int
len
;
...
@@ -2426,7 +2411,7 @@ gfc_hollerith2logical (gfc_expr * src, int kind)
...
@@ -2426,7 +2411,7 @@ gfc_hollerith2logical (gfc_expr * src, int kind)
here if an initializer exceeds gfc_c_int_kind. */
here if an initializer exceeds gfc_c_int_kind. */
gfc_expr
*
gfc_expr
*
gfc_enum_initializer
(
gfc_expr
*
last_initializer
,
locus
where
)
gfc_enum_initializer
(
gfc_expr
*
last_initializer
,
locus
where
)
{
{
gfc_expr
*
result
;
gfc_expr
*
result
;
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment