diff options
Diffstat (limited to 'gcc/fortran/check.c')
| -rw-r--r-- | gcc/fortran/check.c | 156 |
1 files changed, 156 insertions, 0 deletions
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index bf81e9f..bc757ff 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -632,6 +632,33 @@ gfc_check_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind) try +gfc_check_complex (gfc_expr * x, gfc_expr * y) +{ + if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL) + { + gfc_error ( + "'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL", + gfc_current_intrinsic_arg[0], gfc_current_intrinsic, &x->where); + return FAILURE; + } + if (scalar_check (x, 0) == FAILURE) + return FAILURE; + + if (y->ts.type != BT_INTEGER && y->ts.type != BT_REAL) + { + gfc_error ( + "'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL", + gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &y->where); + return FAILURE; + } + if (scalar_check (y, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try gfc_check_count (gfc_expr * mask, gfc_expr * dim) { if (logical_array_check (mask, 0) == FAILURE) @@ -2003,6 +2030,64 @@ gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies) } +/* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and + functions). */ +try +gfc_check_fgetputc_sub (gfc_expr * unit, gfc_expr * c, gfc_expr * status) +{ + if (type_check (unit, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (unit, 0) == FAILURE) + return FAILURE; + + if (type_check (c, 1, BT_CHARACTER) == FAILURE) + return FAILURE; + + if (status == NULL) + return SUCCESS; + + if (type_check (status, 2, BT_INTEGER) == FAILURE + || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE + || scalar_check (status, 2) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_fgetputc (gfc_expr * unit, gfc_expr * c) +{ + return gfc_check_fgetputc_sub (unit, c, NULL); +} + + +try +gfc_check_fgetput_sub (gfc_expr * c, gfc_expr * status) +{ + if (type_check (c, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + + if (status == NULL) + return SUCCESS; + + if (type_check (status, 1, BT_INTEGER) == FAILURE + || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE + || scalar_check (status, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_fgetput (gfc_expr * c) +{ + return gfc_check_fgetput_sub (c, NULL); +} + + try gfc_check_fstat (gfc_expr * unit, gfc_expr * array) { @@ -2054,6 +2139,38 @@ gfc_check_fstat_sub (gfc_expr * unit, gfc_expr * array, gfc_expr * status) try +gfc_check_ftell (gfc_expr * unit) +{ + if (type_check (unit, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (unit, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_ftell_sub (gfc_expr * unit, gfc_expr * offset) +{ + if (type_check (unit, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (unit, 0) == FAILURE) + return FAILURE; + + if (type_check (offset, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (offset, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try gfc_check_stat (gfc_expr * name, gfc_expr * array) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) @@ -2922,3 +3039,42 @@ gfc_check_system_sub (gfc_expr * cmd, gfc_expr * status) return SUCCESS; } + + +/* This is used for the GNU intrinsics AND, OR and XOR. */ +try +gfc_check_and (gfc_expr * i, gfc_expr * j) +{ + if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL) + { + gfc_error ( + "'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL", + gfc_current_intrinsic_arg[0], gfc_current_intrinsic, &i->where); + return FAILURE; + } + + if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL) + { + gfc_error ( + "'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL", + gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &j->where); + return FAILURE; + } + + if (i->ts.type != j->ts.type) + { + gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must " + "have the same type", gfc_current_intrinsic_arg[0], + gfc_current_intrinsic_arg[1], gfc_current_intrinsic, + &j->where); + return FAILURE; + } + + if (scalar_check (i, 0) == FAILURE) + return FAILURE; + + if (scalar_check (j, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} |