| /* Routines for manipulation of expression nodes. |
| Copyright (C) 2000-2020 Free Software Foundation, Inc. |
| Contributed by Andy Vaught |
| |
| This file is part of GCC. |
| |
| GCC is free software; you can redistribute it and/or modify it under |
| the terms of the GNU General Public License as published by the Free |
| Software Foundation; either version 3, or (at your option) any later |
| version. |
| |
| GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
| WARRANTY; without even the implied warranty of MERCHANTABILITY or |
| FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
| for more details. |
| |
| You should have received a copy of the GNU General Public License |
| along with GCC; see the file COPYING3. If not see |
| <http://www.gnu.org/licenses/>. */ |
| |
| #include "config.h" |
| #include "system.h" |
| #include "coretypes.h" |
| #include "options.h" |
| #include "gfortran.h" |
| #include "arith.h" |
| #include "match.h" |
| #include "target-memory.h" /* for gfc_convert_boz */ |
| #include "constructor.h" |
| #include "tree.h" |
| |
| |
| /* The following set of functions provide access to gfc_expr* of |
| various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE. |
| |
| There are two functions available elsewhere that provide |
| slightly different flavours of variables. Namely: |
| expr.c (gfc_get_variable_expr) |
| symbol.c (gfc_lval_expr_from_sym) |
| TODO: Merge these functions, if possible. */ |
| |
| /* Get a new expression node. */ |
| |
| gfc_expr * |
| gfc_get_expr (void) |
| { |
| gfc_expr *e; |
| |
| e = XCNEW (gfc_expr); |
| gfc_clear_ts (&e->ts); |
| e->shape = NULL; |
| e->ref = NULL; |
| e->symtree = NULL; |
| return e; |
| } |
| |
| |
| /* Get a new expression node that is an array constructor |
| of given type and kind. */ |
| |
| gfc_expr * |
| gfc_get_array_expr (bt type, int kind, locus *where) |
| { |
| gfc_expr *e; |
| |
| e = gfc_get_expr (); |
| e->expr_type = EXPR_ARRAY; |
| e->value.constructor = NULL; |
| e->rank = 1; |
| e->shape = NULL; |
| |
| e->ts.type = type; |
| e->ts.kind = kind; |
| if (where) |
| e->where = *where; |
| |
| return e; |
| } |
| |
| |
| /* Get a new expression node that is the NULL expression. */ |
| |
| gfc_expr * |
| gfc_get_null_expr (locus *where) |
| { |
| gfc_expr *e; |
| |
| e = gfc_get_expr (); |
| e->expr_type = EXPR_NULL; |
| e->ts.type = BT_UNKNOWN; |
| |
| if (where) |
| e->where = *where; |
| |
| return e; |
| } |
| |
| |
| /* Get a new expression node that is an operator expression node. */ |
| |
| gfc_expr * |
| gfc_get_operator_expr (locus *where, gfc_intrinsic_op op, |
| gfc_expr *op1, gfc_expr *op2) |
| { |
| gfc_expr *e; |
| |
| e = gfc_get_expr (); |
| e->expr_type = EXPR_OP; |
| e->value.op.op = op; |
| e->value.op.op1 = op1; |
| e->value.op.op2 = op2; |
| |
| if (where) |
| e->where = *where; |
| |
| return e; |
| } |
| |
| |
| /* Get a new expression node that is an structure constructor |
| of given type and kind. */ |
| |
| gfc_expr * |
| gfc_get_structure_constructor_expr (bt type, int kind, locus *where) |
| { |
| gfc_expr *e; |
| |
| e = gfc_get_expr (); |
| e->expr_type = EXPR_STRUCTURE; |
| e->value.constructor = NULL; |
| |
| e->ts.type = type; |
| e->ts.kind = kind; |
| if (where) |
| e->where = *where; |
| |
| return e; |
| } |
| |
| |
| /* Get a new expression node that is an constant of given type and kind. */ |
| |
| gfc_expr * |
| gfc_get_constant_expr (bt type, int kind, locus *where) |
| { |
| gfc_expr *e; |
| |
| if (!where) |
| gfc_internal_error ("gfc_get_constant_expr(): locus %<where%> cannot be " |
| "NULL"); |
| |
| e = gfc_get_expr (); |
| |
| e->expr_type = EXPR_CONSTANT; |
| e->ts.type = type; |
| e->ts.kind = kind; |
| e->where = *where; |
| |
| switch (type) |
| { |
| case BT_INTEGER: |
| mpz_init (e->value.integer); |
| break; |
| |
| case BT_REAL: |
| gfc_set_model_kind (kind); |
| mpfr_init (e->value.real); |
| break; |
| |
| case BT_COMPLEX: |
| gfc_set_model_kind (kind); |
| mpc_init2 (e->value.complex, mpfr_get_default_prec()); |
| break; |
| |
| default: |
| break; |
| } |
| |
| return e; |
| } |
| |
| |
| /* Get a new expression node that is an string constant. |
| If no string is passed, a string of len is allocated, |
| blanked and null-terminated. */ |
| |
| gfc_expr * |
| gfc_get_character_expr (int kind, locus *where, const char *src, gfc_charlen_t len) |
| { |
| gfc_expr *e; |
| gfc_char_t *dest; |
| |
| if (!src) |
| { |
| dest = gfc_get_wide_string (len + 1); |
| gfc_wide_memset (dest, ' ', len); |
| dest[len] = '\0'; |
| } |
| else |
| dest = gfc_char_to_widechar (src); |
| |
| e = gfc_get_constant_expr (BT_CHARACTER, kind, |
| where ? where : &gfc_current_locus); |
| e->value.character.string = dest; |
| e->value.character.length = len; |
| |
| return e; |
| } |
| |
| |
| /* Get a new expression node that is an integer constant. */ |
| |
| gfc_expr * |
| gfc_get_int_expr (int kind, locus *where, HOST_WIDE_INT value) |
| { |
| gfc_expr *p; |
| p = gfc_get_constant_expr (BT_INTEGER, kind, |
| where ? where : &gfc_current_locus); |
| |
| const wide_int w = wi::shwi (value, kind * BITS_PER_UNIT); |
| wi::to_mpz (w, p->value.integer, SIGNED); |
| |
| return p; |
| } |
| |
| |
| /* Get a new expression node that is a logical constant. */ |
| |
| gfc_expr * |
| gfc_get_logical_expr (int kind, locus *where, bool value) |
| { |
| gfc_expr *p; |
| p = gfc_get_constant_expr (BT_LOGICAL, kind, |
| where ? where : &gfc_current_locus); |
| |
| p->value.logical = value; |
| |
| return p; |
| } |
| |
| |
| gfc_expr * |
| gfc_get_iokind_expr (locus *where, io_kind k) |
| { |
| gfc_expr *e; |
| |
| /* Set the types to something compatible with iokind. This is needed to |
| get through gfc_free_expr later since iokind really has no Basic Type, |
| BT, of its own. */ |
| |
| e = gfc_get_expr (); |
| e->expr_type = EXPR_CONSTANT; |
| e->ts.type = BT_LOGICAL; |
| e->value.iokind = k; |
| e->where = *where; |
| |
| return e; |
| } |
| |
| |
| /* Given an expression pointer, return a copy of the expression. This |
| subroutine is recursive. */ |
| |
| gfc_expr * |
| gfc_copy_expr (gfc_expr *p) |
| { |
| gfc_expr *q; |
| gfc_char_t *s; |
| char *c; |
| |
| if (p == NULL) |
| return NULL; |
| |
| q = gfc_get_expr (); |
| *q = *p; |
| |
| switch (q->expr_type) |
| { |
| case EXPR_SUBSTRING: |
| s = gfc_get_wide_string (p->value.character.length + 1); |
| q->value.character.string = s; |
| memcpy (s, p->value.character.string, |
| (p->value.character.length + 1) * sizeof (gfc_char_t)); |
| break; |
| |
| case EXPR_CONSTANT: |
| /* Copy target representation, if it exists. */ |
| if (p->representation.string) |
| { |
| c = XCNEWVEC (char, p->representation.length + 1); |
| q->representation.string = c; |
| memcpy (c, p->representation.string, (p->representation.length + 1)); |
| } |
| |
| /* Copy the values of any pointer components of p->value. */ |
| switch (q->ts.type) |
| { |
| case BT_INTEGER: |
| mpz_init_set (q->value.integer, p->value.integer); |
| break; |
| |
| case BT_REAL: |
| gfc_set_model_kind (q->ts.kind); |
| mpfr_init (q->value.real); |
| mpfr_set (q->value.real, p->value.real, GFC_RND_MODE); |
| break; |
| |
| case BT_COMPLEX: |
| gfc_set_model_kind (q->ts.kind); |
| mpc_init2 (q->value.complex, mpfr_get_default_prec()); |
| mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE); |
| break; |
| |
| case BT_CHARACTER: |
| if (p->representation.string) |
| q->value.character.string |
| = gfc_char_to_widechar (q->representation.string); |
| else |
| { |
| s = gfc_get_wide_string (p->value.character.length + 1); |
| q->value.character.string = s; |
| |
| /* This is the case for the C_NULL_CHAR named constant. */ |
| if (p->value.character.length == 0 |
| && (p->ts.is_c_interop || p->ts.is_iso_c)) |
| { |
| *s = '\0'; |
| /* Need to set the length to 1 to make sure the NUL |
| terminator is copied. */ |
| q->value.character.length = 1; |
| } |
| else |
| memcpy (s, p->value.character.string, |
| (p->value.character.length + 1) * sizeof (gfc_char_t)); |
| } |
| break; |
| |
| case BT_HOLLERITH: |
| case BT_LOGICAL: |
| case_bt_struct: |
| case BT_CLASS: |
| case BT_ASSUMED: |
| break; /* Already done. */ |
| |
| case BT_BOZ: |
| q->boz.len = p->boz.len; |
| q->boz.rdx = p->boz.rdx; |
| q->boz.str = XCNEWVEC (char, q->boz.len + 1); |
| strncpy (q->boz.str, p->boz.str, p->boz.len); |
| break; |
| |
| case BT_PROCEDURE: |
| case BT_VOID: |
| /* Should never be reached. */ |
| case BT_UNKNOWN: |
| gfc_internal_error ("gfc_copy_expr(): Bad expr node"); |
| /* Not reached. */ |
| } |
| |
| break; |
| |
| case EXPR_OP: |
| switch (q->value.op.op) |
| { |
| case INTRINSIC_NOT: |
| case INTRINSIC_PARENTHESES: |
| case INTRINSIC_UPLUS: |
| case INTRINSIC_UMINUS: |
| q->value.op.op1 = gfc_copy_expr (p->value.op.op1); |
| break; |
| |
| default: /* Binary operators. */ |
| q->value.op.op1 = gfc_copy_expr (p->value.op.op1); |
| q->value.op.op2 = gfc_copy_expr (p->value.op.op2); |
| break; |
| } |
| |
| break; |
| |
| case EXPR_FUNCTION: |
| q->value.function.actual = |
| gfc_copy_actual_arglist (p->value.function.actual); |
| break; |
| |
| case EXPR_COMPCALL: |
| case EXPR_PPC: |
| q->value.compcall.actual = |
| gfc_copy_actual_arglist (p->value.compcall.actual); |
| q->value.compcall.tbp = p->value.compcall.tbp; |
| break; |
| |
| case EXPR_STRUCTURE: |
| case EXPR_ARRAY: |
| q->value.constructor = gfc_constructor_copy (p->value.constructor); |
| break; |
| |
| case EXPR_VARIABLE: |
| case EXPR_NULL: |
| break; |
| |
| case EXPR_UNKNOWN: |
| gcc_unreachable (); |
| } |
| |
| q->shape = gfc_copy_shape (p->shape, p->rank); |
| |
| q->ref = gfc_copy_ref (p->ref); |
| |
| if (p->param_list) |
| q->param_list = gfc_copy_actual_arglist (p->param_list); |
| |
| return q; |
| } |
| |
| |
| void |
| gfc_clear_shape (mpz_t *shape, int rank) |
| { |
| int i; |
| |
| for (i = 0; i < rank; i++) |
| mpz_clear (shape[i]); |
| } |
| |
| |
| void |
| gfc_free_shape (mpz_t **shape, int rank) |
| { |
| if (*shape == NULL) |
| return; |
| |
| gfc_clear_shape (*shape, rank); |
| free (*shape); |
| *shape = NULL; |
| } |
| |
| |
| /* Workhorse function for gfc_free_expr() that frees everything |
| beneath an expression node, but not the node itself. This is |
| useful when we want to simplify a node and replace it with |
| something else or the expression node belongs to another structure. */ |
| |
| static void |
| free_expr0 (gfc_expr *e) |
| { |
| switch (e->expr_type) |
| { |
| case EXPR_CONSTANT: |
| /* Free any parts of the value that need freeing. */ |
| switch (e->ts.type) |
| { |
| case BT_INTEGER: |
| mpz_clear (e->value.integer); |
| break; |
| |
| case BT_REAL: |
| mpfr_clear (e->value.real); |
| break; |
| |
| case BT_CHARACTER: |
| free (e->value.character.string); |
| break; |
| |
| case BT_COMPLEX: |
| mpc_clear (e->value.complex); |
| break; |
| |
| default: |
| break; |
| } |
| |
| /* Free the representation. */ |
| free (e->representation.string); |
| |
| break; |
| |
| case EXPR_OP: |
| if (e->value.op.op1 != NULL) |
| gfc_free_expr (e->value.op.op1); |
| if (e->value.op.op2 != NULL) |
| gfc_free_expr (e->value.op.op2); |
| break; |
| |
| case EXPR_FUNCTION: |
| gfc_free_actual_arglist (e->value.function.actual); |
| break; |
| |
| case EXPR_COMPCALL: |
| case EXPR_PPC: |
| gfc_free_actual_arglist (e->value.compcall.actual); |
| break; |
| |
| case EXPR_VARIABLE: |
| break; |
| |
| case EXPR_ARRAY: |
| case EXPR_STRUCTURE: |
| gfc_constructor_free (e->value.constructor); |
| break; |
| |
| case EXPR_SUBSTRING: |
| free (e->value.character.string); |
| break; |
| |
| case EXPR_NULL: |
| break; |
| |
| default: |
| gfc_internal_error ("free_expr0(): Bad expr type"); |
| } |
| |
| /* Free a shape array. */ |
| gfc_free_shape (&e->shape, e->rank); |
| |
| gfc_free_ref_list (e->ref); |
| |
| gfc_free_actual_arglist (e->param_list); |
| |
| memset (e, '\0', sizeof (gfc_expr)); |
| } |
| |
| |
| /* Free an expression node and everything beneath it. */ |
| |
| void |
| gfc_free_expr (gfc_expr *e) |
| { |
| if (e == NULL) |
| return; |
| free_expr0 (e); |
| free (e); |
| } |
| |
| |
| /* Free an argument list and everything below it. */ |
| |
| void |
| gfc_free_actual_arglist (gfc_actual_arglist *a1) |
| { |
| gfc_actual_arglist *a2; |
| |
| while (a1) |
| { |
| a2 = a1->next; |
| if (a1->expr) |
| gfc_free_expr (a1->expr); |
| free (a1); |
| a1 = a2; |
| } |
| } |
| |
| |
| /* Copy an arglist structure and all of the arguments. */ |
| |
| gfc_actual_arglist * |
| gfc_copy_actual_arglist (gfc_actual_arglist *p) |
| { |
| gfc_actual_arglist *head, *tail, *new_arg; |
| |
| head = tail = NULL; |
| |
| for (; p; p = p->next) |
| { |
| new_arg = gfc_get_actual_arglist (); |
| *new_arg = *p; |
| |
| new_arg->expr = gfc_copy_expr (p->expr); |
| new_arg->next = NULL; |
| |
| if (head == NULL) |
| head = new_arg; |
| else |
| tail->next = new_arg; |
| |
| tail = new_arg; |
| } |
| |
| return head; |
| } |
| |
| |
| /* Free a list of reference structures. */ |
| |
| void |
| gfc_free_ref_list (gfc_ref *p) |
| { |
| gfc_ref *q; |
| int i; |
| |
| for (; p; p = q) |
| { |
| q = p->next; |
| |
| switch (p->type) |
| { |
| case REF_ARRAY: |
| for (i = 0; i < GFC_MAX_DIMENSIONS; i++) |
| { |
| gfc_free_expr (p->u.ar.start[i]); |
| gfc_free_expr (p->u.ar.end[i]); |
| gfc_free_expr (p->u.ar.stride[i]); |
| } |
| |
| break; |
| |
| case REF_SUBSTRING: |
| gfc_free_expr (p->u.ss.start); |
| gfc_free_expr (p->u.ss.end); |
| break; |
| |
| case REF_COMPONENT: |
| case REF_INQUIRY: |
| break; |
| } |
| |
| free (p); |
| } |
| } |
| |
| |
| /* Graft the *src expression onto the *dest subexpression. */ |
| |
| void |
| gfc_replace_expr (gfc_expr *dest, gfc_expr *src) |
| { |
| free_expr0 (dest); |
| *dest = *src; |
| free (src); |
| } |
| |
| |
| /* Try to extract an integer constant from the passed expression node. |
| Return true if some error occurred, false on success. If REPORT_ERROR |
| is non-zero, emit error, for positive REPORT_ERROR using gfc_error, |
| for negative using gfc_error_now. */ |
| |
| bool |
| gfc_extract_int (gfc_expr *expr, int *result, int report_error) |
| { |
| gfc_ref *ref; |
| |
| /* A KIND component is a parameter too. The expression for it |
| is stored in the initializer and should be consistent with |
| the tests below. */ |
| if (gfc_expr_attr(expr).pdt_kind) |
| { |
| for (ref = expr->ref; ref; ref = ref->next) |
| { |
| if (ref->u.c.component->attr.pdt_kind) |
| expr = ref->u.c.component->initializer; |
| } |
| } |
| |
| if (expr->expr_type != EXPR_CONSTANT) |
| { |
| if (report_error > 0) |
| gfc_error ("Constant expression required at %C"); |
| else if (report_error < 0) |
| gfc_error_now ("Constant expression required at %C"); |
| return true; |
| } |
| |
| if (expr->ts.type != BT_INTEGER) |
| { |
| if (report_error > 0) |
| gfc_error ("Integer expression required at %C"); |
| else if (report_error < 0) |
| gfc_error_now ("Integer expression required at %C"); |
| return true; |
| } |
| |
| if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0) |
| || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0)) |
| { |
| if (report_error > 0) |
| gfc_error ("Integer value too large in expression at %C"); |
| else if (report_error < 0) |
| gfc_error_now ("Integer value too large in expression at %C"); |
| return true; |
| } |
| |
| *result = (int) mpz_get_si (expr->value.integer); |
| |
| return false; |
| } |
| |
| |
| /* Same as gfc_extract_int, but use a HWI. */ |
| |
| bool |
| gfc_extract_hwi (gfc_expr *expr, HOST_WIDE_INT *result, int report_error) |
| { |
| gfc_ref *ref; |
| |
| /* A KIND component is a parameter too. The expression for it is |
| stored in the initializer and should be consistent with the tests |
| below. */ |
| if (gfc_expr_attr(expr).pdt_kind) |
| { |
| for (ref = expr->ref; ref; ref = ref->next) |
| { |
| if (ref->u.c.component->attr.pdt_kind) |
| expr = ref->u.c.component->initializer; |
| } |
| } |
| |
| if (expr->expr_type != EXPR_CONSTANT) |
| { |
| if (report_error > 0) |
| gfc_error ("Constant expression required at %C"); |
| else if (report_error < 0) |
| gfc_error_now ("Constant expression required at %C"); |
| return true; |
| } |
| |
| if (expr->ts.type != BT_INTEGER) |
| { |
| if (report_error > 0) |
| gfc_error ("Integer expression required at %C"); |
| else if (report_error < 0) |
| gfc_error_now ("Integer expression required at %C"); |
| return true; |
| } |
| |
| /* Use long_long_integer_type_node to determine when to saturate. */ |
| const wide_int val = wi::from_mpz (long_long_integer_type_node, |
| expr->value.integer, false); |
| |
| if (!wi::fits_shwi_p (val)) |
| { |
| if (report_error > 0) |
| gfc_error ("Integer value too large in expression at %C"); |
| else if (report_error < 0) |
| gfc_error_now ("Integer value too large in expression at %C"); |
| return true; |
| } |
| |
| *result = val.to_shwi (); |
| |
| return false; |
| } |
| |
| |
| /* Recursively copy a list of reference structures. */ |
| |
| gfc_ref * |
| gfc_copy_ref (gfc_ref *src) |
| { |
| gfc_array_ref *ar; |
| gfc_ref *dest; |
| |
| if (src == NULL) |
| return NULL; |
| |
| dest = gfc_get_ref (); |
| dest->type = src->type; |
| |
| switch (src->type) |
| { |
| case REF_ARRAY: |
| ar = gfc_copy_array_ref (&src->u.ar); |
| dest->u.ar = *ar; |
| free (ar); |
| break; |
| |
| case REF_COMPONENT: |
| dest->u.c = src->u.c; |
| break; |
| |
| case REF_INQUIRY: |
| dest->u.i = src->u.i; |
| break; |
| |
| case REF_SUBSTRING: |
| dest->u.ss = src->u.ss; |
| dest->u.ss.start = gfc_copy_expr (src->u.ss.start); |
| dest->u.ss.end = gfc_copy_expr (src->u.ss.end); |
| break; |
| } |
| |
| dest->next = gfc_copy_ref (src->next); |
| |
| return dest; |
| } |
| |
| |
| /* Detect whether an expression has any vector index array references. */ |
| |
| int |
| gfc_has_vector_index (gfc_expr *e) |
| { |
| gfc_ref *ref; |
| int i; |
| for (ref = e->ref; ref; ref = ref->next) |
| if (ref->type == REF_ARRAY) |
| for (i = 0; i < ref->u.ar.dimen; i++) |
| if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) |
| return 1; |
| return 0; |
| } |
| |
| |
| /* Copy a shape array. */ |
| |
| mpz_t * |
| gfc_copy_shape (mpz_t *shape, int rank) |
| { |
| mpz_t *new_shape; |
| int n; |
| |
| if (shape == NULL) |
| return NULL; |
| |
| new_shape = gfc_get_shape (rank); |
| |
| for (n = 0; n < rank; n++) |
| mpz_init_set (new_shape[n], shape[n]); |
| |
| return new_shape; |
| } |
| |
| |
| /* Copy a shape array excluding dimension N, where N is an integer |
| constant expression. Dimensions are numbered in Fortran style -- |
| starting with ONE. |
| |
| So, if the original shape array contains R elements |
| { s1 ... sN-1 sN sN+1 ... sR-1 sR} |
| the result contains R-1 elements: |
| { s1 ... sN-1 sN+1 ... sR-1} |
| |
| If anything goes wrong -- N is not a constant, its value is out |
| of range -- or anything else, just returns NULL. */ |
| |
| mpz_t * |
| gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim) |
| { |
| mpz_t *new_shape, *s; |
| int i, n; |
| |
| if (shape == NULL |
| || rank <= 1 |
| || dim == NULL |
| || dim->expr_type != EXPR_CONSTANT |
| || dim->ts.type != BT_INTEGER) |
| return NULL; |
| |
| n = mpz_get_si (dim->value.integer); |
| n--; /* Convert to zero based index. */ |
| if (n < 0 || n >= rank) |
| return NULL; |
| |
| s = new_shape = gfc_get_shape (rank - 1); |
| |
| for (i = 0; i < rank; i++) |
| { |
| if (i == n) |
| continue; |
| mpz_init_set (*s, shape[i]); |
| s++; |
| } |
| |
| return new_shape; |
| } |
| |
| |
| /* Return the maximum kind of two expressions. In general, higher |
| kind numbers mean more precision for numeric types. */ |
| |
| int |
| gfc_kind_max (gfc_expr *e1, gfc_expr *e2) |
| { |
| return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind; |
| } |
| |
| |
| /* Returns nonzero if the type is numeric, zero otherwise. */ |
| |
| static int |
| numeric_type (bt type) |
| { |
| return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER; |
| } |
| |
| |
| /* Returns nonzero if the typespec is a numeric type, zero otherwise. */ |
| |
| int |
| gfc_numeric_ts (gfc_typespec *ts) |
| { |
| return numeric_type (ts->type); |
| } |
| |
| |
| /* Return an expression node with an optional argument list attached. |
| A variable number of gfc_expr pointers are strung together in an |
| argument list with a NULL pointer terminating the list. */ |
| |
| gfc_expr * |
| gfc_build_conversion (gfc_expr *e) |
| { |
| gfc_expr *p; |
| |
| p = gfc_get_expr (); |
| p->expr_type = EXPR_FUNCTION; |
| p->symtree = NULL; |
| p->value.function.actual = gfc_get_actual_arglist (); |
| p->value.function.actual->expr = e; |
| |
| return p; |
| } |
| |
| |
| /* Given an expression node with some sort of numeric binary |
| expression, insert type conversions required to make the operands |
| have the same type. Conversion warnings are disabled if wconversion |
| is set to 0. |
| |
| The exception is that the operands of an exponential don't have to |
| have the same type. If possible, the base is promoted to the type |
| of the exponent. For example, 1**2.3 becomes 1.0**2.3, but |
| 1.0**2 stays as it is. */ |
| |
| void |
| gfc_type_convert_binary (gfc_expr *e, int wconversion) |
| { |
| gfc_expr *op1, *op2; |
| |
| op1 = e->value.op.op1; |
| op2 = e->value.op.op2; |
| |
| if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN) |
| { |
| gfc_clear_ts (&e->ts); |
| return; |
| } |
| |
| /* Kind conversions of same type. */ |
| if (op1->ts.type == op2->ts.type) |
| { |
| if (op1->ts.kind == op2->ts.kind) |
| { |
| /* No type conversions. */ |
| e->ts = op1->ts; |
| goto done; |
| } |
| |
| if (op1->ts.kind > op2->ts.kind) |
| gfc_convert_type_warn (op2, &op1->ts, 2, wconversion); |
| else |
| gfc_convert_type_warn (op1, &op2->ts, 2, wconversion); |
| |
| e->ts = op1->ts; |
| goto done; |
| } |
| |
| /* Integer combined with real or complex. */ |
| if (op2->ts.type == BT_INTEGER) |
| { |
| e->ts = op1->ts; |
| |
| /* Special case for ** operator. */ |
| if (e->value.op.op == INTRINSIC_POWER) |
| goto done; |
| |
| gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion); |
| goto done; |
| } |
| |
| if (op1->ts.type == BT_INTEGER) |
| { |
| e->ts = op2->ts; |
| gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion); |
| goto done; |
| } |
| |
| /* Real combined with complex. */ |
| e->ts.type = BT_COMPLEX; |
| if (op1->ts.kind > op2->ts.kind) |
| e->ts.kind = op1->ts.kind; |
| else |
| e->ts.kind = op2->ts.kind; |
| if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind) |
| gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion); |
| if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind) |
| gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion); |
| |
| done: |
| return; |
| } |
| |
| |
| /* Standard intrinsics listed under F2018:10.1.12 (6), which are excluded in |
| constant expressions, except TRANSFER (c.f. item (8)), which would need |
| separate treatment. */ |
| |
| static bool |
| is_non_constant_intrinsic (gfc_expr *e) |
| { |
| if (e->expr_type == EXPR_FUNCTION |
| && e->value.function.isym) |
| { |
| switch (e->value.function.isym->id) |
| { |
| case GFC_ISYM_COMMAND_ARGUMENT_COUNT: |
| case GFC_ISYM_GET_TEAM: |
| case GFC_ISYM_NULL: |
| case GFC_ISYM_NUM_IMAGES: |
| case GFC_ISYM_TEAM_NUMBER: |
| case GFC_ISYM_THIS_IMAGE: |
| return true; |
| |
| default: |
| return false; |
| } |
| } |
| return false; |
| } |
| |
| |
| /* Determine if an expression is constant in the sense of F08:7.1.12. |
| * This function expects that the expression has already been simplified. */ |
| |
| bool |
| gfc_is_constant_expr (gfc_expr *e) |
| { |
| gfc_constructor *c; |
| gfc_actual_arglist *arg; |
| |
| if (e == NULL) |
| return true; |
| |
| switch (e->expr_type) |
| { |
| case EXPR_OP: |
| return (gfc_is_constant_expr (e->value.op.op1) |
| && (e->value.op.op2 == NULL |
| || gfc_is_constant_expr (e->value.op.op2))); |
| |
| case EXPR_VARIABLE: |
| /* The only context in which this can occur is in a parameterized |
| derived type declaration, so returning true is OK. */ |
| if (e->symtree->n.sym->attr.pdt_len |
| || e->symtree->n.sym->attr.pdt_kind) |
| return true; |
| return false; |
| |
| case EXPR_FUNCTION: |
| case EXPR_PPC: |
| case EXPR_COMPCALL: |
| gcc_assert (e->symtree || e->value.function.esym |
| || e->value.function.isym); |
| |
| /* Check for intrinsics excluded in constant expressions. */ |
| if (e->value.function.isym && is_non_constant_intrinsic (e)) |
| return false; |
| |
| /* Call to intrinsic with at least one argument. */ |
| if (e->value.function.isym && e->value.function.actual) |
| { |
| for (arg = e->value.function.actual; arg; arg = arg->next) |
| if (!gfc_is_constant_expr (arg->expr)) |
| return false; |
| } |
| |
| if (e->value.function.isym |
| && (e->value.function.isym->elemental |
| || e->value.function.isym->pure |
| || e->value.function.isym->inquiry |
| || e->value.function.isym->transformational)) |
| return true; |
| |
| return false; |
| |
| case EXPR_CONSTANT: |
| case EXPR_NULL: |
| return true; |
| |
| case EXPR_SUBSTRING: |
| return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start) |
| && gfc_is_constant_expr (e->ref->u.ss.end)); |
| |
| case EXPR_ARRAY: |
| case EXPR_STRUCTURE: |
| c = gfc_constructor_first (e->value.constructor); |
| if ((e->expr_type == EXPR_ARRAY) && c && c->iterator) |
| return gfc_constant_ac (e); |
| |
| for (; c; c = gfc_constructor_next (c)) |
| if (!gfc_is_constant_expr (c->expr)) |
| return false; |
| |
| return true; |
| |
| |
| default: |
| gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type"); |
| return false; |
| } |
| } |
| |
| |
| /* Is true if the expression or symbol is a passed CFI descriptor. */ |
| bool |
| is_CFI_desc (gfc_symbol *sym, gfc_expr *e) |
| { |
| if (sym == NULL |
| && e && e->expr_type == EXPR_VARIABLE) |
| sym = e->symtree->n.sym; |
| |
| if (sym && sym->attr.dummy |
| && sym->ns->proc_name->attr.is_bind_c |
| && sym->attr.dimension |
| && (sym->attr.pointer |
| || sym->attr.allocatable |
| || sym->as->type == AS_ASSUMED_SHAPE |
| || sym->as->type == AS_ASSUMED_RANK)) |
| return true; |
| |
| return false; |
| } |
| |
| |
| /* Is true if an array reference is followed by a component or substring |
| reference. */ |
| bool |
| is_subref_array (gfc_expr * e) |
| { |
| gfc_ref * ref; |
| bool seen_array; |
| gfc_symbol *sym; |
| |
| if (e->expr_type != EXPR_VARIABLE) |
| return false; |
| |
| sym = e->symtree->n.sym; |
| |
| if (sym->attr.subref_array_pointer) |
| return true; |
| |
| seen_array = false; |
| |
| for (ref = e->ref; ref; ref = ref->next) |
| { |
| /* If we haven't seen the array reference and this is an intrinsic, |
| what follows cannot be a subreference array, unless there is a |
| substring reference. */ |
| if (!seen_array && ref->type == REF_COMPONENT |
| && ref->u.c.component->ts.type != BT_CHARACTER |
| && ref->u.c.component->ts.type != BT_CLASS |
| && !gfc_bt_struct (ref->u.c.component->ts.type)) |
| return false; |
| |
| if (ref->type == REF_ARRAY |
| && ref->u.ar.type != AR_ELEMENT) |
| seen_array = true; |
| |
| if (seen_array |
| && ref->type != REF_ARRAY) |
| return seen_array; |
| } |
| |
| if (sym->ts.type == BT_CLASS |
| && sym->attr.dummy |
| && CLASS_DATA (sym)->attr.dimension |
| && CLASS_DATA (sym)->attr.class_pointer) |
| return true; |
| |
| return false; |
| } |
| |
| |
| /* Try to collapse intrinsic expressions. */ |
| |
| static bool |
| simplify_intrinsic_op (gfc_expr *p, int type) |
| { |
| gfc_intrinsic_op op; |
| gfc_expr *op1, *op2, *result; |
| |
| if (p->value.op.op == INTRINSIC_USER) |
| return true; |
| |
| op1 = p->value.op.op1; |
| op2 = p->value.op.op2; |
| op = p->value.op.op; |
| |
| if (!gfc_simplify_expr (op1, type)) |
| return false; |
| if (!gfc_simplify_expr (op2, type)) |
| return false; |
| |
| if (!gfc_is_constant_expr (op1) |
| || (op2 != NULL && !gfc_is_constant_expr (op2))) |
| return true; |
| |
| /* Rip p apart. */ |
| p->value.op.op1 = NULL; |
| p->value.op.op2 = NULL; |
| |
| switch (op) |
| { |
| case INTRINSIC_PARENTHESES: |
| result = gfc_parentheses (op1); |
| break; |
| |
| case INTRINSIC_UPLUS: |
| result = gfc_uplus (op1); |
| break; |
| |
| case INTRINSIC_UMINUS: |
| result = gfc_uminus (op1); |
| break; |
| |
| case INTRINSIC_PLUS: |
| result = gfc_add (op1, op2); |
| break; |
| |
| case INTRINSIC_MINUS: |
| result = gfc_subtract (op1, op2); |
| break; |
| |
| case INTRINSIC_TIMES: |
| result = gfc_multiply (op1, op2); |
| break; |
| |
| case INTRINSIC_DIVIDE: |
| result = gfc_divide (op1, op2); |
| break; |
| |
| case INTRINSIC_POWER: |
| result = gfc_power (op1, op2); |
| break; |
| |
| case INTRINSIC_CONCAT: |
| result = gfc_concat (op1, op2); |
| break; |
| |
| case INTRINSIC_EQ: |
| case INTRINSIC_EQ_OS: |
| result = gfc_eq (op1, op2, op); |
| break; |
| |
| case INTRINSIC_NE: |
| case INTRINSIC_NE_OS: |
| result = gfc_ne (op1, op2, op); |
| break; |
| |
| case INTRINSIC_GT: |
| case INTRINSIC_GT_OS: |
| result = gfc_gt (op1, op2, op); |
| break; |
| |
| case INTRINSIC_GE: |
| case INTRINSIC_GE_OS: |
| result = gfc_ge (op1, op2, op); |
| break; |
| |
| case INTRINSIC_LT: |
| case INTRINSIC_LT_OS: |
| result = gfc_lt (op1, op2, op); |
| break; |
| |
| case INTRINSIC_LE: |
| case INTRINSIC_LE_OS: |
| result = gfc_le (op1, op2, op); |
| break; |
| |
| case INTRINSIC_NOT: |
| result = gfc_not (op1); |
| break; |
| |
| case INTRINSIC_AND: |
| result = gfc_and (op1, op2); |
| break; |
| |
| case INTRINSIC_OR: |
| result = gfc_or (op1, op2); |
| break; |
| |
| case INTRINSIC_EQV: |
| result = gfc_eqv (op1, op2); |
| break; |
| |
| case INTRINSIC_NEQV: |
| result = gfc_neqv (op1, op2); |
| break; |
| |
| default: |
| gfc_internal_error ("simplify_intrinsic_op(): Bad operator"); |
| } |
| |
| if (result == NULL) |
| { |
| gfc_free_expr (op1); |
| gfc_free_expr (op2); |
| return false; |
| } |
| |
| result->rank = p->rank; |
| result->where = p->where; |
| gfc_replace_expr (p, result); |
| |
| return true; |
| } |
| |
| |
| /* Subroutine to simplify constructor expressions. Mutually recursive |
| with gfc_simplify_expr(). */ |
| |
| static bool |
| simplify_constructor (gfc_constructor_base base, int type) |
| { |
| gfc_constructor *c; |
| gfc_expr *p; |
| |
| for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) |
| { |
| if (c->iterator |
| && (!gfc_simplify_expr(c->iterator->start, type) |
| || !gfc_simplify_expr (c->iterator->end, type) |
| || !gfc_simplify_expr (c->iterator->step, type))) |
| return false; |
| |
| if (c->expr) |
| { |
| /* Try and simplify a copy. Replace the original if successful |
| but keep going through the constructor at all costs. Not |
| doing so can make a dog's dinner of complicated things. */ |
| p = gfc_copy_expr (c->expr); |
| |
| if (!gfc_simplify_expr (p, type)) |
| { |
| gfc_free_expr (p); |
| continue; |
| } |
| |
| gfc_replace_expr (c->expr, p); |
| } |
| } |
| |
| return true; |
| } |
| |
| |
| /* Pull a single array element out of an array constructor. */ |
| |
| static bool |
| find_array_element (gfc_constructor_base base, gfc_array_ref *ar, |
| gfc_constructor **rval) |
| { |
| unsigned long nelemen; |
| int i; |
| mpz_t delta; |
| mpz_t offset; |
| mpz_t span; |
| mpz_t tmp; |
| gfc_constructor *cons; |
| gfc_expr *e; |
| bool t; |
| |
| t = true; |
| e = NULL; |
| |
| mpz_init_set_ui (offset, 0); |
| mpz_init (delta); |
| mpz_init (tmp); |
| mpz_init_set_ui (span, 1); |
| for (i = 0; i < ar->dimen; i++) |
| { |
| if (!gfc_reduce_init_expr (ar->as->lower[i]) |
| || !gfc_reduce_init_expr (ar->as->upper[i]) |
| || ar->as->upper[i]->expr_type != EXPR_CONSTANT |
| || ar->as->lower[i]->expr_type != EXPR_CONSTANT) |
| { |
| t = false; |
| cons = NULL; |
| goto depart; |
| } |
| |
| e = ar->start[i]; |
| if (e->expr_type != EXPR_CONSTANT) |
| { |
| cons = NULL; |
| goto depart; |
| } |
| |
| /* Check the bounds. */ |
| if ((ar->as->upper[i] |
| && mpz_cmp (e->value.integer, |
| ar->as->upper[i]->value.integer) > 0) |
| || (mpz_cmp (e->value.integer, |
| ar->as->lower[i]->value.integer) < 0)) |
| { |
| gfc_error ("Index in dimension %d is out of bounds " |
| "at %L", i + 1, &ar->c_where[i]); |
| cons = NULL; |
| t = false; |
| goto depart; |
| } |
| |
| mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer); |
| mpz_mul (delta, delta, span); |
| mpz_add (offset, offset, delta); |
| |
| mpz_set_ui (tmp, 1); |
| mpz_add (tmp, tmp, ar->as->upper[i]->value.integer); |
| mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer); |
| mpz_mul (span, span, tmp); |
| } |
| |
| for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui (offset); |
| cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--) |
| { |
| if (cons->iterator) |
| { |
| cons = NULL; |
| goto depart; |
| } |
| } |
| |
| depart: |
| mpz_clear (delta); |
| mpz_clear (offset); |
| mpz_clear (span); |
| mpz_clear (tmp); |
| *rval = cons; |
| return t; |
| } |
| |
| |
| /* Find a component of a structure constructor. */ |
| |
| static gfc_constructor * |
| find_component_ref (gfc_constructor_base base, gfc_ref *ref) |
| { |
| gfc_component *pick = ref->u.c.component; |
| gfc_constructor *c = gfc_constructor_first (base); |
| |
| gfc_symbol *dt = ref->u.c.sym; |
| int ext = dt->attr.extension; |
| |
| /* For extended types, check if the desired component is in one of the |
| * parent types. */ |
| while (ext > 0 && gfc_find_component (dt->components->ts.u.derived, |
| pick->name, true, true, NULL)) |
| { |
| dt = dt->components->ts.u.derived; |
| c = gfc_constructor_first (c->expr->value.constructor); |
| ext--; |
| } |
| |
| gfc_component *comp = dt->components; |
| while (comp != pick) |
| { |
| comp = comp->next; |
| c = gfc_constructor_next (c); |
| } |
| |
| return c; |
| } |
| |
| |
| /* Replace an expression with the contents of a constructor, removing |
| the subobject reference in the process. */ |
| |
| static void |
| remove_subobject_ref (gfc_expr *p, gfc_constructor *cons) |
| { |
| gfc_expr *e; |
| |
| if (cons) |
| { |
| e = cons->expr; |
| cons->expr = NULL; |
| } |
| else |
| e = gfc_copy_expr (p); |
| e->ref = p->ref->next; |
| p->ref->next = NULL; |
| gfc_replace_expr (p, e); |
| } |
| |
| |
| /* Pull an array section out of an array constructor. */ |
| |
| static bool |
| find_array_section (gfc_expr *expr, gfc_ref *ref) |
| { |
| int idx; |
| int rank; |
| int d; |
| int shape_i; |
| int limit; |
| long unsigned one = 1; |
| bool incr_ctr; |
| mpz_t start[GFC_MAX_DIMENSIONS]; |
| mpz_t end[GFC_MAX_DIMENSIONS]; |
| mpz_t stride[GFC_MAX_DIMENSIONS]; |
| mpz_t delta[GFC_MAX_DIMENSIONS]; |
| mpz_t ctr[GFC_MAX_DIMENSIONS]; |
| mpz_t delta_mpz; |
| mpz_t tmp_mpz; |
| mpz_t nelts; |
| mpz_t ptr; |
| gfc_constructor_base base; |
| gfc_constructor *cons, *vecsub[GFC_MAX_DIMENSIONS]; |
| gfc_expr *begin; |
| gfc_expr *finish; |
| gfc_expr *step; |
| gfc_expr *upper; |
| gfc_expr *lower; |
| bool t; |
| |
| t = true; |
| |
| base = expr->value.constructor; |
| expr->value.constructor = NULL; |
| |
| rank = ref->u.ar.as->rank; |
| |
| if (expr->shape == NULL) |
| expr->shape = gfc_get_shape (rank); |
| |
| mpz_init_set_ui (delta_mpz, one); |
| mpz_init_set_ui (nelts, one); |
| mpz_init (tmp_mpz); |
| |
| /* Do the initialization now, so that we can cleanup without |
| keeping track of where we were. */ |
| for (d = 0; d < rank; d++) |
| { |
| mpz_init (delta[d]); |
| mpz_init (start[d]); |
| mpz_init (end[d]); |
| mpz_init (ctr[d]); |
| mpz_init (stride[d]); |
| vecsub[d] = NULL; |
| } |
| |
| /* Build the counters to clock through the array reference. */ |
| shape_i = 0; |
| for (d = 0; d < rank; d++) |
| { |
| /* Make this stretch of code easier on the eye! */ |
| begin = ref->u.ar.start[d]; |
| finish = ref->u.ar.end[d]; |
| step = ref->u.ar.stride[d]; |
| lower = ref->u.ar.as->lower[d]; |
| upper = ref->u.ar.as->upper[d]; |
| |
| if (!lower || !upper |
| || lower->expr_type != EXPR_CONSTANT |
| || upper->expr_type != EXPR_CONSTANT |
| || lower->ts.type != BT_INTEGER |
| || upper->ts.type != BT_INTEGER) |
| { |
| t = false; |
| goto cleanup; |
| } |
| |
| if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */ |
| { |
| gfc_constructor *ci; |
| gcc_assert (begin); |
| |
| if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin)) |
| { |
| t = false; |
| goto cleanup; |
| } |
| |
| gcc_assert (begin->rank == 1); |
| /* Zero-sized arrays have no shape and no elements, stop early. */ |
| if (!begin->shape) |
| { |
| mpz_init_set_ui (nelts, 0); |
| break; |
| } |
| |
| vecsub[d] = gfc_constructor_first (begin->value.constructor); |
| mpz_set (ctr[d], vecsub[d]->expr->value.integer); |
| mpz_mul (nelts, nelts, begin->shape[0]); |
| mpz_set (expr->shape[shape_i++], begin->shape[0]); |
| |
| /* Check bounds. */ |
| for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci)) |
| { |
| if (mpz_cmp (ci->expr->value.integer, upper->value.integer) > 0 |
| || mpz_cmp (ci->expr->value.integer, |
| lower->value.integer) < 0) |
| { |
| gfc_error ("index in dimension %d is out of bounds " |
| "at %L", d + 1, &ref->u.ar.c_where[d]); |
| t = false; |
| goto cleanup; |
| } |
| } |
| } |
| else |
| { |
| if ((begin && begin->expr_type != EXPR_CONSTANT) |
| || (finish && finish->expr_type != EXPR_CONSTANT) |
| || (step && step->expr_type != EXPR_CONSTANT)) |
| { |
| t = false; |
| goto cleanup; |
| } |
| |
| /* Obtain the stride. */ |
| if (step) |
| mpz_set (stride[d], step->value.integer); |
| else |
| mpz_set_ui (stride[d], one); |
| |
| if (mpz_cmp_ui (stride[d], 0) == 0) |
| mpz_set_ui (stride[d], one); |
| |
| /* Obtain the start value for the index. */ |
| if (begin) |
| mpz_set (start[d], begin->value.integer); |
| else |
| mpz_set (start[d], lower->value.integer); |
| |
| mpz_set (ctr[d], start[d]); |
| |
| /* Obtain the end value for the index. */ |
| if (finish) |
| mpz_set (end[d], finish->value.integer); |
| else |
| mpz_set (end[d], upper->value.integer); |
| |
| /* Separate 'if' because elements sometimes arrive with |
| non-null end. */ |
| if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT) |
| mpz_set (end [d], begin->value.integer); |
| |
| /* Check the bounds. */ |
| if (mpz_cmp (ctr[d], upper->value.integer) > 0 |
| || mpz_cmp (end[d], upper->value.integer) > 0 |
| || mpz_cmp (ctr[d], lower->value.integer) < 0 |
| || mpz_cmp (end[d], lower->value.integer) < 0) |
| { |
| gfc_error ("index in dimension %d is out of bounds " |
| "at %L", d + 1, &ref->u.ar.c_where[d]); |
| t = false; |
| goto cleanup; |
| } |
| |
| /* Calculate the number of elements and the shape. */ |
| mpz_set (tmp_mpz, stride[d]); |
| mpz_add (tmp_mpz, end[d], tmp_mpz); |
| mpz_sub (tmp_mpz, tmp_mpz, ctr[d]); |
| mpz_div (tmp_mpz, tmp_mpz, stride[d]); |
| mpz_mul (nelts, nelts, tmp_mpz); |
| |
| /* An element reference reduces the rank of the expression; don't |
| add anything to the shape array. */ |
| if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT) |
| mpz_set (expr->shape[shape_i++], tmp_mpz); |
| } |
| |
| /* Calculate the 'stride' (=delta) for conversion of the |
| counter values into the index along the constructor. */ |
| mpz_set (delta[d], delta_mpz); |
| mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer); |
| mpz_add_ui (tmp_mpz, tmp_mpz, one); |
| mpz_mul (delta_mpz, delta_mpz, tmp_mpz); |
| } |
| |
| mpz_init (ptr); |
| cons = gfc_constructor_first (base); |
| |
| /* Now clock through the array reference, calculating the index in |
| the source constructor and transferring the elements to the new |
| constructor. */ |
| for (idx = 0; idx < (int) mpz_get_si (nelts); idx++) |
| { |
| mpz_init_set_ui (ptr, 0); |
| |
| incr_ctr = true; |
| for (d = 0; d < rank; d++) |
| { |
| mpz_set (tmp_mpz, ctr[d]); |
| mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer); |
| mpz_mul (tmp_mpz, tmp_mpz, delta[d]); |
| mpz_add (ptr, ptr, tmp_mpz); |
| |
| if (!incr_ctr) continue; |
| |
| if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */ |
| { |
| gcc_assert(vecsub[d]); |
| |
| if (!gfc_constructor_next (vecsub[d])) |
| vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor); |
| else |
| { |
| vecsub[d] = gfc_constructor_next (vecsub[d]); |
| incr_ctr = false; |
| } |
| mpz_set (ctr[d], vecsub[d]->expr->value.integer); |
| } |
| else |
| { |
| mpz_add (ctr[d], ctr[d], stride[d]); |
| |
| if (mpz_cmp_ui (stride[d], 0) > 0 |
| ? mpz_cmp (ctr[d], end[d]) > 0 |
| : mpz_cmp (ctr[d], end[d]) < 0) |
| mpz_set (ctr[d], start[d]); |
| else |
| incr_ctr = false; |
| } |
| } |
| |
| limit = mpz_get_ui (ptr); |
| if (limit >= flag_max_array_constructor) |
| { |
| gfc_error ("The number of elements in the array constructor " |
| "at %L requires an increase of the allowed %d " |
| "upper limit. See %<-fmax-array-constructor%> " |
| "option", &expr->where, flag_max_array_constructor); |
| return false; |
| } |
| |
| cons = gfc_constructor_lookup (base, limit); |
| gcc_assert (cons); |
| gfc_constructor_append_expr (&expr->value.constructor, |
| gfc_copy_expr (cons->expr), NULL); |
| } |
| |
| mpz_clear (ptr); |
| |
| cleanup: |
| |
| mpz_clear (delta_mpz); |
| mpz_clear (tmp_mpz); |
| mpz_clear (nelts); |
| for (d = 0; d < rank; d++) |
| { |
| mpz_clear (delta[d]); |
| mpz_clear (start[d]); |
| mpz_clear (end[d]); |
| mpz_clear (ctr[d]); |
| mpz_clear (stride[d]); |
| } |
| gfc_constructor_free (base); |
| return t; |
| } |
| |
| /* Pull a substring out of an expression. */ |
| |
| static bool |
| find_substring_ref (gfc_expr *p, gfc_expr **newp) |
| { |
| gfc_charlen_t end; |
| gfc_charlen_t start; |
| gfc_charlen_t length; |
| gfc_char_t *chr; |
| |
| if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT |
| || p->ref->u.ss.end->expr_type != EXPR_CONSTANT) |
| return false; |
| |
| *newp = gfc_copy_expr (p); |
| free ((*newp)->value.character.string); |
| |
| end = (gfc_charlen_t) mpz_get_si (p->ref->u.ss.end->value.integer); |
| start = (gfc_charlen_t) mpz_get_si (p->ref->u.ss.start->value.integer); |
| if (end >= start) |
| length = end - start + 1; |
| else |
| length = 0; |
| |
| chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1); |
| (*newp)->value.character.length = length; |
| memcpy (chr, &p->value.character.string[start - 1], |
| length * sizeof (gfc_char_t)); |
| chr[length] = '\0'; |
| return true; |
| } |
| |
| |
| /* Pull an inquiry result out of an expression. */ |
| |
| static bool |
| find_inquiry_ref (gfc_expr *p, gfc_expr **newp) |
| { |
| gfc_ref *ref; |
| gfc_ref *inquiry = NULL; |
| gfc_expr *tmp; |
| |
| tmp = gfc_copy_expr (p); |
| |
| if (tmp->ref && tmp->ref->type == REF_INQUIRY) |
| { |
| inquiry = tmp->ref; |
| tmp->ref = NULL; |
| } |
| else |
| { |
| for (ref = tmp->ref; ref; ref = ref->next) |
| if (ref->next && ref->next->type == REF_INQUIRY) |
| { |
| inquiry = ref->next; |
| ref->next = NULL; |
| } |
| } |
| |
| if (!inquiry) |
| { |
| gfc_free_expr (tmp); |
| return false; |
| } |
| |
| gfc_resolve_expr (tmp); |
| |
| /* In principle there can be more than one inquiry reference. */ |
| for (; inquiry; inquiry = inquiry->next) |
| { |
| switch (inquiry->u.i) |
| { |
| case INQUIRY_LEN: |
| if (tmp->ts.type != BT_CHARACTER) |
| goto cleanup; |
| |
| if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C")) |
| goto cleanup; |
| |
| if (tmp->ts.u.cl->length |
| && tmp->ts.u.cl->length->expr_type == EXPR_CONSTANT) |
| *newp = gfc_copy_expr (tmp->ts.u.cl->length); |
| else if (tmp->expr_type == EXPR_CONSTANT) |
| *newp = gfc_get_int_expr (gfc_default_integer_kind, |
| NULL, tmp->value.character.length); |
| else |
| goto cleanup; |
| |
| break; |
| |
| case INQUIRY_KIND: |
| if (tmp->ts.type == BT_DERIVED || tmp->ts.type == BT_CLASS) |
| goto cleanup; |
| |
| if (!gfc_notify_std (GFC_STD_F2003, "KIND part_ref at %C")) |
| goto cleanup; |
| |
| *newp = gfc_get_int_expr (gfc_default_integer_kind, |
| NULL, tmp->ts.kind); |
| break; |
| |
| case INQUIRY_RE: |
| if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT) |
| goto cleanup; |
| |
| if (!gfc_notify_std (GFC_STD_F2008, "RE part_ref at %C")) |
| goto cleanup; |
| |
| *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where); |
| mpfr_set ((*newp)->value.real, |
| mpc_realref (tmp->value.complex), GFC_RND_MODE); |
| break; |
| |
| case INQUIRY_IM: |
| if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT) |
| goto cleanup; |
| |
| if (!gfc_notify_std (GFC_STD_F2008, "IM part_ref at %C")) |
| goto cleanup; |
| |
| *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where); |
| mpfr_set ((*newp)->value.real, |
| mpc_imagref (tmp->value.complex), GFC_RND_MODE); |
| break; |
| } |
| tmp = gfc_copy_expr (*newp); |
| } |
| |
| if (!(*newp)) |
| goto cleanup; |
| else if ((*newp)->expr_type != EXPR_CONSTANT) |
| { |
| gfc_free_expr (*newp); |
| goto cleanup; |
| } |
| |
| gfc_free_expr (tmp); |
| return true; |
| |
| cleanup: |
| gfc_free_expr (tmp); |
| return false; |
| } |
| |
| |
| |
| /* Simplify a subobject reference of a constructor. This occurs when |
| parameter variable values are substituted. */ |
| |
| static bool |
| simplify_const_ref (gfc_expr *p) |
| { |
| gfc_constructor *cons, *c; |
| gfc_expr *newp = NULL; |
| gfc_ref *last_ref; |
| |
| while (p->ref) |
| { |
| switch (p->ref->type) |
| { |
| case REF_ARRAY: |
| switch (p->ref->u.ar.type) |
| { |
| case AR_ELEMENT: |
| /* <type/kind spec>, parameter :: x(<int>) = scalar_expr |
| will generate this. */ |
| if (p->expr_type != EXPR_ARRAY) |
| { |
| remove_subobject_ref (p, NULL); |
| break; |
| } |
| if (!find_array_element (p->value.constructor, &p->ref->u.ar, &cons)) |
| return false; |
| |
| if (!cons) |
| return true; |
| |
| remove_subobject_ref (p, cons); |
| break; |
| |
| case AR_SECTION: |
| if (!find_array_section (p, p->ref)) |
| return false; |
| p->ref->u.ar.type = AR_FULL; |
| |
| /* Fall through. */ |
| |
| case AR_FULL: |
| if (p->ref->next != NULL |
| && (p->ts.type == BT_CHARACTER || gfc_bt_struct (p->ts.type))) |
| { |
| for (c = gfc_constructor_first (p->value.constructor); |
| c; c = gfc_constructor_next (c)) |
| { |
| c->expr->ref = gfc_copy_ref (p->ref->next); |
| if (!simplify_const_ref (c->expr)) |
| return false; |
| } |
| |
| if (gfc_bt_struct (p->ts.type) |
| && p->ref->next |
| && (c = gfc_constructor_first (p->value.constructor))) |
| { |
| /* There may have been component references. */ |
| p->ts = c->expr->ts; |
| } |
| |
| last_ref = p->ref; |
| for (; last_ref->next; last_ref = last_ref->next) {}; |
| |
| if (p->ts.type == BT_CHARACTER |
| && last_ref->type == REF_SUBSTRING) |
| { |
| /* If this is a CHARACTER array and we possibly took |
| a substring out of it, update the type-spec's |
| character length according to the first element |
| (as all should have the same length). */ |
| gfc_charlen_t string_len; |
| if ((c = gfc_constructor_first (p->value.constructor))) |
| { |
| const gfc_expr* first = c->expr; |
| gcc_assert (first->expr_type == EXPR_CONSTANT); |
| gcc_assert (first->ts.type == BT_CHARACTER); |
| string_len = first->value.character.length; |
| } |
| else |
| string_len = 0; |
| |
| if (!p->ts.u.cl) |
| { |
| if (p->symtree) |
| p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns, |
| NULL); |
| else |
| p->ts.u.cl = gfc_new_charlen (gfc_current_ns, |
| NULL); |
| } |
| else |
| gfc_free_expr (p->ts.u.cl->length); |
| |
| p->ts.u.cl->length |
| = gfc_get_int_expr (gfc_charlen_int_kind, |
| NULL, string_len); |
| } |
| } |
| gfc_free_ref_list (p->ref); |
| p->ref = NULL; |
| break; |
| |
| default: |
| return true; |
| } |
| |
| break; |
| |
| case REF_COMPONENT: |
| cons = find_component_ref (p->value.constructor, p->ref); |
| remove_subobject_ref (p, cons); |
| break; |
| |
| case REF_INQUIRY: |
| if (!find_inquiry_ref (p, &newp)) |
| return false; |
| |
| gfc_replace_expr (p, newp); |
| gfc_free_ref_list (p->ref); |
| p->ref = NULL; |
| break; |
| |
| case REF_SUBSTRING: |
| if (!find_substring_ref (p, &newp)) |
| return false; |
| |
| gfc_replace_expr (p, newp); |
| gfc_free_ref_list (p->ref); |
| p->ref = NULL; |
| break; |
| } |
| } |
| |
| return true; |
| } |
| |
| |
| /* Simplify a chain of references. */ |
| |
| static bool |
| simplify_ref_chain (gfc_ref *ref, int type, gfc_expr **p) |
| { |
| int n; |
| gfc_expr *newp; |
| |
| for (; ref; ref = ref->next) |
| { |
| switch (ref->type) |
| { |
| case REF_ARRAY: |
| for (n = 0; n < ref->u.ar.dimen; n++) |
| { |
| if (!gfc_simplify_expr (ref->u.ar.start[n], type)) |
| return false; |
| if (!gfc_simplify_expr (ref->u.ar.end[n], type)) |
| return false; |
| if (!gfc_simplify_expr (ref->u.ar.stride[n], type)) |
| return false; |
| } |
| break; |
| |
| case REF_SUBSTRING: |
| if (!gfc_simplify_expr (ref->u.ss.start, type)) |
| return false; |
| if (!gfc_simplify_expr (ref->u.ss.end, type)) |
| return false; |
| break; |
| |
| case REF_INQUIRY: |
| if (!find_inquiry_ref (*p, &newp)) |
| return false; |
| |
| gfc_replace_expr (*p, newp); |
| gfc_free_ref_list ((*p)->ref); |
| (*p)->ref = NULL; |
| return true; |
| |
| default: |
| break; |
| } |
| } |
| return true; |
| } |
| |
| |
| /* Try to substitute the value of a parameter variable. */ |
| |
| static bool |
| simplify_parameter_variable (gfc_expr *p, int type) |
| { |
| gfc_expr *e; |
| bool t; |
| |
| /* Set rank and check array ref; as resolve_variable calls |
| gfc_simplify_expr, call gfc_resolve_ref + gfc_expression_rank instead. */ |
| if (!gfc_resolve_ref (p)) |
| { |
| gfc_error_check (); |
| return false; |
| } |
| gfc_expression_rank (p); |
| |
| /* Is this an inquiry? */ |
| bool inquiry = false; |
| gfc_ref* ref = p->ref; |
| while (ref) |
| { |
| if (ref->type == REF_INQUIRY) |
| break; |
| ref = ref->next; |
| } |
| if (ref && ref->type == REF_INQUIRY) |
| inquiry = ref->u.i == INQUIRY_LEN || ref->u.i == INQUIRY_KIND; |
| |
| if (gfc_is_size_zero_array (p)) |
| { |
| if (p->expr_type == EXPR_ARRAY) |
| return true; |
| |
| e = gfc_get_expr (); |
| e->expr_type = EXPR_ARRAY; |
| e->ts = p->ts; |
| e->rank = p->rank; |
| e->value.constructor = NULL; |
| e->shape = gfc_copy_shape (p->shape, p->rank); |
| e->where = p->where; |
| /* If %kind and %len are not used then we're done, otherwise |
| drop through for simplification. */ |
| if (!inquiry) |
| { |
| gfc_replace_expr (p, e); |
| return true; |
| } |
| } |
| else |
| { |
| e = gfc_copy_expr (p->symtree->n.sym->value); |
| if (e == NULL) |
| return false; |
| |
| gfc_free_shape (&e->shape, e->rank); |
| e->shape = gfc_copy_shape (p->shape, p->rank); |
| e->rank = p->rank; |
| |
| if (e->ts.type == BT_CHARACTER && p->ts.u.cl) |
| e->ts = p->ts; |
| } |
| |
| if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL) |
| e->ts.u.cl = gfc_new_charlen (gfc_current_ns, p->ts.u.cl); |
| |
| /* Do not copy subobject refs for constant. */ |
| if (e->expr_type != EXPR_CONSTANT && p->ref != NULL) |
| e->ref = gfc_copy_ref (p->ref); |
| t = gfc_simplify_expr (e, type); |
| e->where = p->where; |
| |
| /* Only use the simplification if it eliminated all subobject references. */ |
| if (t && !e->ref) |
| gfc_replace_expr (p, e); |
| else |
| gfc_free_expr (e); |
| |
| return t; |
| } |
| |
| |
| static bool |
| scalarize_intrinsic_call (gfc_expr *, bool init_flag); |
| |
| /* Given an expression, simplify it by collapsing constant |
| expressions. Most simplification takes place when the expression |
| tree is being constructed. If an intrinsic function is simplified |
| at some point, we get called again to collapse the result against |
| other constants. |
| |
| We work by recursively simplifying expression nodes, simplifying |
| intrinsic functions where possible, which can lead to further |
| constant collapsing. If an operator has constant operand(s), we |
| rip the expression apart, and rebuild it, hoping that it becomes |
| something simpler. |
| |
| The expression type is defined for: |
| 0 Basic expression parsing |
| 1 Simplifying array constructors -- will substitute |
| iterator values. |
| Returns false on error, true otherwise. |
| NOTE: Will return true even if the expression cannot be simplified. */ |
| |
| bool |
| gfc_simplify_expr (gfc_expr *p, int type) |
| { |
| gfc_actual_arglist *ap; |
| gfc_intrinsic_sym* isym = NULL; |
| |
| |
| if (p == NULL) |
| return true; |
| |
| switch (p->expr_type) |
| { |
| case EXPR_CONSTANT: |
| if (p->ref && p->ref->type == REF_INQUIRY) |
| simplify_ref_chain (p->ref, type, &p); |
| break; |
| case EXPR_NULL: |
| break; |
| |
| case EXPR_FUNCTION: |
| // For array-bound functions, we don't need to optimize |
| // the 'array' argument. In particular, if the argument |
| // is a PARAMETER, simplifying might convert an EXPR_VARIABLE |
| // into an EXPR_ARRAY; the latter has lbound = 1, the former |
| // can have any lbound. |
| ap = p->value.function.actual; |
| if (p->value.function.isym && |
| (p->value.function.isym->id == GFC_ISYM_LBOUND |
| || p->value.function.isym->id == GFC_ISYM_UBOUND |
| || p->value.function.isym->id == GFC_ISYM_LCOBOUND |
| || p->value.function.isym->id == GFC_ISYM_UCOBOUND)) |
| ap = ap->next; |
| |
| for ( ; ap; ap = ap->next) |
| if (!gfc_simplify_expr (ap->expr, type)) |
| return false; |
| |
| if (p->value.function.isym != NULL |
| && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR) |
| return false; |
| |
| if (p->symtree && (p->value.function.isym || p->ts.type == BT_UNKNOWN)) |
| { |
| isym = gfc_find_function (p->symtree->n.sym->name); |
| if (isym && isym->elemental) |
| scalarize_intrinsic_call (p, false); |
| } |
| |
| break; |
| |
| case EXPR_SUBSTRING: |
| if (!simplify_ref_chain (p->ref, type, &p)) |
| return false; |
| |
| if (gfc_is_constant_expr (p)) |
| { |
| gfc_char_t *s; |
| HOST_WIDE_INT start, end; |
| |
| start = 0; |
| if (p->ref && p->ref->u.ss.start) |
| { |
| gfc_extract_hwi (p->ref->u.ss.start, &start); |
| start--; /* Convert from one-based to zero-based. */ |
| } |
| |
| end = p->value.character.length; |
| if (p->ref && p->ref->u.ss.end) |
| gfc_extract_hwi (p->ref->u.ss.end, &end); |
| |
| if (end < start) |
| end = start; |
| |
| s = gfc_get_wide_string (end - start + 2); |
| memcpy (s, p->value.character.string + start, |
| (end - start) * sizeof (gfc_char_t)); |
| s[end - start + 1] = '\0'; /* TODO: C-style string. */ |
| free (p->value.character.string); |
| p->value.character.string = s; |
| p->value.character.length = end - start; |
| p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); |
| p->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, |
| NULL, |
| p->value.character.length); |
| gfc_free_ref_list (p->ref); |
| p->ref = NULL; |
| p->expr_type = EXPR_CONSTANT; |
| } |
| break; |
| |
| case EXPR_OP: |
| if (!simplify_intrinsic_op (p, type)) |
| return false; |
| break; |
| |
| case EXPR_VARIABLE: |
| /* Only substitute array parameter variables if we are in an |
| initialization expression, or we want a subsection. */ |
| if (p->symtree->n.sym->attr.flavor == FL_PARAMETER |
| && (gfc_init_expr_flag || p->ref |
| || (p->symtree->n.sym->value |
| && p->symtree->n.sym->value->expr_type != EXPR_ARRAY))) |
| { |
| if (!simplify_parameter_variable (p, type)) |
| return false; |
| break; |
| } |
| |
| if (type == 1) |
| { |
| gfc_simplify_iterator_var (p); |
| } |
| |
| /* Simplify subcomponent references. */ |
| if (!simplify_ref_chain (p->ref, type, &p)) |
| return false; |
| |
| break; |
| |
| case EXPR_STRUCTURE: |
| case EXPR_ARRAY: |
| if (!simplify_ref_chain (p->ref, type, &p)) |
| return false; |
| |
| /* If the following conditions hold, we found something like kind type |
| inquiry of the form a(2)%kind while simplify the ref chain. */ |
| if (p->expr_type == EXPR_CONSTANT && !p->ref && !p->rank && !p->shape) |
| return true; |
| |
| if (!simplify_constructor (p->value.constructor, type)) |
| return false; |
| |
| if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY |
| && p->ref->u.ar.type == AR_FULL) |
| gfc_expand_constructor (p, false); |
| |
| if (!simplify_const_ref (p)) |
| return false; |
| |
| break; |
| |
| case EXPR_COMPCALL: |
| case EXPR_PPC: |
| break; |
| |
| case EXPR_UNKNOWN: |
| gcc_unreachable (); |
| } |
| |
| return true; |
| } |
| |
| |
| /* Try simplification of an expression via gfc_simplify_expr. |
| When an error occurs (arithmetic or otherwise), roll back. */ |
| |
| bool |
| gfc_try_simplify_expr (gfc_expr *e, int type) |
| { |
| gfc_expr *n; |
| bool t, saved_div0; |
| |
| if (e == NULL || e->expr_type == EXPR_CONSTANT) |
| return true; |
| |
| saved_div0 = gfc_seen_div0; |
| gfc_seen_div0 = false; |
| n = gfc_copy_expr (e); |
| t = gfc_simplify_expr (n, type) && !gfc_seen_div0; |
| if (t) |
| gfc_replace_expr (e, n); |
| else |
| gfc_free_expr (n); |
| gfc_seen_div0 = saved_div0; |
| return t; |
| } |
| |
| |
| /* Returns the type of an expression with the exception that iterator |
| variables are automatically integers no matter what else they may |
| be declared as. */ |
| |
| static bt |
| et0 (gfc_expr *e) |
| { |
| if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e)) |
| return BT_INTEGER; |
| |
| return e->ts.type; |
| } |
| |
| |
| /* Scalarize an expression for an elemental intrinsic call. */ |
| |
| static bool |
| scalarize_intrinsic_call (gfc_expr *e, bool init_flag) |
| { |
| gfc_actual_arglist *a, *b; |
| gfc_constructor_base ctor; |
| gfc_constructor *args[5] = {}; /* Avoid uninitialized warnings. */ |
| gfc_constructor *ci, *new_ctor; |
| gfc_expr *expr, *old, *p; |
| int n, i, rank[5], array_arg; |
| |
| if (e == NULL) |
| return false; |
| |
| a = e->value.function.actual; |
| for (; a; a = a->next) |
| if (a->expr && !gfc_is_constant_expr (a->expr)) |
| return false; |
| |
| /* Find which, if any, arguments are arrays. Assume that the old |
| expression carries the type information and that the first arg |
| that is an array expression carries all the shape information.*/ |
| n = array_arg = 0; |
| a = e->value.function.actual; |
| for (; a; a = a->next) |
| { |
| n++; |
| if (!a->expr || a->expr->expr_type != EXPR_ARRAY) |
| continue; |
| array_arg = n; |
| expr = gfc_copy_expr (a->expr); |
| break; |
| } |
| |
| if (!array_arg) |
| return false; |
| |
| old = gfc_copy_expr (e); |
| |
| gfc_constructor_free (expr->value.constructor); |
| expr->value.constructor = NULL; |
| expr->ts = old->ts; |
| expr->where = old->where; |
| expr->expr_type = EXPR_ARRAY; |
| |
| /* Copy the array argument constructors into an array, with nulls |
| for the scalars. */ |
| n = 0; |
| a = old->value.function.actual; |
| for (; a; a = a->next) |
| { |
| /* Check that this is OK for an initialization expression. */ |
| if (a->expr && init_flag && !gfc_check_init_expr (a->expr)) |
| goto cleanup; |
| |
| rank[n] = 0; |
| if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE) |
| { |
| rank[n] = a->expr->rank; |
| ctor = a->expr->symtree->n.sym->value->value.constructor; |
| args[n] = gfc_constructor_first (ctor); |
| } |
| else if (a->expr && a->expr->expr_type == EXPR_ARRAY) |
| { |
| if (a->expr->rank) |
| rank[n] = a->expr->rank; |
| else |
| rank[n] = 1; |
| ctor = gfc_constructor_copy (a->expr->value.constructor); |
| args[n] = gfc_constructor_first (ctor); |
| } |
| else |
| args[n] = NULL; |
| |
| n++; |
| } |
| |
| /* Using the array argument as the master, step through the array |
| calling the function for each element and advancing the array |
| constructors together. */ |
| for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci)) |
| { |
| new_ctor = gfc_constructor_append_expr (&expr->value.constructor, |
| gfc_copy_expr (old), NULL); |
| |
| gfc_free_actual_arglist (new_ctor->expr->value.function.actual); |
| a = NULL; |
| b = old->value.function.actual; |
| for (i = 0; i < n; i++) |
| { |
| if (a == NULL) |
| new_ctor->expr->value.function.actual |
| = a = gfc_get_actual_arglist (); |
| else |
| { |
| a->next = gfc_get_actual_arglist (); |
| a = a->next; |
| } |
| |
| if (args[i]) |
| a->expr = gfc_copy_expr (args[i]->expr); |
| else |
| a->expr = gfc_copy_expr (b->expr); |
| |
| b = b->next; |
| } |
| |
| /* Simplify the function calls. If the simplification fails, the |
| error will be flagged up down-stream or the library will deal |
| with it. */ |
| p = gfc_copy_expr (new_ctor->expr); |
| |
| if (!gfc_simplify_expr (p, init_flag)) |
| gfc_free_expr (p); |
| else |
| gfc_replace_expr (new_ctor->expr, p); |
| |
| for (i = 0; i < n; i++) |
| if (args[i]) |
| args[i] = gfc_constructor_next (args[i]); |
| |
| for (i = 1; i < n; i++) |
| if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL) |
| || (args[i] == NULL && args[array_arg - 1] != NULL))) |
| goto compliance; |
| } |
| |
| free_expr0 (e); |
| *e = *expr; |
| /* Free "expr" but not the pointers it contains. */ |
| free (expr); |
| gfc_free_expr (old); |
| return true; |
| |
| compliance: |
| gfc_error_now ("elemental function arguments at %C are not compliant"); |
| |
| cleanup: |
| gfc_free_expr (expr); |
| gfc_free_expr (old); |
| return false; |
| } |
| |
| |
| static bool |
| check_intrinsic_op (gfc_expr *e, bool (*check_function) (gfc_expr *)) |
| { |
| gfc_expr *op1 = e->value.op.op1; |
| gfc_expr *op2 = e->value.op.op2; |
| |
| if (!(*check_function)(op1)) |
| return false; |
| |
| switch (e->value.op.op) |
| { |
| case INTRINSIC_UPLUS: |
| case INTRINSIC_UMINUS: |
| if (!numeric_type (et0 (op1))) |
| goto not_numeric; |
| break; |
| |
| case INTRINSIC_EQ: |
| case INTRINSIC_EQ_OS: |
| case INTRINSIC_NE: |
| case INTRINSIC_NE_OS: |
| case INTRINSIC_GT: |
| case INTRINSIC_GT_OS: |
| case INTRINSIC_GE: |
| case INTRINSIC_GE_OS: |
| case INTRINSIC_LT: |
| case INTRINSIC_LT_OS: |
| case INTRINSIC_LE: |
| case INTRINSIC_LE_OS: |
| if (!(*check_function)(op2)) |
| return false; |
| |
| if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER) |
| && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2)))) |
| { |
| gfc_error ("Numeric or CHARACTER operands are required in " |
| "expression at %L", &e->where); |
| return false; |
| } |
| break; |
| |
| case INTRINSIC_PLUS: |
| case INTRINSIC_MINUS: |
| case INTRINSIC_TIMES: |
| case INTRINSIC_DIVIDE: |
| case INTRINSIC_POWER: |
| if (!(*check_function)(op2)) |
| return false; |
| |
| if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2))) |
| goto not_numeric; |
| |
| break; |
| |
| case INTRINSIC_CONCAT: |
| if (!(*check_function)(op2)) |
| return false; |
| |
| if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER) |
| { |
| gfc_error ("Concatenation operator in expression at %L " |
| "must have two CHARACTER operands", &op1->where); |
| return false; |
| } |
| |
| if (op1->ts.kind != op2->ts.kind) |
| { |
| gfc_error ("Concat operator at %L must concatenate strings of the " |
| "same kind", &e->where); |
| return false; |
| } |
| |
| break; |
| |
| case INTRINSIC_NOT: |
| if (et0 (op1) != BT_LOGICAL) |
| { |
| gfc_error (".NOT. operator in expression at %L must have a LOGICAL " |
| "operand", &op1->where); |
| return false; |
| } |
| |
| break; |
| |
| case INTRINSIC_AND: |
| case INTRINSIC_OR: |
| case INTRINSIC_EQV: |
| case INTRINSIC_NEQV: |
| if (!(*check_function)(op2)) |
| return false; |
| |
| if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL) |
| { |
| gfc_error ("LOGICAL operands are required in expression at %L", |
| &e->where); |
| return false; |
| } |
| |
| break; |
| |
| case INTRINSIC_PARENTHESES: |
| break; |
| |
| default: |
| gfc_error ("Only intrinsic operators can be used in expression at %L", |
| &e->where); |
| return false; |
| } |
| |
| return true; |
| |
| not_numeric: |
| gfc_error ("Numeric operands are required in expression at %L", &e->where); |
| |
| return false; |
| } |
| |
| /* F2003, 7.1.7 (3): In init expression, allocatable components |
| must not be data-initialized. */ |
| static bool |
| check_alloc_comp_init (gfc_expr *e) |
| { |
| gfc_component *comp; |
| gfc_constructor *ctor; |
| |
| gcc_assert (e->expr_type == EXPR_STRUCTURE); |
| gcc_assert (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS); |
| |
| for (comp = e->ts.u.derived->components, |
| ctor = gfc_constructor_first (e->value.constructor); |
| comp; comp = comp->next, ctor = gfc_constructor_next (ctor)) |
| { |
| if (comp->attr.allocatable && ctor->expr |
| && ctor->expr->expr_type != EXPR_NULL) |
| { |
| gfc_error ("Invalid initialization expression for ALLOCATABLE " |
| "component %qs in structure constructor at %L", |
| comp->name, &ctor->expr->where); |
| return false; |
| } |
| } |
| |
| return true; |
| } |
| |
| static match |
| check_init_expr_arguments (gfc_expr *e) |
| { |
| gfc_actual_arglist *ap; |
| |
| for (ap = e->value.function.actual; ap; ap = ap->next) |
| if (!gfc_check_init_expr (ap->expr)) |
| return MATCH_ERROR; |
| |
| return MATCH_YES; |
| } |
| |
| static bool check_restricted (gfc_expr *); |
| |
| /* F95, 7.1.6.1, Initialization expressions, (7) |
| F2003, 7.1.7 Initialization expression, (8) |
| F2008, 7.1.12 Constant expression, (4) */ |
| |
| static match |
| check_inquiry (gfc_expr *e, int not_restricted) |
| { |
| const char *name; |
| const char *const *functions; |
| |
| static const char *const inquiry_func_f95[] = { |
| "lbound", "shape", "size", "ubound", |
| "bit_size", "len", "kind", |
| "digits", "epsilon", "huge", "maxexponent", "minexponent", |
| "precision", "radix", "range", "tiny", |
| NULL |
| }; |
| |
| static const char *const inquiry_func_f2003[] = { |
| "lbound", "shape", "size", "ubound", |
| "bit_size", "len", "kind", |
| "digits", "epsilon", "huge", "maxexponent", "minexponent", |
| "precision", "radix", "range", "tiny", |
| "new_line", NULL |
| }; |
| |
| /* std=f2008+ or -std=gnu */ |
| static const char *const inquiry_func_gnu[] = { |
| "lbound", "shape", "size", "ubound", |
| "bit_size", "len", "kind", |
| "digits", "epsilon", "huge", "maxexponent", "minexponent", |
| "precision", "radix", "range", "tiny", |
| "new_line", "storage_size", NULL |
| }; |
| |
| int i = 0; |
| gfc_actual_arglist *ap; |
| gfc_symbol *sym; |
| gfc_symbol *asym; |
| |
| if (!e->value.function.isym |
| || !e->value.function.isym->inquiry) |
| return MATCH_NO; |
| |
| /* An undeclared parameter will get us here (PR25018). */ |
| if (e->symtree == NULL) |
| return MATCH_NO; |
| |
| sym = e->symtree->n.sym; |
| |
| if (sym->from_intmod) |
| { |
| if (sym->from_intmod == INTMOD_ISO_FORTRAN_ENV |
| && sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS |
| && sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION) |
| return MATCH_NO; |
| |
| if (sym->from_intmod == INTMOD_ISO_C_BINDING |
| && sym->intmod_sym_id != ISOCBINDING_C_SIZEOF) |
| return MATCH_NO; |
| } |
| else |
| { |
| name = sym->name; |
| |
| functions = inquiry_func_gnu; |
| if (gfc_option.warn_std & GFC_STD_F2003) |
| functions = inquiry_func_f2003; |
| if (gfc_option.warn_std & GFC_STD_F95) |
| functions = inquiry_func_f95; |
| |
| for (i = 0; functions[i]; i++) |
| if (strcmp (functions[i], name) == 0) |
| break; |
| |
| if (functions[i] == NULL) |
| return MATCH_ERROR; |
| } |
| |
| /* At this point we have an inquiry function with a variable argument. The |
| type of the variable might be undefined, but we need it now, because the |
| arguments of these functions are not allowed to be undefined. */ |
| |
| for (ap = e->value.function.actual; ap; ap = ap->next) |
| { |
| if (!ap->expr) |
| continue; |
| |
| asym = ap->expr->symtree ? ap->expr->symtree->n.sym : NULL; |
| |
| if (ap->expr->ts.type == BT_UNKNOWN) |
| { |
| if (asym && asym->ts.type == BT_UNKNOWN |
| && !gfc_set_default_type (asym, 0, gfc_current_ns)) |
| return MATCH_NO; |
| |
| ap->expr->ts = asym->ts; |
| } |
| |
| if (asym && asym->assoc && asym->assoc->target |
| && asym->assoc->target->expr_type == EXPR_CONSTANT) |
| { |
| gfc_free_expr (ap->expr); |
| ap->expr = gfc_copy_expr (asym->assoc->target); |
| } |
| |
| /* Assumed character length will not reduce to a constant expression |
| with LEN, as required by the standard. */ |
| if (i == 5 && not_restricted && asym |
| && asym->ts.type == BT_CHARACTER |
| && ((asym->ts.u.cl && asym->ts.u.cl->length == NULL) |
| || asym->ts.deferred)) |
| { |
| gfc_error ("Assumed or deferred character length variable %qs " |
| "in constant expression at %L", |
| asym->name, &ap->expr->where); |
| return MATCH_ERROR; |
| } |
| else if (not_restricted && !gfc_check_init_expr (ap->expr)) |
| return MATCH_ERROR; |
| |
| if (not_restricted == 0 |
| && ap->expr->expr_type != EXPR_VARIABLE |
| && !check_restricted (ap->expr)) |
| return MATCH_ERROR; |
| |
| if (not_restricted == 0 |
| && ap->expr->expr_type == EXPR_VARIABLE |
| && asym->attr.dummy && asym->attr.optional) |
| return MATCH_NO; |
| } |
| |
| return MATCH_YES; |
| } |
| |
| |
| /* F95, 7.1.6.1, Initialization expressions, (5) |
| F2003, 7.1.7 Initialization expression, (5) */ |
| |
| static match |
| check_transformational (gfc_expr *e) |
| { |
| static const char * const trans_func_f95[] = { |
| "repeat", "reshape", "selected_int_kind", |
| "selected_real_kind", "transfer", "trim", NULL |
| }; |
| |
| static const char * const trans_func_f2003[] = { |
| "all", "any", "count", "dot_product", "matmul", "null", "pack", |
| "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind", |
| "selected_real_kind", "spread", "sum", "transfer", "transpose", |
| "trim", "unpack", NULL |
| }; |
| |
| static const char * const trans_func_f2008[] = { |
| "all", "any", "count", "dot_product", "matmul", "null", "pack", |
| "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind", |
| "selected_real_kind", "spread", "sum", "transfer", "transpose", |
| "trim", "unpack", "findloc", NULL |
| }; |
| |
| int i; |
| const char *name; |
| const char *const *functions; |
| |
| if (!e->value.function.isym |
| || !e->value.function.isym->transformational) |
| return MATCH_NO; |
| |
| name = e->symtree->n.sym->name; |
| |
| if (gfc_option.allow_std & GFC_STD_F2008) |
| functions = trans_func_f2008; |
| else if (gfc_option.allow_std & GFC_STD_F2003) |
| functions = trans_func_f2003; |
| else |
| functions = trans_func_f95; |
| |
| /* NULL() is dealt with below. */ |
| if (strcmp ("null", name) == 0) |
| return MATCH_NO; |
| |
| for (i = 0; functions[i]; i++) |
| if (strcmp (functions[i], name) == 0) |
| break; |
| |
| if (functions[i] == NULL) |
| { |
| gfc_error ("transformational intrinsic %qs at %L is not permitted " |
| "in an initialization expression", name, &e->where); |
| return MATCH_ERROR; |
| } |
| |
| return check_init_expr_arguments (e); |
| } |
| |
| |
| /* F95, 7.1.6.1, Initialization expressions, (6) |
| F2003, 7.1.7 Initialization expression, (6) */ |
| |
| static match |
| check_null (gfc_expr *e) |
| { |
| if (strcmp ("null", e->symtree->n.sym->name) != 0) |
| return MATCH_NO; |
| |
| return check_init_expr_arguments (e); |
| } |
| |
| |
| static match |
| check_elemental (gfc_expr *e) |
| { |
| if (!e->value.function.isym |
| || !e->value.function.isym->elemental) |
| return MATCH_NO; |
| |
| if (e->ts.type != BT_INTEGER |
| && e->ts.type != BT_CHARACTER |
| && !gfc_notify_std (GFC_STD_F2003, "Evaluation of nonstandard " |
| "initialization expression at %L", &e->where)) |
| return MATCH_ERROR; |
| |
| return check_init_expr_arguments (e); |
| } |
| |
| |
| static match |
| check_conversion (gfc_expr *e) |
| { |
| if (!e->value.function.isym |
| || !e->value.function.isym->conversion) |
| return MATCH_NO; |
| |
| return check_init_expr_arguments (e); |
| } |
| |
| |
| /* Verify that an expression is an initialization expression. A side |
| effect is that the expression tree is reduced to a single constant |
| node if all goes well. This would normally happen when the |
| expression is constructed but function references are assumed to be |
| intrinsics in the context of initialization expressions. If |
| false is returned an error message has been generated. */ |
| |
| bool |
| gfc_check_init_expr (gfc_expr *e) |
| { |
| match m; |
| bool t; |
| |
| if (e == NULL) |
| return true; |
| |
| switch (e->expr_type) |
| { |
| case EXPR_OP: |
| t = check_intrinsic_op (e, gfc_check_init_expr); |
| if (t) |
| t = gfc_simplify_expr (e, 0); |
| |
| break; |
| |
| case EXPR_FUNCTION: |
| t = false; |
| |
| { |
| bool conversion; |
| gfc_intrinsic_sym* isym = NULL; |
| gfc_symbol* sym = e->symtree->n.sym; |
| |
| /* Simplify here the intrinsics from the IEEE_ARITHMETIC and |
| IEEE_EXCEPTIONS modules. */ |
| int mod = sym->from_intmod; |
| if (mod == INTMOD_NONE && sym->generic) |
| mod = sym->generic->sym->from_intmod; |
| if (mod == INTMOD_IEEE_ARITHMETIC || mod == INTMOD_IEEE_EXCEPTIONS) |
| { |
| gfc_expr *new_expr = gfc_simplify_ieee_functions (e); |
| if (new_expr) |
| { |
| gfc_replace_expr (e, new_expr); |
| t = true; |
| break; |
| } |
| } |
| |
| /* If a conversion function, e.g., __convert_i8_i4, was inserted |
| into an array constructor, we need to skip the error check here. |
| Conversion errors are caught below in scalarize_intrinsic_call. */ |
| conversion = e->value.function.isym |
| && (e->value.function.isym->conversion == 1); |
| |
| if (!conversion && (!gfc_is_intrinsic (sym, 0, e->where) |
| || (m = gfc_intrinsic_func_interface (e, 0)) == MATCH_NO)) |
| { |
| gfc_error ("Function %qs in initialization expression at %L " |
| "must be an intrinsic function", |
| e->symtree->n.sym->name, &e->where); |
| break; |
| } |
| |
| if ((m = check_conversion (e)) == MATCH_NO |
| && (m = check_inquiry (e, 1)) == MATCH_NO |
| && (m = check_null (e)) == MATCH_NO |
| && (m = check_transformational (e)) == MATCH_NO |
| && (m = check_elemental (e)) == MATCH_NO) |
| { |
| gfc_error ("Intrinsic function %qs at %L is not permitted " |
| "in an initialization expression", |
| e->symtree->n.sym->name, &e->where); |
| m = MATCH_ERROR; |
| } |
| |
| if (m == MATCH_ERROR) |
| return false; |
| |
| /* Try to scalarize an elemental intrinsic function that has an |
| array argument. */ |
| isym = gfc_find_function (e->symtree->n.sym->name); |
| if (isym && isym->elemental |
| && (t = scalarize_intrinsic_call (e, true))) |
| break; |
| } |
| |
| if (m == MATCH_YES) |
| t = gfc_simplify_expr (e, 0); |
| |
| break; |
| |
| case EXPR_VARIABLE: |
| t = true; |
| |
| /* This occurs when parsing pdt templates. */ |
| if (gfc_expr_attr (e).pdt_kind) |
| break; |
| |
| if (gfc_check_iter_variable (e)) |
| break; |
| |
| if (e->symtree->n.sym->attr.flavor == FL_PARAMETER) |
| { |
| /* A PARAMETER shall not be used to define itself, i.e. |
| REAL, PARAMETER :: x = transfer(0, x) |
| is invalid. */ |
| if (!e->symtree->n.sym->value) |
| { |
| gfc_error ("PARAMETER %qs is used at %L before its definition " |
| "is complete", e->symtree->n.sym->name, &e->where); |
| t = false; |
| } |
| else |
| t = simplify_parameter_variable (e, 0); |
| |
| break; |
| } |
| |
| if (gfc_in_match_data ()) |
| break; |
| |
| t = false; |
| |
| if (e->symtree->n.sym->as) |
| { |
| switch (e->symtree->n.sym->as->type) |
| { |
| case AS_ASSUMED_SIZE: |
| gfc_error ("Assumed size array %qs at %L is not permitted " |
| "in an initialization expression", |
| e->symtree->n.sym->name, &e->where); |
| break; |
| |
| case AS_ASSUMED_SHAPE: |
| gfc_error ("Assumed shape array %qs at %L is not permitted " |
| "in an initialization expression", |
| e->symtree->n.sym->name, &e->where); |
| break; |
| |
| case AS_DEFERRED: |
| if (!e->symtree->n.sym->attr.allocatable |
| && !e->symtree->n.sym->attr.pointer |
| && e->symtree->n.sym->attr.dummy) |
| gfc_error ("Assumed-shape array %qs at %L is not permitted " |
| "in an initialization expression", |
| e->symtree->n.sym->name, &e->where); |
| else |
| gfc_error ("Deferred array %qs at %L is not permitted " |
| "in an initialization expression", |
| e->symtree->n.sym->name, &e->where); |
| break; |
| |
| case AS_EXPLICIT: |
| gfc_error ("Array %qs at %L is a variable, which does " |
| "not reduce to a constant expression", |
| e->symtree->n.sym->name, &e->where); |
| break; |
| |
| default: |
| gcc_unreachable(); |
| } |
| } |
| else |
| gfc_error ("Parameter %qs at %L has not been declared or is " |
| "a variable, which does not reduce to a constant " |
| "expression", e->symtree->name, &e->where); |
| |
| break; |
| |
| case EXPR_CONSTANT: |
| case EXPR_NULL: |
| t = true; |
| break; |
| |
| case EXPR_SUBSTRING: |
| if (e->ref) |
| { |
| t = gfc_check_init_expr (e->ref->u.ss.start); |
| if (!t) |
| break; |
| |
| t = gfc_check_init_expr (e->ref->u.ss.end); |
| if (t) |
| t = gfc_simplify_expr (e, 0); |
| } |
| else |
| t = false; |
| break; |
| |
| case EXPR_STRUCTURE: |
| t = e->ts.is_iso_c ? true : false; |
| if (t) |
| break; |
| |
| t = check_alloc_comp_init (e); |
| if (!t) |
| break; |
| |
| t = gfc_check_constructor (e, gfc_check_init_expr); |
| if (!t) |
| break; |
| |
| break; |
| |
| case EXPR_ARRAY: |
| t = gfc_check_constructor (e, gfc_check_init_expr); |
| if (!t) |
| break; |
| |
| t = gfc_expand_constructor (e, true); |
| if (!t) |
| break; |
| |
| t = gfc_check_constructor_type (e); |
| break; |
| |
| default: |
| gfc_internal_error ("check_init_expr(): Unknown expression type"); |
| } |
| |
| return t; |
| } |
| |
| /* Reduces a general expression to an initialization expression (a constant). |
| This used to be part of gfc_match_init_expr. |
| Note that this function doesn't free the given expression on false. */ |
| |
| bool |
| gfc_reduce_init_expr (gfc_expr *expr) |
| { |
| bool t; |
| |
| gfc_init_expr_flag = true; |
| t = gfc_resolve_expr (expr); |
| if (t) |
| t = gfc_check_init_expr (expr); |
| gfc_init_expr_flag = false; |
| |
| if (!t || !expr) |
| return false; |
| |
| if (expr->expr_type == EXPR_ARRAY) |
| { |
| if (!gfc_check_constructor_type (expr)) |
| return false; |
| if (!gfc_expand_constructor (expr, true)) |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| /* Match an initialization expression. We work by first matching an |
| expression, then reducing it to a constant. */ |
| |
| match |
| gfc_match_init_expr (gfc_expr **result) |
| { |
| gfc_expr *expr; |
| match m; |
| bool t; |
| |
| expr = NULL; |
| |
| gfc_init_expr_flag = true; |
| |
| m = gfc_match_expr (&expr); |
| if (m != MATCH_YES) |
| { |
| gfc_init_expr_flag = false; |
| return m; |
| } |
| |
| if (gfc_derived_parameter_expr (expr)) |
| { |
| *result = expr; |
| gfc_init_expr_flag = false; |
| return m; |
| } |
| |
| t = gfc_reduce_init_expr (expr); |
| if (!t) |
| { |
| gfc_free_expr (expr); |
| gfc_init_expr_flag = false; |
| return MATCH_ERROR; |
| } |
| |
| *result = expr; |
| gfc_init_expr_flag = false; |
| |
| return MATCH_YES; |
| } |
| |
| |
| /* Given an actual argument list, test to see that each argument is a |
| restricted expression and optionally if the expression type is |
| integer or character. */ |
| |
| static bool |
| restricted_args (gfc_actual_arglist *a) |
| { |
| for (; a; a = a->next) |
| { |
| if (!check_restricted (a->expr)) |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| /************* Restricted/specification expressions *************/ |
| |
| |
| /* Make sure a non-intrinsic function is a specification function, |
| * see F08:7.1.11.5. */ |
| |
| static bool |
| external_spec_function (gfc_expr *e) |
| { |
| gfc_symbol *f; |
| |
| f = e->value.function.esym; |
| |
| /* IEEE functions allowed are "a reference to a transformational function |
| from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and |
| "inquiry function from the intrinsic modules IEEE_ARITHMETIC and |
| IEEE_EXCEPTIONS". */ |
| if (f->from_intmod == INTMOD_IEEE_ARITHMETIC |
| || f->from_intmod == INTMOD_IEEE_EXCEPTIONS) |
| { |
| if (!strcmp (f->name, "ieee_selected_real_kind") |
| || !strcmp (f->name, "ieee_support_rounding") |
| || !strcmp (f->name, "ieee_support_flag") |
| || !strcmp (f->name, "ieee_support_halting") |
| || !strcmp (f->name, "ieee_support_datatype") |
| || !strcmp (f->name, "ieee_support_denormal") |
| || !strcmp (f->name, "ieee_support_subnormal") |
| || !strcmp (f->name, "ieee_support_divide") |
| || !strcmp (f->name, "ieee_support_inf") |
| || !strcmp (f->name, "ieee_support_io") |
| || !strcmp (f->name, "ieee_support_nan") |
| || !strcmp (f->name, "ieee_support_sqrt") |
| || !strcmp (f->name, "ieee_support_standard") |
| || !strcmp (f->name, "ieee_support_underflow_control")) |
| goto function_allowed; |
| } |
| |
| if (f->attr.proc == PROC_ST_FUNCTION) |
| { |
| gfc_error ("Specification function %qs at %L cannot be a statement " |
| "function", f->name, &e->where); |
| return false; |
| } |
| |
| if (f->attr.proc == PROC_INTERNAL) |
| { |
| gfc_error ("Specification function %qs at %L cannot be an internal " |
| "function", f->name, &e->where); |
| return false; |
| } |
| |
| if (!f->attr.pure && !f->attr.elemental) |
| { |
| gfc_error ("Specification function %qs at %L must be PURE", f->name, |
| &e->where); |
| return false; |
| } |
| |
| /* F08:7.1.11.6. */ |
| if (f->attr.recursive |
| && !gfc_notify_std (GFC_STD_F2003, |
| "Specification function %qs " |
| "at %L cannot be RECURSIVE", f->name, &e->where)) |
| return false; |
| |
| function_allowed: |
| return restricted_args (e->value.function.actual); |
| } |
| |
| |
| /* Check to see that a function reference to an intrinsic is a |
| restricted expression. */ |
| |
| static bool |
| restricted_intrinsic (gfc_expr *e) |
| { |
| /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */ |
| if (check_inquiry (e, 0) == MATCH_YES) |
| return true; |
| |
| return restricted_args (e->value.function.actual); |
| } |
| |
| |
| /* Check the expressions of an actual arglist. Used by check_restricted. */ |
| |
| static bool |
| check_arglist (gfc_actual_arglist* arg, bool (*checker) (gfc_expr*)) |
| { |
| for (; arg; arg = arg->next) |
| if (!checker (arg->expr)) |
| return false; |
| |
| return true; |
| } |
| |
| |
| /* Check the subscription expressions of a reference chain with a checking |
| function; used by check_restricted. */ |
| |
| static bool |
| check_references (gfc_ref* ref, bool (*checker) (gfc_expr*)) |
| { |
| int dim; |
| |
| if (!ref) |
| return true; |
| |
| switch (ref->type) |
| { |
| case REF_ARRAY: |
| for (dim = 0; dim != ref->u.ar.dimen; ++dim) |
| { |
| if (!checker (ref->u.ar.start[dim])) |
| return false; |
| if (!checker (ref->u.ar.end[dim])) |
| return false; |
| if (!checker (ref->u.ar.stride[dim])) |
| return false; |
| } |
| break; |
| |
| case REF_COMPONENT: |
| /* Nothing needed, just proceed to next reference. */ |
| break; |
| |
| case REF_SUBSTRING: |
| if (!checker (ref->u.ss.start)) |
| return false; |
| if (!checker (ref->u.ss.end)) |
| return false; |
| break; |
| |
| default: |
| gcc_unreachable (); |
| break; |
| } |
| |
| return check_references (ref->next, checker); |
| } |
| |
| /* Return true if ns is a parent of the current ns. */ |
| |
| static bool |
| is_parent_of_current_ns (gfc_namespace *ns) |
| { |
| gfc_namespace *p; |
| for (p = gfc_current_ns->parent; p; p = p->parent) |
| if (ns == p) |
| return true; |
| |
| return false; |
| } |
| |
| /* Verify that an expression is a restricted expression. Like its |
| cousin check_init_expr(), an error message is generated if we |
| return false. */ |
| |
| static bool |
| check_restricted (gfc_expr *e) |
| { |
| gfc_symbol* sym; |
| bool t; |
| |
| if (e == NULL) |
| return true; |
| |
| switch (e->expr_type) |
| { |
| case EXPR_OP: |
| t = check_intrinsic_op (e, check_restricted); |
| if (t) |
| t = gfc_simplify_expr (e, 0); |
| |
| break; |
| |
| case EXPR_FUNCTION: |
| if (e->value.function.esym) |
| { |
| t = check_arglist (e->value.function.actual, &check_restricted); |
| if (t) |
| t = external_spec_function (e); |
| } |
| else |
| { |
| if (e->value.function.isym && e->value.function.isym->inquiry) |
| t = true; |
| else |
| t = check_arglist (e->value.function.actual, &check_restricted); |
| |
| if (t) |
| t = restricted_intrinsic (e); |
| } |
| break; |
| |
| case EXPR_VARIABLE: |
| sym = e->symtree->n.sym; |
| t = false; |
| |
| /* If a dummy argument appears in a context that is valid for a |
| restricted expression in an elemental procedure, it will have |
| already been simplified away once we get here. Therefore we |
| don't need to jump through hoops to distinguish valid from |
| invalid cases. Allowed in F2008 and F2018. */ |
| if (gfc_notification_std (GFC_STD_F2008) |
| && sym->attr.dummy && sym->ns == gfc_current_ns |
| && sym->ns->proc_name && sym->ns->proc_name->attr.elemental) |
| { |
| gfc_error_now ("Dummy argument %qs not " |
| "allowed in expression at %L", |
| sym->name, &e->where); |
| break; |
| } |
| |
| if (sym->attr.optional) |
| { |
| gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL", |
| sym->name, &e->where); |
| break; |
| } |
| |
| if (sym->attr.intent == INTENT_OUT) |
| { |
| gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)", |
| sym->name, &e->where); |
| break; |
| } |
| |
| /* Check reference chain if any. */ |
| if (!check_references (e->ref, &check_restricted)) |
| break; |
| |
| /* gfc_is_formal_arg broadcasts that a formal argument list is being |
| processed in resolve.c(resolve_formal_arglist). This is done so |
| that host associated dummy array indices are accepted (PR23446). |
| This mechanism also does the same for the specification expressions |
| of array-valued functions. */ |
| if (e->error |
| || sym->attr.in_common |
| || sym->attr.use_assoc |
| || sym->attr.dummy |
| || sym->attr.implied_index |
| || sym->attr.flavor == FL_PARAMETER |
| || is_parent_of_current_ns (sym->ns) |
| || (sym->ns->proc_name != NULL |
| && sym->ns->proc_name->attr.flavor == FL_MODULE) |
| || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns))) |
| { |
| t = true; |
| break; |
| } |
| |
| gfc_error ("Variable %qs cannot appear in the expression at %L", |
| sym->name, &e->where); |
| /* Prevent a repetition of the error. */ |
| e->error = 1; |
| break; |
| |
| case EXPR_NULL: |
| case EXPR_CONSTANT: |
| t = true; |
| break; |
| |
| case EXPR_SUBSTRING: |
| t = gfc_specification_expr (e->ref->u.ss.start); |
| if (!t) |
| break; |
| |
| t = gfc_specification_expr (e->ref->u.ss.end); |
| if (t) |
| t = gfc_simplify_expr (e, 0); |
| |
| break; |
| |
| case EXPR_STRUCTURE: |
| t = gfc_check_constructor (e, check_restricted); |
| break; |
| |
| case EXPR_ARRAY: |
| t = gfc_check_constructor (e, check_restricted); |
| break; |
| |
| default: |
| gfc_internal_error ("check_restricted(): Unknown expression type"); |
| } |
| |
| return t; |
| } |
| |
| |
| /* Check to see that an expression is a specification expression. If |
| we return false, an error has been generated. */ |
| |
| bool |
| gfc_specification_expr (gfc_expr *e) |
| { |
| gfc_component *comp; |
| |
| if (e == NULL) |
| return true; |
| |
| if (e->ts.type != BT_INTEGER) |
| { |
| gfc_error ("Expression at %L must be of INTEGER type, found %s", |
| &e->where, gfc_basic_typename (e->ts.type)); |
| return false; |
| } |
| |
| comp = gfc_get_proc_ptr_comp (e); |
| if (e->expr_type == EXPR_FUNCTION |
| && !e->value.function.isym |
| && !e->value.function.esym |
| && !gfc_pure (e->symtree->n.sym) |
| && (!comp || !comp->attr.pure)) |
| { |
| gfc_error ("Function %qs at %L must be PURE", |
| e->symtree->n.sym->name, &e->where); |
| /* Prevent repeat error messages. */ |
| e->symtree->n.sym->attr.pure = 1; |
| return false; |
| } |
| |
| if (e->rank != 0) |
| { |
| gfc_error ("Expression at %L must be scalar", &e->where); |
| return false; |
| } |
| |
| if (!gfc_simplify_expr (e, 0)) |
| return false; |
| |
| return check_restricted (e); |
| } |
| |
| |
| /************** Expression conformance checks. *************/ |
| |
| /* Given two expressions, make sure that the arrays are conformable. */ |
| |
| bool |
| gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...) |
| { |
| int op1_flag, op2_flag, d; |
| mpz_t op1_size, op2_size; |
| bool t; |
| |
| va_list argp; |
| char buffer[240]; |
| |
| if (op1->rank == 0 || op2->rank == 0) |
| return true; |
| |
| va_start (argp, optype_msgid); |
| d = vsnprintf (buffer, sizeof (buffer), optype_msgid, argp); |
| va_end (argp); |
| if (d < 1 || d >= (int) sizeof (buffer)) /* Reject truncation. */ |
| gfc_internal_error ("optype_msgid overflow: %d", d); |
| |
| if (op1->rank != op2->rank) |
| { |
| gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer), |
| op1->rank, op2->rank, &op1->where); |
| return false; |
| } |
| |
| t = true; |
| |
| for (d = 0; d < op1->rank; d++) |
| { |
| op1_flag = gfc_array_dimen_size(op1, d, &op1_size); |
| op2_flag = gfc_array_dimen_size(op2, d, &op2_size); |
| |
| if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0) |
| { |
| gfc_error ("Different shape for %s at %L on dimension %d " |
| "(%d and %d)", _(buffer), &op1->where, d + 1, |
| (int) mpz_get_si (op1_size), |
| (int) mpz_get_si (op2_size)); |
| |
| t = false; |
| } |
| |
| if (op1_flag) |
| mpz_clear (op1_size); |
| if (op2_flag) |
| mpz_clear (op2_size); |
| |
| if (!t) |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| /* Given an assignable expression and an arbitrary expression, make |
| sure that the assignment can take place. Only add a call to the intrinsic |
| conversion routines, when allow_convert is set. When this assign is a |
| coarray call, then the convert is done by the coarray routine implictly and |
| adding the intrinsic conversion would do harm in most cases. */ |
| |
| bool |
| gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform, |
| bool allow_convert) |
| { |
| gfc_symbol *sym; |
| gfc_ref *ref; |
| int has_pointer; |
| |
| sym = lvalue->symtree->n.sym; |
| |
| /* See if this is the component or subcomponent of a pointer and guard |
| against assignment to LEN or KIND part-refs. */ |
| has_pointer = sym->attr.pointer; |
| for (ref = lvalue->ref; ref; ref = ref->next) |
| { |
| if (!has_pointer && ref->type == REF_COMPONENT |
| && ref->u.c.component->attr.pointer) |
| has_pointer = 1; |
| else if (ref->type == REF_INQUIRY |
| && (ref->u.i == INQUIRY_LEN || ref->u.i == INQUIRY_KIND)) |
| { |
| gfc_error ("Assignment to a LEN or KIND part_ref at %L is not " |
| "allowed", &lvalue->where); |
| return false; |
| } |
| } |
| |
| /* 12.5.2.2, Note 12.26: The result variable is very similar to any other |
| variable local to a function subprogram. Its existence begins when |
| execution of the function is initiated and ends when execution of the |
| function is terminated... |
| Therefore, the left hand side is no longer a variable, when it is: */ |
| if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION |
| && !sym->attr.external) |
| { |
| bool bad_proc; |
| bad_proc = false; |
| |
| /* (i) Use associated; */ |
| if (sym->attr.use_assoc) |
| bad_proc = true; |
| |
| /* (ii) The assignment is in the main program; or */ |
| if (gfc_current_ns->proc_name |
| && gfc_current_ns->proc_name->attr.is_main_program) |
| bad_proc = true; |
| |
| /* (iii) A module or internal procedure... */ |
| if (gfc_current_ns->proc_name |
| && (gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL |
| || gfc_current_ns->proc_name->attr.proc == PROC_MODULE) |
| && gfc_current_ns->parent |
| && (!(gfc_current_ns->parent->proc_name->attr.function |
| || gfc_current_ns->parent->proc_name->attr.subroutine) |
| || gfc_current_ns->parent->proc_name->attr.is_main_program)) |
| { |
| /* ... that is not a function... */ |
| if (gfc_current_ns->proc_name |
| && !gfc_current_ns->proc_name->attr.function) |
| bad_proc = true; |
| |
| /* ... or is not an entry and has a different name. */ |
| if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name) |
| bad_proc = true; |
| } |
| |
| /* (iv) Host associated and not the function symbol or the |
| parent result. This picks up sibling references, which |
| cannot be entries. */ |
| if (!sym->attr.entry |
| && sym->ns == gfc_current_ns->parent |
| && sym != gfc_current_ns->proc_name |
| && sym != gfc_current_ns->parent->proc_name->result) |
| bad_proc = true; |
| |
| if (bad_proc) |
| { |
| gfc_error ("%qs at %L is not a VALUE", sym->name, &lvalue->where); |
| return false; |
| } |
| } |
| else |
| { |
| /* Reject assigning to an external symbol. For initializers, this |
| was already done before, in resolve_fl_procedure. */ |
| if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external |
| && sym->attr.proc != PROC_MODULE && !rvalue->error) |
| { |
| gfc_error ("Illegal assignment to external procedure at %L", |
| &lvalue->where); |
| return false; |
| } |
| } |
| |
| if (rvalue->rank != 0 && lvalue->rank != rvalue->rank) |
| { |
| gfc_error ("Incompatible ranks %d and %d in assignment at %L", |
| lvalue->rank, rvalue->rank, &lvalue->where); |
| return false; |
| } |
| |
| if (lvalue->ts.type == BT_UNKNOWN) |
| { |
| gfc_error ("Variable type is UNKNOWN in assignment at %L", |
| &lvalue->where); |
| return false; |
| } |
| |
| if (rvalue->expr_type == EXPR_NULL) |
| { |
| if (has_pointer && (ref == NULL || ref->next == NULL) |
| && lvalue->symtree->n.sym->attr.data) |
| return true; |
| else |
| { |
| gfc_error ("NULL appears on right-hand side in assignment at %L", |
| &rvalue->where); |
| return false; |
| } |
| } |
| |
| /* This is possibly a typo: x = f() instead of x => f(). */ |
| if (warn_surprising |
| && rvalue->expr_type == EXPR_FUNCTION && gfc_expr_attr (rvalue).pointer) |
| gfc_warning (OPT_Wsurprising, |
| "POINTER-valued function appears on right-hand side of " |
| "assignment at %L", &rvalue->where); |
| |
| /* Check size of array assignments. */ |
| if (lvalue->rank != 0 && rvalue->rank != 0 |
| && !gfc_check_conformance (lvalue, rvalue, "array assignment")) |
| return false; |
| |
| /* Handle the case of a BOZ literal on the RHS. */ |
| if (rvalue->ts.type == BT_BOZ) |
| { |
| if (lvalue->symtree->n.sym->attr.data) |
| { |
| if (lvalue->ts.type == BT_INTEGER |
| && gfc_boz2int (rvalue, lvalue->ts.kind)) |
| return true; |
| |
| if (lvalue->ts.type == BT_REAL |
| && gfc_boz2real (rvalue, lvalue->ts.kind)) |
| { |
| if (gfc_invalid_boz ("BOZ literal constant near %L cannot " |
| "be assigned to a REAL variable", |
| &rvalue->where)) |
| return false; |
| return true; |
| } |
| } |
| |
| if (!lvalue->symtree->n.sym->attr.data |
| && gfc_invalid_boz ("BOZ literal constant at %L is neither a " |
| "data-stmt-constant nor an actual argument to " |
| "INT, REAL, DBLE, or CMPLX intrinsic function", |
| &rvalue->where)) |
| return false; |
| |
| if (lvalue->ts.type == BT_INTEGER |
| && gfc_boz2int (rvalue, lvalue->ts.kind)) |
| return true; |
| |
| if (lvalue->ts.type == BT_REAL |
| && gfc_boz2real (rvalue, lvalue->ts.kind)) |
| return true; |
| |
| gfc_error ("BOZ literal constant near %L cannot be assigned to a " |
| "%qs variable", &rvalue->where, gfc_typename (lvalue)); |
| return false; |
| } |
| |
| if (gfc_expr_attr (lvalue).pdt_kind || gfc_expr_attr (lvalue).pdt_len) |
| { |
| gfc_error ("The assignment to a KIND or LEN component of a " |
| "parameterized type at %L is not allowed", |
| &lvalue->where); |
| return false; |
| } |
| |
| if (gfc_compare_types (&lvalue->ts, &rvalue->ts)) |
| return true; |
| |
| /* Only DATA Statements come here. */ |
| if (!conform) |
| { |
| locus *where; |
| |
| /* Numeric can be converted to any other numeric. And Hollerith can be |
| converted to any other type. */ |
| if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts)) |
| || rvalue->ts.type == BT_HOLLERITH) |
| return true; |
| |
| if (flag_dec_char_conversions && (gfc_numeric_ts (&lvalue->ts) |
| || lvalue->ts.type == BT_LOGICAL) |
| && rvalue->ts.type == BT_CHARACTER |
| && rvalue->ts.kind == gfc_default_character_kind) |
| return true; |
| |
| if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL) |
| return true; |
| |
| where = lvalue->where.lb ? &lvalue->where : &rvalue->where; |
| gfc_error ("Incompatible types in DATA statement at %L; attempted " |
| "conversion of %s to %s", where, |
| gfc_typename (rvalue), gfc_typename (lvalue)); |
| |
| return false; |
| } |
| |
| /* Assignment is the only case where character variables of different |
| kind values can be converted into one another. */ |
| if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER) |
| { |
| if (lvalue->ts.kind != rvalue->ts.kind && allow_convert) |
| return gfc_convert_chartype (rvalue, &lvalue->ts); |
| else |
| return true; |
| } |
| |
| if (!allow_convert) |
| return true; |
| |
| return gfc_convert_type (rvalue, &lvalue->ts, 1); |
| } |
| |
| |
| /* Check that a pointer assignment is OK. We first check lvalue, and |
| we only check rvalue if it's not an assignment to NULL() or a |
| NULLIFY statement. */ |
| |
| bool |
| gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue, |
| bool suppress_type_test, bool is_init_expr) |
| { |
| symbol_attribute attr, lhs_attr; |
| gfc_ref *ref; |
| bool is_pure, is_implicit_pure, rank_remap; |
| int proc_pointer; |
| bool same_rank; |
| |
| if (!lvalue->symtree) |
| return false; |
| |
| lhs_attr = gfc_expr_attr (lvalue); |
| if (lvalue->ts.type == BT_UNKNOWN && !lhs_attr.proc_pointer) |
| { |
| gfc_error ("Pointer assignment target is not a POINTER at %L", |
| &lvalue->where); |
| return false; |
| } |
| |
| if (lhs_attr.flavor == FL_PROCEDURE && lhs_attr.use_assoc |
| && !lhs_attr.proc_pointer) |
| { |
| gfc_error ("%qs in the pointer assignment at %L cannot be an " |
| "l-value since it is a procedure", |
| lvalue->symtree->n.sym->name, &lvalue->where); |
| return false; |
| } |
| |
| proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer; |
| |
| rank_remap = false; |
| same_rank = lvalue->rank == rvalue->rank; |
| for (ref = lvalue->ref; ref; ref = ref->next) |
| { |
| if (ref->type == REF_COMPONENT) |
| proc_pointer = ref->u.c.component->attr.proc_pointer; |
| |
| if (ref->type == REF_ARRAY && ref->next == NULL) |
| { |
| int dim; |
| |
| if (ref->u.ar.type == AR_FULL) |
| break; |
| |
| if (ref->u.ar.type != AR_SECTION) |
| { |
| gfc_error ("Expected bounds specification for %qs at %L", |
| lvalue->symtree->n.sym->name, &lvalue->where); |
| return false; |
| } |
| |
| if (!gfc_notify_std (GFC_STD_F2003, "Bounds specification " |
| "for %qs in pointer assignment at %L", |
| lvalue->symtree->n.sym->name, &lvalue->where)) |
| return false; |
| |
| /* Fortran standard (e.g. F2018, 10.2.2 Pointer assignment): |
| * |
| * (C1017) If bounds-spec-list is specified, the number of |
| * bounds-specs shall equal the rank of data-pointer-object. |
| * |
| * If bounds-spec-list appears, it specifies the lower bounds. |
| * |
| * (C1018) If bounds-remapping-list is specified, the number of |
| * bounds-remappings shall equal the rank of data-pointer-object. |
| * |
| * If bounds-remapping-list appears, it specifies the upper and |
| * lower bounds of each dimension of the pointer; the pointer target |
| * shall be simply contiguous or of rank one. |
| * |
| * (C1019) If bounds-remapping-list is not specified, the ranks of |
| * data-pointer-object and data-target shall be the same. |
| * |
| * Thus when bounds are given, all lbounds are necessary and either |
| * all or none of the upper bounds; no strides are allowed. If the |
| * upper bounds are present, we may do rank remapping. */ |
| for (dim = 0; dim < ref->u.ar.dimen; ++dim) |
| { |
| if (ref->u.ar.stride[dim]) |
| { |
| gfc_error ("Stride must not be present at %L", |
| &lvalue->where); |
| return false; |
| } |
| if (!same_rank && (!ref->u.ar.start[dim] ||!ref->u.ar.end[dim])) |
| { |
| gfc_error ("Rank remapping requires a " |
| "list of %<lower-bound : upper-bound%> " |
| "specifications at %L", &lvalue->where); |
| return false; |
| } |
| if (!ref->u.ar.start[dim] |
| || ref->u.ar.dimen_type[dim] != DIMEN_RANGE) |
| { |
| gfc_error ("Expected list of %<lower-bound :%> or " |
| "list of %<lower-bound : upper-bound%> " |
| "specifications at %L", &lvalue->where); |
| return false; |
| } |
| |
| if (dim == 0) |
| rank_remap = (ref->u.ar.end[dim] != NULL); |
| else |
| { |
| if ((rank_remap && !ref->u.ar.end[dim])) |
| { |
| gfc_error ("Rank remapping requires a " |
| "list of %<lower-bound : upper-bound%> " |
| "specifications at %L", &lvalue->where); |
| return false; |
| } |
| if (!rank_remap && ref->u.ar.end[dim]) |
| { |
| gfc_error ("Expected list of %<lower-bound :%> or " |
| "list of %<lower-bound : upper-bound%> " |
| "specifications at %L", &lvalue->where); |
| return false; |
| } |
| } |
| } |
| } |
| } |
| |
| is_pure = gfc_pure (NULL); |
| is_implicit_pure = gfc_implicit_pure (NULL); |
| |
| /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type, |
| kind, etc for lvalue and rvalue must match, and rvalue must be a |
| pure variable if we're in a pure function. */ |
| if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN) |
| return true; |
| |
| /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */ |
| if (lvalue->expr_type == EXPR_VARIABLE |
| && gfc_is_coindexed (lvalue)) |
| { |
| gfc_ref *ref; |
| for (ref = lvalue->ref; ref; ref = ref->next) |
| if (ref->type == REF_ARRAY && ref->u.ar.codimen) |
| { |
| gfc_error ("Pointer object at %L shall not have a coindex", |
| &lvalue->where); |
| return false; |
| } |
| } |
| |
| /* Checks on rvalue for procedure pointer assignments. */ |
| if (proc_pointer) |
| { |
| char err[200]; |
| gfc_symbol *s1,*s2; |
| gfc_component *comp1, *comp2; |
| const char *name; |
| |
| attr = gfc_expr_attr (rvalue); |
| if (!((rvalue->expr_type == EXPR_NULL) |
| || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer) |
| || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer) |
| || (rvalue->expr_type == EXPR_VARIABLE |
| && attr.flavor == FL_PROCEDURE))) |
| { |
| gfc_error ("Invalid procedure pointer assignment at %L", |
| &rvalue->where); |
| return false; |
| } |
| |
| if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer) |
| { |
| /* Check for intrinsics. */ |
| gfc_symbol *sym = rvalue->symtree->n.sym; |
| if (!sym->attr.intrinsic |
| && (gfc_is_intrinsic (sym, 0, sym->declared_at) |
| || gfc_is_intrinsic (sym, 1, sym->declared_at))) |
| { |
| sym->attr.intrinsic = 1; |
| gfc_resolve_intrinsic (sym, &rvalue->where); |
| attr = gfc_expr_attr (rvalue); |
| } |
| /* Check for result of embracing function. */ |
| if (sym->attr.function && sym->result == sym) |
| { |
| gfc_namespace *ns; |
| |
| for (ns = gfc_current_ns; ns; ns = ns->parent) |
| if (sym == ns->proc_name) |
| { |
| gfc_error ("Function result %qs is invalid as proc-target " |
| "in procedure pointer assignment at %L", |
| sym->name, &rvalue->where); |
| return false; |
| } |
| } |
| } |
| if (attr.abstract) |
| { |
| gfc_error ("Abstract interface %qs is invalid " |
| "in procedure pointer assignment at %L", |
| rvalue->symtree->name, &rvalue->where); |
| return false; |
| } |
| /* Check for F08:C729. */ |
| if (attr.flavor == FL_PROCEDURE) |
| { |
| if (attr.proc == PROC_ST_FUNCTION) |
| { |
| gfc_error ("Statement function %qs is invalid " |
| "in procedure pointer assignment at %L", |
| rvalue->symtree->name, &rvalue->where); |
| return false; |
| } |
| if (attr.proc == PROC_INTERNAL && |
| !gfc_notify_std(GFC_STD_F2008, "Internal procedure %qs " |
| "is invalid in procedure pointer assignment " |
| "at %L", rvalue->symtree->name, &rvalue->where)) |
| return false; |
| if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name, |
| attr.subroutine) == 0) |
| { |
| gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer " |
| "assignment", rvalue->symtree->name, &rvalue->where); |
| return false; |
| } |
| } |
| /* Check for F08:C730. */ |
| if (attr.elemental && !attr.intrinsic) |
| { |
| gfc_error ("Nonintrinsic elemental procedure %qs is invalid " |
| "in procedure pointer assignment at %L", |
| rvalue->symtree->name, &rvalue->where); |
| return false; |
| } |
| |
| /* Ensure that the calling convention is the same. As other attributes |
| such as DLLEXPORT may differ, one explicitly only tests for the |
| calling conventions. */ |
| if (rvalue->expr_type == EXPR_VARIABLE |
| && lvalue->symtree->n.sym->attr.ext_attr |
| != rvalue->symtree->n.sym->attr.ext_attr) |
| { |
| symbol_attribute calls; |
| |
| calls.ext_attr = 0; |
| gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL); |
| gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL); |
| gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL); |
| |
| if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr) |
| != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr)) |
| { |
| gfc_error ("Mismatch in the procedure pointer assignment " |
| "at %L: mismatch in the calling convention", |
| &rvalue->where); |
| return false; |
| } |
| } |
| |
| comp1 = gfc_get_proc_ptr_comp (lvalue); |
| if (comp1) |
| s1 = comp1->ts.interface; |
| else |
| { |
| s1 = lvalue->symtree->n.sym; |
| if (s1->ts.interface) |
| s1 = s1->ts.interface; |
| } |
| |
| comp2 = gfc_get_proc_ptr_comp (rvalue); |
| if (comp2) |
| { |
| if (rvalue->expr_type == EXPR_FUNCTION) |
| { |
| s2 = comp2->ts.interface->result; |
| name = s2->name; |
| } |
| else |
| { |
| s2 = comp2->ts.interface; |
| name = comp2->name; |
| } |
| } |
| else if (rvalue->expr_type == EXPR_FUNCTION) |
| { |
| if (rvalue->value.function.esym) |
| s2 = rvalue->value.function.esym->result; |
| else |
| s2 = rvalue->symtree->n.sym->result; |
| |
| name = s2->name; |
| } |
| else |
| { |
| s2 = rvalue->symtree->n.sym; |
| name = s2->name; |
| } |
| |
| if (s2 && s2->attr.proc_pointer && s2->ts.interface) |
| s2 = s2->ts.interface; |
| |
| /* Special check for the case of absent interface on the lvalue. |
| * All other interface checks are done below. */ |
| if (!s1 && comp1 && comp1->attr.subroutine && s2 && s2->attr.function) |
| { |
| gfc_error ("Interface mismatch in procedure pointer assignment " |
| "at %L: %qs is not a subroutine", &rvalue->where, name); |
| return false; |
| } |
| |
| /* F08:7.2.2.4 (4) */ |
| if (s2 && gfc_explicit_interface_required (s2, err, sizeof(err))) |
| { |
| if (comp1 && !s1) |
| { |
| gfc_error ("Explicit interface required for component %qs at %L: %s", |
| comp1->name, &lvalue->where, err); |
| return false; |
| } |
| else if (s1->attr.if_source == IFSRC_UNKNOWN) |
| { |
| gfc_error ("Explicit interface required for %qs at %L: %s", |
| s1->name, &lvalue->where, err); |
| return false; |
| } |
| } |
| if (s1 && gfc_explicit_interface_required (s1, err, sizeof(err))) |
| { |
| if (comp2 && !s2) |
| { |
| gfc_error ("Explicit interface required for component %qs at %L: %s", |
| comp2->name, &rvalue->where, err); |
| return false; |
| } |
| else if (s2->attr.if_source == IFSRC_UNKNOWN) |
| { |
| gfc_error ("Explicit interface required for %qs at %L: %s", |
| s2->name, &rvalue->where, err); |
| return false; |
| } |
| } |
| |
| if (s1 == s2 || !s1 || !s2) |
| return true; |
| |
| if (!gfc_compare_interfaces (s1, s2, name, 0, 1, |
| err, sizeof(err), NULL, NULL)) |
| { |
| gfc_error ("Interface mismatch in procedure pointer assignment " |
| "at %L: %s", &rvalue->where, err); |
| return false; |
| } |
| |
| /* Check F2008Cor2, C729. */ |
| if (!s2->attr.intrinsic && s2->attr.if_source == IFSRC_UNKNOWN |
| && !s2->attr.external && !s2->attr.subroutine && !s2->attr.function) |
| { |
| gfc_error ("Procedure pointer target %qs at %L must be either an " |
| "intrinsic, host or use associated, referenced or have " |
| "the EXTERNAL attribute", s2->name, &rvalue->where); |
| return false; |
| } |
| |
| return true; |
| } |
| else |
| { |
| /* A non-proc pointer cannot point to a constant. */ |
| if (rvalue->expr_type == EXPR_CONSTANT) |
| { |
| gfc_error_now ("Pointer assignment target cannot be a constant at %L", |
| &rvalue->where); |
| return false; |
| } |
| } |
| |
| if (!gfc_compare_types (&lvalue->ts, &rvalue->ts)) |
| { |
| /* Check for F03:C717. */ |
| if (UNLIMITED_POLY (rvalue) |
| && !(UNLIMITED_POLY (lvalue) |
| || (lvalue->ts.type == BT_DERIVED |
| && (lvalue->ts.u.derived->attr.is_bind_c |
| || lvalue->ts.u.derived->attr.sequence)))) |
| gfc_error ("Data-pointer-object at %L must be unlimited " |
| "polymorphic, or of a type with the BIND or SEQUENCE " |
| "attribute, to be compatible with an unlimited " |
| "polymorphic target", &lvalue->where); |
| else if (!suppress_type_test) |
| gfc_error ("Different types in pointer assignment at %L; " |
| "attempted assignment of %s to %s", &lvalue->where, |
| gfc_typename (rvalue), gfc_typename (lvalue)); |
| return false; |
| } |
| |
| if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind) |
| { |
| gfc_error ("Different kind type parameters in pointer " |
| "assignment at %L", &lvalue->where); |
| return false; |
| } |
| |
| if (lvalue->rank != rvalue->rank && !rank_remap) |
| { |
| gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where); |
| return false; |
| } |
| |
| /* Make sure the vtab is present. */ |
| if (lvalue->ts.type == BT_CLASS && !UNLIMITED_POLY (rvalue)) |
| gfc_find_vtab (&rvalue->ts); |
| |
| /* Check rank remapping. */ |
| if (rank_remap) |
| { |
| mpz_t lsize, rsize; |
| |
| /* If this can be determined, check that the target must be at least as |
| large as the pointer assigned to it is. */ |
| if (gfc_array_size (lvalue, &lsize) |
| && gfc_array_size (rvalue, &rsize) |
| && mpz_cmp (rsize, lsize) < 0) |
| { |
| gfc_error ("Rank remapping target is smaller than size of the" |
| " pointer (%ld < %ld) at %L", |
| mpz_get_si (rsize), mpz_get_si (lsize), |
| &lvalue->where); |
| return false; |
| } |
| |
| /* The target must be either rank one or it must be simply contiguous |
| and F2008 must be allowed. */ |
| if (rvalue->rank != 1) |
| { |
| if (!gfc_is_simply_contiguous (rvalue, true, false)) |
| { |
| gfc_error ("Rank remapping target must be rank 1 or" |
| " simply contiguous at %L", &rvalue->where); |
| return false; |
| } |
| if (!gfc_notify_std (GFC_STD_F2008, "Rank remapping target is not " |
| "rank 1 at %L", &rvalue->where)) |
| return false; |
| } |
| } |
| |
| /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */ |
| if (rvalue->expr_type == EXPR_NULL) |
| return true; |
| |
| if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue)) |
| lvalue->symtree->n.sym->attr.subref_array_pointer = 1; |
| |
| attr = gfc_expr_attr (rvalue); |
| |
| if (rvalue->expr_type == EXPR_FUNCTION && !attr.pointer) |
| { |
| /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call |
| to caf_get. Map this to the same error message as below when it is |
| still a variable expression. */ |
| if (rvalue->value.function.isym |
| && rvalue->value.function.isym->id == GFC_ISYM_CAF_GET) |
| /* The test above might need to be extend when F08, Note 5.4 has to be |
| interpreted in the way that target and pointer with the same coindex |
| are allowed. */ |
| gfc_error ("Data target at %L shall not have a coindex", |
| &rvalue->where); |
| else |
| gfc_error ("Target expression in pointer assignment " |
| "at %L must deliver a pointer result", |
| &rvalue->where); |
| return false; |
| } |
| |
| if (is_init_expr) |
| { |
| gfc_symbol *sym; |
| bool target; |
| gfc_ref *ref; |
| |
| if (gfc_is_size_zero_array (rvalue)) |
| { |
| gfc_error ("Zero-sized array detected at %L where an entity with " |
| "the TARGET attribute is expected", &rvalue->where); |
| return false; |
| } |
| else if (!rvalue->symtree) |
| { |
| gfc_error ("Pointer assignment target in initialization expression " |
| "does not have the TARGET attribute at %L", |
| &rvalue->where); |
| return false; |
| } |
| |
| sym = rvalue->symtree->n.sym; |
| |
| if (sym->ts.type == BT_CLASS && sym->attr.class_ok) |
| target = CLASS_DATA (sym)->attr.target; |
| else |
| target = sym->attr.target; |
| |
| if (!target && !proc_pointer) |
| { |
| gfc_error ("Pointer assignment target in initialization expression " |
| "does not have the TARGET attribute at %L", |
| &rvalue->where); |
| return false; |
| } |
| |
| for (ref = rvalue->ref; ref; ref = ref->next) |
| { |
| switch (ref->type) |
| { |
| case REF_ARRAY: |
| for (int n = 0; n < ref->u.ar.dimen; n++) |
| if (!gfc_is_constant_expr (ref->u.ar.start[n]) |
| || !gfc_is_constant_expr (ref->u.ar.end[n]) |
| || !gfc_is_constant_expr (ref->u.ar.stride[n])) |
| { |
| gfc_error ("Every subscript of target specification " |
| "at %L must be a constant expression", |
| &ref->u.ar.where); |
| return false; |
| } |
| break; |
| |
| case REF_SUBSTRING: |
| if (!gfc_is_constant_expr (ref->u.ss.start) |
| || !gfc_is_constant_expr (ref->u.ss.end)) |
| { |
| gfc_error ("Substring starting and ending points of target " |
| "specification at %L must be constant expressions", |
| &ref->u.ss.start->where); |
| return false; |
| } |
| break; |
| |
| default: |
| break; |
| } |
| } |
| } |
| else |
| { |
| if (!attr.target && !attr.pointer) |
| { |
| gfc_error ("Pointer assignment target is neither TARGET " |
| "nor POINTER at %L", &rvalue->where); |
| return false; |
| } |
| } |
| |
| if (lvalue->ts.type == BT_CHARACTER) |
| { |
| bool t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment"); |
| if (!t) |
| return false; |
| } |
| |
| if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym)) |
| { |
| gfc_error ("Bad target in pointer assignment in PURE " |
| "procedure at %L", &rvalue->where); |
| } |
| |
| if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym)) |
| gfc_unset_implicit_pure (gfc_current_ns->proc_name); |
| |
| if (gfc_has_vector_index (rvalue)) |
| { |
| gfc_error ("Pointer assignment with vector subscript " |
| "on rhs at %L", &rvalue->where); |
| return false; |
| } |
| |
| if (attr.is_protected && attr.use_assoc |
| && !(attr.pointer || attr.proc_pointer)) |
| { |
| gfc_error ("Pointer assignment target has PROTECTED " |
| "attribute at %L", &rvalue->where); |
| return false; |
| } |
| |
| /* F2008, C725. For PURE also C1283. */ |
| if (rvalue->expr_type == EXPR_VARIABLE |
| && gfc_is_coindexed (rvalue)) |
| { |
| gfc_ref *ref; |
| for (ref = rvalue->ref; ref; ref = ref->next) |
| if (ref->type == REF_ARRAY && ref->u.ar.codimen) |
| { |
| gfc_error ("Data target at %L shall not have a coindex", |
| &rvalue->where); |
| return false; |
| } |
| } |
| |
| /* Warn for assignments of contiguous pointers to targets which is not |
| contiguous. Be lenient in the definition of what counts as |
| contiguous. */ |
| |
| if (lhs_attr.contiguous |
| && lhs_attr.dimension > 0 |
| && !gfc_is_simply_contiguous (rvalue, false, true)) |
| gfc_warning (OPT_Wextra, "Assignment to contiguous pointer from " |
| "non-contiguous target at %L", &rvalue->where); |
| |
| /* Warn if it is the LHS pointer may lives longer than the RHS target. */ |
| if (warn_target_lifetime |
| && rvalue->expr_type == EXPR_VARIABLE |
| && !rvalue->symtree->n.sym->attr.save |
| && !rvalue->symtree->n.sym->attr.pointer && !attr.pointer |
| && !rvalue->symtree->n.sym->attr.host_assoc |
| && !rvalue->symtree->n.sym->attr.in_common |
| && !rvalue->symtree->n.sym->attr.use_assoc |
| && !rvalue->symtree->n.sym->attr.dummy) |
| { |
| bool warn; |
| gfc_namespace *ns; |
| |
| warn = lvalue->symtree->n.sym->attr.dummy |
| || lvalue->symtree->n.sym->attr.result |
| || lvalue->symtree->n.sym->attr.function |
| || (lvalue->symtree->n.sym->attr.host_assoc |
| && lvalue->symtree->n.sym->ns |
| != rvalue->symtree->n.sym->ns) |
| || lvalue->symtree->n.sym->attr.use_assoc |
| || lvalue->symtree->n.sym->attr.in_common; |
| |
| if (rvalue->symtree->n.sym->ns->proc_name |
| && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROCEDURE |
| && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROGRAM) |
| for (ns = rvalue->symtree->n.sym->ns; |
| ns && ns->proc_name && ns->proc_name->attr.flavor != FL_PROCEDURE; |
| ns = ns->parent) |
| if (ns->parent == lvalue->symtree->n.sym->ns) |
| { |
| warn = true; |
| break; |
| } |
| |
| if (warn) |
| gfc_warning (OPT_Wtarget_lifetime, |
| "Pointer at %L in pointer assignment might outlive the " |
| "pointer target", &lvalue->where); |
| } |
| |
| return true; |
| } |
| |
| |
| /* Relative of gfc_check_assign() except that the lvalue is a single |
| symbol. Used for initialization assignments. */ |
| |
| bool |
| gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue) |
| { |
| gfc_expr lvalue; |
| bool r; |
| bool pointer, proc_pointer; |
| |
| memset (&lvalue, '\0', sizeof (gfc_expr)); |
| |
| lvalue.expr_type = EXPR_VARIABLE; |
| lvalue.ts = sym->ts; |
| if (sym->as) |
| lvalue.rank = sym->as->rank; |
| lvalue.symtree = XCNEW (gfc_symtree); |
| lvalue.symtree->n.sym = sym; |
| lvalue.where = sym->declared_at; |
| |
| if (comp) |
| { |
| lvalue.ref = gfc_get_ref (); |
| lvalue.ref->type = REF_COMPONENT; |
| lvalue.ref->u.c.component = comp; |
| lvalue.ref->u.c.sym = sym; |
| lvalue.ts = comp->ts; |
| lvalue.rank = comp->as ? comp->as->rank : 0; |
| lvalue.where = comp->loc; |
| pointer = comp->ts.type == BT_CLASS && CLASS_DATA (comp) |
| ? CLASS_DATA (comp)->attr.class_pointer : comp->attr.pointer; |
| proc_pointer = comp->attr.proc_pointer; |
| } |
| else |
| { |
| pointer = sym->ts.type == BT_CLASS && CLASS_DATA (sym) |
| ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer; |
| proc_pointer = sym->attr.proc_pointer; |
| } |
| |
| if (pointer || proc_pointer) |
| r = gfc_check_pointer_assign (&lvalue, rvalue, false, true); |
| else |
| { |
| /* If a conversion function, e.g., __convert_i8_i4, was inserted |
| into an array constructor, we should check if it can be reduced |
| as an initialization expression. */ |
| if (rvalue->expr_type == EXPR_FUNCTION |
| && rvalue->value.function.isym |
| && (rvalue->value.function.isym->conversion == 1)) |
| gfc_check_init_expr (rvalue); |
| |
| r = gfc_check_assign (&lvalue, rvalue, 1); |
| } |
| |
| free (lvalue.symtree); |
| free (lvalue.ref); |
| |
| if (!r) |
| return r; |
| |
| if (pointer && rvalue->expr_type != EXPR_NULL && !proc_pointer) |
| { |
| /* F08:C461. Additional checks for pointer initialization. */ |
| symbol_attribute attr; |
| attr = gfc_expr_attr (rvalue); |
| if (attr.allocatable) |
| { |
| gfc_error ("Pointer initialization target at %L " |
| "must not be ALLOCATABLE", &rvalue->where); |
| return false; |
| } |
| if (!attr.target || attr.pointer) |
| { |
| gfc_error ("Pointer initialization target at %L " |
| "must have the TARGET attribute", &rvalue->where); |
| return false; |
| } |
| |
| if (!attr.save && rvalue->expr_type == EXPR_VARIABLE |
| && rvalue->symtree->n.sym->ns->proc_name |
| && rvalue->symtree->n.sym->ns->proc_name->attr.is_main_program) |
| { |
| rvalue->symtree->n.sym->ns->proc_name->attr.save = SAVE_IMPLICIT; |
| attr.save = SAVE_IMPLICIT; |
| } |
| |
| if (!attr.save) |
| { |
| gfc_error ("Pointer initialization target at %L " |
| "must have the SAVE attribute", &rvalue->where); |
| return false; |
| } |
| } |
| |
| if (proc_pointer && rvalue->expr_type != EXPR_NULL) |
| { |
| /* F08:C1220. Additional checks for procedure pointer initialization. */ |
| symbol_attribute attr = gfc_expr_attr (rvalue); |
| if (attr.proc_pointer) |
| { |
| gfc_error ("Procedure pointer initialization target at %L " |
| "may not be a procedure pointer", &rvalue->where); |
| return false; |
| } |
| if (attr.proc == PROC_INTERNAL) |
| { |
| gfc_error ("Internal procedure %qs is invalid in " |
| "procedure pointer initialization at %L", |
| rvalue->symtree->name, &rvalue->where); |
| return false; |
| } |
| if (attr.dummy) |
| { |
| gfc_error ("Dummy procedure %qs is invalid in " |
| "procedure pointer initialization at %L", |
| rvalue->symtree->name, &rvalue->where); |
| return false; |
| } |
| } |
| |
| return true; |
| } |
| |
| /* Invoke gfc_build_init_expr to create an initializer expression, but do not |
| * require that an expression be built. */ |
| |
| gfc_expr * |
| gfc_build_default_init_expr (gfc_typespec *ts, locus *where) |
| { |
| return gfc_build_init_expr (ts, where, false); |
| } |
| |
| /* Build an initializer for a local integer, real, complex, logical, or |
| character variable, based on the command line flags finit-local-zero, |
| finit-integer=, finit-real=, finit-logical=, and finit-character=. |
| With force, an initializer is ALWAYS generated. */ |
| |
| gfc_expr * |
| gfc_build_init_expr (gfc_typespec *ts, locus *where, bool force) |
| { |
| gfc_expr *init_expr; |
| |
| /* Try to build an initializer expression. */ |
| init_expr = gfc_get_constant_expr (ts->type, ts->kind, where); |
| |
| /* If we want to force generation, make sure we default to zero. */ |
| gfc_init_local_real init_real = flag_init_real; |
| int init_logical = gfc_option.flag_init_logical; |
| if (force) |
| { |
| if (init_real == GFC_INIT_REAL_OFF) |
| init_real = GFC_INIT_REAL_ZERO; |
| if (init_logical == GFC_INIT_LOGICAL_OFF) |
| init_logical = GFC_INIT_LOGICAL_FALSE; |
| } |
| |
| /* We will only initialize integers, reals, complex, logicals, and |
| characters, and only if the corresponding command-line flags |
| were set. Otherwise, we free init_expr and return null. */ |
| switch (ts->type) |
| { |
| case BT_INTEGER: |
| if (force || gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF) |
| mpz_set_si (init_expr->value.integer, |
| gfc_option.flag_init_integer_value); |
| else |
| { |
| gfc_free_expr (init_expr); |
| init_expr = NULL; |
| } |
| break; |
| |
| case BT_REAL: |
| switch (init_real) |
| { |
| case GFC_INIT_REAL_SNAN: |
| init_expr->is_snan = 1; |
| /* Fall through. */ |
| case GFC_INIT_REAL_NAN: |
| mpfr_set_nan (init_expr->value.real); |
| break; |
| |
| case GFC_INIT_REAL_INF: |
| mpfr_set_inf (init_expr->value.real, 1); |
| break; |
| |
| case GFC_INIT_REAL_NEG_INF: |
| mpfr_set_inf (init_expr->value.real, -1); |
| break; |
| |
| case GFC_INIT_REAL_ZERO: |
| mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE); |
| break; |
| |
| default: |
| gfc_free_expr (init_expr); |
| init_expr = NULL; |
| break; |
| } |
| break; |
| |
| case BT_COMPLEX: |
| switch (init_real) |
| { |
| case GFC_INIT_REAL_SNAN: |
| init_expr->is_snan = 1; |
| /* Fall through. */ |
| case GFC_INIT_REAL_NAN: |
| mpfr_set_nan (mpc_realref (init_expr->value.complex)); |
| mpfr_set_nan (mpc_imagref (init_expr->value.complex)); |
| break; |
| |
| case GFC_INIT_REAL_INF: |
| mpfr_set_inf (mpc_realref (init_expr->value.complex), 1); |
| mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1); |
| break; |
| |
| case GFC_INIT_REAL_NEG_INF: |
| mpfr_set_inf (mpc_realref (init_expr->value.complex), -1); |
| mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1); |
| break; |
| |
| case GFC_INIT_REAL_ZERO: |
| mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE); |
| break; |
| |
| default: |
| gfc_free_expr (init_expr); |
| init_expr = NULL; |
| break; |
| } |
| break; |
| |
| case BT_LOGICAL: |
| if (init_logical == GFC_INIT_LOGICAL_FALSE) |
| init_expr->value.logical = 0; |
| else if (init_logical == GFC_INIT_LOGICAL_TRUE) |
| init_expr->value.logical = 1; |
| else |
| { |
| gfc_free_expr (init_expr); |
| init_expr = NULL; |
| } |
| break; |
| |
| case BT_CHARACTER: |
| /* For characters, the length must be constant in order to |
| create a default initializer. */ |
| if ((force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON) |
| && ts->u.cl->length |
| && ts->u.cl->length->expr_type == EXPR_CONSTANT) |
| { |
| HOST_WIDE_INT char_len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); |
| init_expr->value.character.length = char_len; |
| init_expr->value.character.string = gfc_get_wide_string (char_len+1); |
| for (size_t i = 0; i < (size_t) char_len; i++) |
| init_expr->value.character.string[i] |
| = (unsigned char) gfc_option.flag_init_character_value; |
| } |
| else |
| { |
| gfc_free_expr (init_expr); |
| init_expr = NULL; |
| } |
| if (!init_expr |
| && (force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON) |
| && ts->u.cl->length && flag_max_stack_var_size != 0) |
| { |
| gfc_actual_arglist *arg; |
| init_expr = gfc_get_expr (); |
| init_expr->where = *where; |
| init_expr->ts = *ts; |
| init_expr->expr_type = EXPR_FUNCTION; |
| init_expr->value.function.isym = |
| gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT); |
| init_expr->value.function.name = "repeat"; |
| arg = gfc_get_actual_arglist (); |
| arg->expr = gfc_get_character_expr (ts->kind, where, NULL, 1); |
| arg->expr->value.character.string[0] = |
| gfc_option.flag_init_character_value; |
| arg->next = gfc_get_actual_arglist (); |
| arg->next->expr = gfc_copy_expr (ts->u.cl->length); |
| init_expr->value.function.actual = arg; |
| } |
| break; |
| |
| default: |
| gfc_free_expr (init_expr); |
| init_expr = NULL; |
| } |
| |
| return init_expr; |
| } |
| |
| /* Apply an initialization expression to a typespec. Can be used for symbols or |
| components. Similar to add_init_expr_to_sym in decl.c; could probably be |
| combined with some effort. */ |
| |
| void |
| gfc_apply_init (gfc_typespec *ts, symbol_attribute *attr, gfc_expr *init) |
| { |
| if (ts->type == BT_CHARACTER && !attr->pointer && init |
| && ts->u.cl |
| && ts->u.cl->length |
| && ts->u.cl->length->expr_type == EXPR_CONSTANT |
| && ts->u.cl->length->ts.type == BT_INTEGER) |
| { |
| HOST_WIDE_INT len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); |
| |
| if (init->expr_type == EXPR_CONSTANT) |
| gfc_set_constant_character_len (len, init, -1); |
| else if (init |
| && init->ts.type == BT_CHARACTER |
| && init->ts.u.cl && init->ts.u.cl->length |
| && mpz_cmp (ts->u.cl->length->value.integer, |
| init->ts.u.cl->length->value.integer)) |
| { |
| gfc_constructor *ctor; |
| ctor = gfc_constructor_first (init->value.constructor); |
| |
| if (ctor) |
| { |
| bool has_ts = (init->ts.u.cl |
| && init->ts.u.cl->length_from_typespec); |
| |
| /* Remember the length of the first element for checking |
| that all elements *in the constructor* have the same |
| length. This need not be the length of the LHS! */ |
| gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT); |
| gcc_assert (ctor->expr->ts.type == BT_CHARACTER); |
| gfc_charlen_t first_len = ctor->expr->value.character.length; |
| |
| for ( ; ctor; ctor = gfc_constructor_next (ctor)) |
| if (ctor->expr->expr_type == EXPR_CONSTANT) |
| { |
| gfc_set_constant_character_len (len, ctor->expr, |
| has_ts ? -1 : first_len); |
| if (!ctor->expr->ts.u.cl) |
| ctor->expr->ts.u.cl |
| = gfc_new_charlen (gfc_current_ns, ts->u.cl); |
| else |
| ctor->expr->ts.u.cl->length |
| = gfc_copy_expr (ts->u.cl->length); |
| } |
| } |
| } |
| } |
| } |
| |
| |
| /* Check whether an expression is a structure constructor and whether it has |
| other values than NULL. */ |
| |
| bool |
| is_non_empty_structure_constructor (gfc_expr * e) |
| { |
| if (e->expr_type != EXPR_STRUCTURE) |
| return false; |
| |
| gfc_constructor *cons = gfc_constructor_first (e->value.constructor); |
| while (cons) |
| { |
| if (!cons->expr || cons->expr->expr_type != EXPR_NULL) |
| return true; |
| cons = gfc_constructor_next (cons); |
| } |
| return false; |
| } |
| |
| |
| /* Check for default initializer; sym->value is not enough |
| as it is also set for EXPR_NULL of allocatables. */ |
| |
| bool |
| gfc_has_default_initializer (gfc_symbol *der) |
| { |
| gfc_component *c; |
| |
| gcc_assert (gfc_fl_struct (der->attr.flavor)); |
| for (c = der->components; c; c = c->next) |
| if (gfc_bt_struct (c->ts.type)) |
| { |
| if (!c->attr.pointer && !c->attr.proc_pointer |
| && !(c->attr.allocatable && der == c->ts.u.derived) |
| && ((c->initializer |
| && is_non_empty_structure_constructor (c->initializer)) |
| || gfc_has_default_initializer (c->ts.u.derived))) |
| return true; |
| if (c->attr.pointer && c->initializer) |
| return true; |
| } |
| else |
| { |
| if (c->initializer) |
| return true; |
| } |
| |
| return false; |
| } |
| |
| |
| /* |
| Generate an initializer expression which initializes the entirety of a union. |
| A normal structure constructor is insufficient without undue effort, because |
| components of maps may be oddly aligned/overlapped. (For example if a |
| character is initialized from one map overtop a real from the other, only one |
| byte of the real is actually initialized.) Unfortunately we don't know the |
| size of the union right now, so we can't generate a proper initializer, but |
| we use a NULL expr as a placeholder and do the right thing later in |
| gfc_trans_subcomponent_assign. |
| */ |
| static gfc_expr * |
| generate_union_initializer (gfc_component *un) |
| { |
| if (un == NULL || un->ts.type != BT_UNION) |
| return NULL; |
| |
| gfc_expr *placeholder = gfc_get_null_expr (&un->loc); |
| placeholder->ts = un->ts; |
| return placeholder; |
| } |
| |
| |
| /* Get the user-specified initializer for a union, if any. This means the user |
| has said to initialize component(s) of a map. For simplicity's sake we |
| only allow the user to initialize the first map. We don't have to worry |
| about overlapping initializers as they are released early in resolution (see |
| resolve_fl_struct). */ |
| |
| static gfc_expr * |
| get_union_initializer (gfc_symbol *union_type, gfc_component **map_p) |
| { |
| gfc_component *map; |
| gfc_expr *init=NULL; |
| |
| if (!union_type || union_type->attr.flavor != FL_UNION) |
| return NULL; |
| |
| for (map = union_type->components; map; map = map->next) |
| { |
| if (gfc_has_default_initializer (map->ts.u.derived)) |
| { |
| init = gfc_default_initializer (&map->ts); |
| if (map_p) |
| *map_p = map; |
| break; |
| } |
| } |
| |
| if (map_p && !init) |
| *map_p = NULL; |
| |
| return init; |
| } |
| |
| static bool |
| class_allocatable (gfc_component *comp) |
| { |
| return comp->ts.type == BT_CLASS && CLASS_DATA (comp) |
| && CLASS_DATA (comp)->attr.allocatable; |
| } |
| |
| static bool |
| class_pointer (gfc_component *comp) |
| { |
| return comp->ts.type == BT_CLASS && CLASS_DATA (comp) |
| && CLASS_DATA (comp)->attr.pointer; |
| } |
| |
| static bool |
| comp_allocatable (gfc_component *comp) |
| { |
| return comp->attr.allocatable || class_allocatable (comp); |
| } |
| |
| static bool |
| comp_pointer (gfc_component *comp) |
| { |
| return comp->attr.pointer |
| || comp->attr.proc_pointer |
| || comp->attr.class_pointer |
| || class_pointer (comp); |
| } |
| |
| /* Fetch or generate an initializer for the given component. |
| Only generate an initializer if generate is true. */ |
| |
| static gfc_expr * |
| component_initializer (gfc_component *c, bool generate) |
| { |
| gfc_expr *init = NULL; |
| |
| /* Allocatable components always get EXPR_NULL. |
| Pointer components are only initialized when generating, and only if they |
| do not already have an initializer. */ |
| if (comp_allocatable (c) || (generate && comp_pointer (c) && !c->initializer)) |
| { |
| init = gfc_get_null_expr (&c->loc); |
| init->ts = c->ts; |
| return init; |
| } |
| |
| /* See if we can find the initializer immediately. */ |
| if (c->initializer || !generate) |
| return c->initializer; |
| |
| /* Recursively handle derived type components. */ |
| else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) |
| init = gfc_generate_initializer (&c->ts, true); |
| |
| else if (c->ts.type == BT_UNION && c->ts.u.derived->components) |
| { |
| gfc_component *map = NULL; |
| gfc_constructor *ctor; |
| gfc_expr *user_init; |
| |
| /* If we don't have a user initializer and we aren't generating one, this |
| union has no initializer. */ |
| user_init = get_union_initializer (c->ts.u.derived, &map); |
| if (!user_init && !generate) |
| return NULL; |
| |
| /* Otherwise use a structure constructor. */ |
| init = gfc_get_structure_constructor_expr (c->ts.type, c->ts.kind, |
| &c->loc); |
| init->ts = c->ts; |
| |
| /* If we are to generate an initializer for the union, add a constructor |
| which initializes the whole union first. */ |
| if (generate) |
| { |
| ctor = gfc_constructor_get (); |
| ctor->expr = generate_union_initializer (c); |
| gfc_constructor_append (&init->value.constructor, ctor); |
| } |
| |
| /* If we found an initializer in one of our maps, apply it. Note this |
| is applied _after_ the entire-union initializer above if any. */ |
| if (user_init) |
| { |
| ctor = gfc_constructor_get (); |
| ctor->expr = user_init; |
| ctor->n.component = map; |
| gfc_constructor_append (&init->value.constructor, ctor); |
| } |
| } |
| |
| /* Treat simple components like locals. */ |
| else |
| { |
| /* We MUST give an initializer, so force generation. */ |
| init = gfc_build_init_expr (&c->ts, &c->loc, true); |
| gfc_apply_init (&c->ts, &c->attr, init); |
| } |
| |
| return init; |
| } |
| |
| |
| /* Get an expression for a default initializer of a derived type. */ |
| |
| gfc_expr * |
| gfc_default_initializer (gfc_typespec *ts) |
| { |
| return gfc_generate_initializer (ts, false); |
| } |
| |
| /* Generate an initializer expression for an iso_c_binding type |
| such as c_[fun]ptr. The appropriate initializer is c_null_[fun]ptr. */ |
| |
| static gfc_expr * |
| generate_isocbinding_initializer (gfc_symbol *derived) |
| { |
| /* The initializers have already been built into the c_null_[fun]ptr symbols |
| from gen_special_c_interop_ptr. */ |
| gfc_symtree *npsym = NULL; |
| if (0 == strcmp (derived->name, "c_ptr")) |
| gfc_find_sym_tree ("c_null_ptr", gfc_current_ns, true, &npsym); |
| else if (0 == strcmp (derived->name, "c_funptr")) |
| gfc_find_sym_tree ("c_null_funptr", gfc_current_ns, true, &npsym); |
| else |
| gfc_internal_error ("generate_isocbinding_initializer(): bad iso_c_binding" |
| " type, expected %<c_ptr%> or %<c_funptr%>"); |
| if (npsym) |
| { |
| gfc_expr *init = gfc_copy_expr (npsym->n.sym->value); |
| init->symtree = npsym; |
| init->ts.is_iso_c = true; |
| return init; |
| } |
| |
| return NULL; |
| } |
| |
| /* Get or generate an expression for a default initializer of a derived type. |
| If -finit-derived is specified, generate default initialization expressions |
| for components that lack them when generate is set. */ |
| |
| gfc_expr * |
| gfc_generate_initializer (gfc_typespec *ts, bool generate) |
| { |
| gfc_expr *init, *tmp; |
| gfc_component *comp; |
| |
| generate = flag_init_derived && generate; |
| |
| if (ts->u.derived->ts.is_iso_c && generate) |
| return generate_isocbinding_initializer (ts->u.derived); |
| |
| /* See if we have a default initializer in this, but not in nested |
| types (otherwise we could use gfc_has_default_initializer()). |
| We don't need to check if we are going to generate them. */ |
| comp = ts->u.derived->components; |
| if (!generate) |
| { |
| for (; comp; comp = comp->next) |
| if (comp->initializer || comp_allocatable (comp)) |
| break; |
| } |
| |
| if (!comp) |
| return NULL; |
| |
| init = gfc_get_structure_constructor_expr (ts->type, ts->kind, |
| &ts->u.derived->declared_at); |
| init->ts = *ts; |
| |
| for (comp = ts->u.derived->components; comp; comp = comp->next) |
| { |
| gfc_constructor *ctor = gfc_constructor_get(); |
| |
| /* Fetch or generate an initializer for the component. */ |
| tmp = component_initializer (comp, generate); |
| if (tmp) |
| { |
| /* Save the component ref for STRUCTUREs and UNIONs. */ |
| if (ts->u.derived->attr.flavor == FL_STRUCT |
| || ts->u.derived->attr.flavor == FL_UNION) |
| ctor->n.component = comp; |
| |
| /* If the initializer was not generated, we need a copy. */ |
| ctor->expr = comp->initializer ? gfc_copy_expr (tmp) : tmp; |
| if ((comp->ts.type != tmp->ts.type || comp->ts.kind != tmp->ts.kind) |
| && !comp->attr.pointer && !comp->attr.proc_pointer) |
| { |
| bool val; |
| val = gfc_convert_type_warn (ctor->expr, &comp->ts, 1, false); |
| if (val == false) |
| return NULL; |
| } |
| } |
| |
| gfc_constructor_append (&init->value.constructor, ctor); |
| } |
| |
| return init; |
| } |
| |
| |
| /* Given a symbol, create an expression node with that symbol as a |
| variable. If the symbol is array valued, setup a reference of the |
| whole array. */ |
| |
| gfc_expr * |
| gfc_get_variable_expr (gfc_symtree *var) |
| { |
| gfc_expr *e; |
| |
| e = gfc_get_expr (); |
| e->expr_type = EXPR_VARIABLE; |
| e->symtree = var; |
| e->ts = var->n.sym->ts; |
| |
| if (var->n.sym->attr.flavor != FL_PROCEDURE |
| && ((var->n.sym->as != NULL && var->n.sym->ts.type != BT_CLASS) |
| || (var->n.sym->ts.type == BT_CLASS && var->n.sym->ts.u.derived |
| && CLASS_DATA (var->n.sym) |
| && CLASS_DATA (var->n.sym)->as))) |
| { |
| e->rank = var->n.sym->ts.type == BT_CLASS |
| ? CLASS_DATA (var->n.sym)->as->rank : var->n.sym->as->rank; |
| e->ref = gfc_get_ref (); |
| e->ref->type = REF_ARRAY; |
| e->ref->u.ar.type = AR_FULL; |
| e->ref->u.ar.as = gfc_copy_array_spec (var->n.sym->ts.type == BT_CLASS |
| ? CLASS_DATA (var->n.sym)->as |
| : var->n.sym->as); |
| } |
| |
| return e; |
| } |
| |
| |
| /* Adds a full array reference to an expression, as needed. */ |
| |
| void |
| gfc_add_full_array_ref (gfc_expr *e, gfc_array_spec *as) |
| { |
| gfc_ref *ref; |
| for (ref = e->ref; ref; ref = ref->next) |
| if (!ref->next) |
| break; |
| if (ref) |
| { |
| ref->next = gfc_get_ref (); |
| ref = ref->next; |
| } |
| else |
| { |
| e->ref = gfc_get_ref (); |
| ref = e->ref; |
| } |
| ref->type = REF_ARRAY; |
| ref->u.ar.type = AR_FULL; |
| ref->u.ar.dimen = e->rank; |
| ref->u.ar.where = e->where; |
| ref->u.ar.as = as; |
| } |
| |
| |
| gfc_expr * |
| gfc_lval_expr_from_sym (gfc_symbol *sym) |
| { |
| gfc_expr *lval; |
| gfc_array_spec *as; |
| lval = gfc_get_expr (); |
| lval->expr_type = EXPR_VARIABLE; |
| lval->where = sym->declared_at; |
| lval->ts = sym->ts; |
| lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name); |
| |
| /* It will always be a full array. */ |
| as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; |
| lval->rank = as ? as->rank : 0; |
| if (lval->rank) |
| gfc_add_full_array_ref (lval, as); |
| return lval; |
| } |
| |
| |
| /* Returns the array_spec of a full array expression. A NULL is |
| returned otherwise. */ |
| gfc_array_spec * |
| gfc_get_full_arrayspec_from_expr (gfc_expr *expr) |
| { |
| gfc_array_spec *as; |
| gfc_ref *ref; |
| |
| if (expr->rank == 0) |
| return NULL; |
| |
| /* Follow any component references. */ |
| if (expr->expr_type == EXPR_VARIABLE |
| || expr->expr_type == EXPR_CONSTANT) |
| { |
| if (expr->symtree) |
| as = expr->symtree->n.sym->as; |
| else |
| as = NULL; |
| |
| for (ref = expr->ref; ref; ref = ref->next) |
| { |
| switch (ref->type) |
| { |
| case REF_COMPONENT: |
| as = ref->u.c.component->as; |
| continue; |
| |
| case REF_SUBSTRING: |
| case REF_INQUIRY: |
| continue; |
| |
| case REF_ARRAY: |
| { |
| switch (ref->u.ar.type) |
| { |
| case AR_ELEMENT: |
| case AR_SECTION: |
| case AR_UNKNOWN: |
| as = NULL; |
| continue; |
| |
| case AR_FULL: |
| break; |
| } |
| break; |
| } |
| } |
| } |
| } |
| else |
| as = NULL; |
| |
| return as; |
| } |
| |
| |
| /* General expression traversal function. */ |
| |
| bool |
| gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym, |
| bool (*func)(gfc_expr *, gfc_symbol *, int*), |
| int f) |
| { |
| gfc_array_ref ar; |
| gfc_ref *ref; |
| gfc_actual_arglist *args; |
| gfc_constructor *c; |
| int i; |
| |
| if (!expr) |
| return false; |
| |
| if ((*func) (expr, sym, &f)) |
| return true; |
| |
| if (expr->ts.type == BT_CHARACTER |
| && expr->ts.u.cl |
| && expr->ts.u.cl->length |
| && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT |
| && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f)) |
| return true; |
| |
| switch (expr->expr_type) |
| { |
| case EXPR_PPC: |
| case EXPR_COMPCALL: |
| case EXPR_FUNCTION: |
| for (args = expr->value.function.actual; args; args = args->next) |
| { |
| if (gfc_traverse_expr (args->expr, sym, func, f)) |
| return true; |
| } |
| break; |
| |
| case EXPR_VARIABLE: |
| case EXPR_CONSTANT: |
| case EXPR_NULL: |
| case EXPR_SUBSTRING: |
| break; |
| |
| case EXPR_STRUCTURE: |
| case EXPR_ARRAY: |
| for (c = gfc_constructor_first (expr->value.constructor); |
| c; c = gfc_constructor_next (c)) |
| { |
| if (gfc_traverse_expr (c->expr, sym, func, f)) |
| return true; |
| if (c->iterator) |
| { |
| if (gfc_traverse_expr (c->iterator->var, sym, func, f)) |
| return true; |
| if (gfc_traverse_expr (c->iterator->start, sym, func, f)) |
| return true; |
| if (gfc_traverse_expr (c->iterator->end, sym, func, f)) |
| return true; |
| if (gfc_traverse_expr (c->iterator->step, sym, func, f)) |
| return true; |
| } |
| } |
| break; |
| |
| case EXPR_OP: |
| if (gfc_traverse_expr (expr->value.op.op1, sym, func, f)) |
| return true; |
| if (gfc_traverse_expr (expr->value.op.op2, sym, func, f)) |
| return true; |
| break; |
| |
| default: |
| gcc_unreachable (); |
| break; |
| } |
| |
| ref = expr->ref; |
| while (ref != NULL) |
| { |
| switch (ref->type) |
| { |
| case REF_ARRAY: |
| ar = ref->u.ar; |
| for (i = 0; i < GFC_MAX_DIMENSIONS; i++) |
| { |
| if (gfc_traverse_expr (ar.start[i], sym, func, f)) |
| return true; |
| if (gfc_traverse_expr (ar.end[i], sym, func, f)) |
| return true; |
| if (gfc_traverse_expr (ar.stride[i], sym, func, f)) |
| return true; |
| } |
| break; |
| |
| case REF_SUBSTRING: |
| if (gfc_traverse_expr (ref->u.ss.start, sym, func, f)) |
| return true; |
| if (gfc_traverse_expr (ref->u.ss.end, sym, func, f)) |
| return true; |
| break; |
| |
| case REF_COMPONENT: |
| if (ref->u.c.component->ts.type == BT_CHARACTER |
| && ref->u.c.component->ts.u.cl |
| && ref->u.c.component->ts.u.cl->length |
| && ref->u.c.component->ts.u.cl->length->expr_type |
| != EXPR_CONSTANT |
| && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length, |
| sym, func, f)) |
| return true; |
| |
| if (ref->u.c.component->as) |
| for (i = 0; i < ref->u.c.component->as->rank |
| + ref->u.c.component->as->corank; i++) |
| { |
| if (gfc_traverse_expr (ref->u.c.component->as->lower[i], |
| sym, func, f)) |
| return true; |
| if (gfc_traverse_expr (ref->u.c.component->as->upper[i], |
| sym, func, f)) |
| return true; |
| } |
| break; |
| |
| case REF_INQUIRY: |
| return true; |
| |
| default: |
| gcc_unreachable (); |
| } |
| ref = ref->next; |
| } |
| return false; |
| } |
| |
| /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */ |
| |
| static bool |
| expr_set_symbols_referenced (gfc_expr *expr, |
| gfc_symbol *sym ATTRIBUTE_UNUSED, |
| int *f ATTRIBUTE_UNUSED) |
| { |
| if (expr->expr_type != EXPR_VARIABLE) |
| return false; |
| gfc_set_sym_referenced (expr->symtree->n.sym); |
| return false; |
| } |
| |
| void |
| gfc_expr_set_symbols_referenced (gfc_expr *expr) |
| { |
| gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0); |
| } |
| |
| |
| /* Determine if an expression is a procedure pointer component and return |
| the component in that case. Otherwise return NULL. */ |
| |
| gfc_component * |
| gfc_get_proc_ptr_comp (gfc_expr *expr) |
| { |
| gfc_ref *ref; |
| |
| if (!expr || !expr->ref) |
| return NULL; |
| |
| ref = expr->ref; |
| while (ref->next) |
| ref = ref->next; |
| |
| if (ref->type == REF_COMPONENT |
| && ref->u.c.component->attr.proc_pointer) |
| return ref->u.c.component; |
| |
| return NULL; |
| } |
| |
| |
| /* Determine if an expression is a procedure pointer component. */ |
| |
| bool |
| gfc_is_proc_ptr_comp (gfc_expr *expr) |
| { |
| return (gfc_get_proc_ptr_comp (expr) != NULL); |
| } |
| |
| |
| /* Determine if an expression is a function with an allocatable class scalar |
| result. */ |
| bool |
| gfc_is_alloc_class_scalar_function (gfc_expr *expr) |
| { |
| if (expr->expr_type == EXPR_FUNCTION |
| && expr->value.function.esym |
| && expr->value.function.esym->result |
| && expr->value.function.esym->result->ts.type == BT_CLASS |
| && !CLASS_DATA (expr->value.function.esym->result)->attr.dimension |
| && CLASS_DATA (expr->value.function.esym->result)->attr.allocatable) |
| return true; |
| |
| return false; |
| } |
| |
| |
| /* Determine if an expression is a function with an allocatable class array |
| result. */ |
| bool |
| gfc_is_class_array_function (gfc_expr *expr) |
| { |
| if (expr->expr_type == EXPR_FUNCTION |
| && expr->value.function.esym |
| && expr->value.function.esym->result |
| && expr->value.function.esym->result->ts.type == BT_CLASS |
| && CLASS_DATA (expr->value.function.esym->result)->attr.dimension |
| && (CLASS_DATA (expr->value.function.esym->result)->attr.allocatable |
| || CLASS_DATA (expr->value.function.esym->result)->attr.pointer)) |
| return true; |
| |
| return false; |
| } |
| |
| |
| /* Walk an expression tree and check each variable encountered for being typed. |
| If strict is not set, a top-level variable is tolerated untyped in -std=gnu |
| mode as is a basic arithmetic expression using those; this is for things in |
| legacy-code like: |
| |
| INTEGER :: arr(n), n |
| INTEGER :: arr(n + 1), n |
| |
| The namespace is needed for IMPLICIT typing. */ |
| |
| static gfc_namespace* check_typed_ns; |
| |
| static bool |
| expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED, |
| int* f ATTRIBUTE_UNUSED) |
| { |
| bool t; |
| |
| if (e->expr_type != EXPR_VARIABLE) |
| return false; |
| |
| gcc_assert (e->symtree); |
| t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns, |
| true, e->where); |
| |
| return (!t); |
| } |
| |
| bool |
| gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict) |
| { |
| bool error_found; |
| |
| /* If this is a top-level variable or EXPR_OP, do the check with strict given |
| to us. */ |
| if (!strict) |
| { |
| if (e->expr_type == EXPR_VARIABLE && !e->ref) |
| return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where); |
| |
| if (e->expr_type == EXPR_OP) |
| { |
| bool t = true; |
| |
| gcc_assert (e->value.op.op1); |
| t = gfc_expr_check_typed (e->value.op.op1, ns, strict); |
| |
| if (t && e->value.op.op2) |
| t = gfc_expr_check_typed (e->value.op.op2, ns, strict); |
| |
| return t; |
| } |
| } |
| |
| /* Otherwise, walk the expression and do it strictly. */ |
| check_typed_ns = ns; |
| error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0); |
| |
| return error_found ? false : true; |
| } |
| |
| |
| /* This function returns true if it contains any references to PDT KIND |
| or LEN parameters. */ |
| |
| static bool |
| derived_parameter_expr (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED, |
| int* f ATTRIBUTE_UNUSED) |
| { |
| if (e->expr_type != EXPR_VARIABLE) |
| return false; |
| |
| gcc_assert (e->symtree); |
| if (e->symtree->n.sym->attr.pdt_kind |
| || e->symtree->n.sym->attr.pdt_len) |
| return true; |
| |
| return false; |
| } |
| |
| |
| bool |
| gfc_derived_parameter_expr (gfc_expr *e) |
| { |
| return gfc_traverse_expr (e, NULL, &derived_parameter_expr, 0); |
| } |
| |
| |
| /* This function returns the overall type of a type parameter spec list. |
| If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the |
| parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned |
| unless derived is not NULL. In this latter case, all the LEN parameters |
| must be either assumed or deferred for the return argument to be set to |
| anything other than SPEC_EXPLICIT. */ |
| |
| gfc_param_spec_type |
| gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived) |
| { |
| gfc_param_spec_type res = SPEC_EXPLICIT; |
| gfc_component *c; |
| bool seen_assumed = false; |
| bool seen_deferred = false; |
| |
| if (derived == NULL) |
| { |
| for (; param_list; param_list = param_list->next) |
| if (param_list->spec_type == SPEC_ASSUMED |
| || param_list->spec_type == SPEC_DEFERRED) |
| return param_list->spec_type; |
| } |
| else |
| { |
| for (; param_list; param_list = param_list->next) |
| { |
| c = gfc_find_component (derived, param_list->name, |
| true, true, NULL); |
| gcc_assert (c != NULL); |
| if (c->attr.pdt_kind) |
| continue; |
| else if (param_list->spec_type == SPEC_EXPLICIT) |
| return SPEC_EXPLICIT; |
| seen_assumed = param_list->spec_type == SPEC_ASSUMED; |
| seen_deferred = param_list->spec_type == SPEC_DEFERRED; |
| if (seen_assumed && seen_deferred) |
| return SPEC_EXPLICIT; |
| } |
| res = seen_assumed ? SPEC_ASSUMED : SPEC_DEFERRED; |
| } |
| return res; |
| } |
| |
| |
| bool |
| gfc_ref_this_image (gfc_ref *ref) |
| { |
| int n; |
| |
| gcc_assert (ref->type == REF_ARRAY && ref->u.ar.codimen > 0); |
| |
| for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++) |
| if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE) |
| return false; |
| |
| return true; |
| } |
| |
| gfc_expr * |
| gfc_find_team_co (gfc_expr *e) |
| { |
| gfc_ref *ref; |
| |
| for (ref = e->ref; ref; ref = ref->next) |
| if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) |
| return ref->u.ar.team; |
| |
| if (e->value.function.actual->expr) |
| for (ref = e->value.function.actual->expr->ref; ref; |
| ref = ref->next) |
| if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) |
| return ref->u.ar.team; |
| |
| return NULL; |
| } |
| |
| gfc_expr * |
| gfc_find_stat_co (gfc_expr *e) |
| { |
| gfc_ref *ref; |
| |
| for (ref = e->ref; ref; ref = ref->next) |
| if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) |
| return ref->u.ar.stat; |
| |
| if (e->value.function.actual->expr) |
| for (ref = e->value.function.actual->expr->ref; ref; |
| ref = ref->next) |
| if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) |
| return ref->u.ar.stat; |
| |
| return NULL; |
| } |
| |
| bool |
| gfc_is_coindexed (gfc_expr *e) |
| { |
| gfc_ref *ref; |
| |
| for (ref = e->ref; ref; ref = ref->next) |
| if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) |
| return !gfc_ref_this_image (ref); |
| |
| return false; |
| } |
| |
| |
| /* Coarrays are variables with a corank but not being coindexed. However, also |
| the following is a coarray: A subobject of a coarray is a coarray if it does |
| not have any cosubscripts, vector subscripts, allocatable component |
| selection, or pointer component selection. (F2008, 2.4.7) */ |
| |
| bool |
| gfc_is_coarray (gfc_expr *e) |
| { |
| gfc_ref *ref; |
| gfc_symbol *sym; |
| gfc_component *comp; |
| bool coindexed; |
| bool coarray; |
| int i; |
| |
| if (e->expr_type != EXPR_VARIABLE) |
| return false; |
| |
| coindexed = false; |
| sym = e->symtree->n.sym; |
| |
| if (sym->ts.type == BT_CLASS && sym->attr.class_ok) |
| coarray = CLASS_DATA (sym)->attr.codimension; |
| else |
| coarray = sym->attr.codimension; |
| |
| for (ref = e->ref; ref; ref = ref->next) |
| switch (ref->type) |
| { |
| case REF_COMPONENT: |
| comp = ref->u.c.component; |
| if (comp->ts.type == BT_CLASS && comp->attr.class_ok |
| && (CLASS_DATA (comp)->attr.class_pointer |
| || CLASS_DATA (comp)->attr.allocatable)) |
| { |
| coindexed = false; |
| coarray = CLASS_DATA (comp)->attr.codimension; |
| } |
| else if (comp->attr.pointer || comp->attr.allocatable) |
| { |
| coindexed = false; |
| coarray = comp->attr.codimension; |
| } |
| break; |
| |
| case REF_ARRAY: |
| if (!coarray) |
| break; |
| |
| if (ref->u.ar.codimen > 0 && !gfc_ref_this_image (ref)) |
| { |
| coindexed = true; |
| break; |
| } |
| |
| for (i = 0; i < ref->u.ar.dimen; i++) |
| if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) |
| { |
| coarray = false; |
| break; |
| } |
| break; |
| |
| case REF_SUBSTRING: |
| case REF_INQUIRY: |
| break; |
| } |
| |
| return coarray && !coindexed; |
| } |
| |
| |
| int |
| gfc_get_corank (gfc_expr *e) |
| { |
| int corank; |
| gfc_ref *ref; |
| |
| if (!gfc_is_coarray (e)) |
| return 0; |
| |
| if (e->ts.type == BT_CLASS && e->ts.u.derived->components) |
| corank = e->ts.u.derived->components->as |
| ? e->ts.u.derived->components->as->corank : 0; |
| else |
| corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0; |
| |
| for (ref = e->ref; ref; ref = ref->next) |
| { |
| if (ref->type == REF_ARRAY) |
| corank = ref->u.ar.as->corank; |
| gcc_assert (ref->type != REF_SUBSTRING); |
| } |
| |
| return corank; |
| } |
| |
| |
| /* Check whether the expression has an ultimate allocatable component. |
| Being itself allocatable does not count. */ |
| bool |
| gfc_has_ultimate_allocatable (gfc_expr *e) |
| { |
| gfc_ref *ref, *last = NULL; |
| |
| if (e->expr_type != EXPR_VARIABLE) |
| return false; |
| |
| for (ref = e->ref; ref; ref = ref->next) |
| if (ref->type == REF_COMPONENT) |
| last = ref; |
| |
| if (last && last->u.c.component->ts.type == BT_CLASS) |
| return CLASS_DATA (last->u.c.component)->attr.alloc_comp; |
| else if (last && last->u.c.component->ts.type == BT_DERIVED) |
| return last->u.c.component->ts.u.derived->attr.alloc_comp; |
| else if (last) |
| return false; |
| |
| if (e->ts.type == BT_CLASS) |
| return CLASS_DATA (e)->attr.alloc_comp; |
| else if (e->ts.type == BT_DERIVED) |
| return e->ts.u.derived->attr.alloc_comp; |
| else |
| return false; |
| } |
| |
| |
| /* Check whether the expression has an pointer component. |
| Being itself a pointer does not count. */ |
| bool |
| gfc_has_ultimate_pointer (gfc_expr *e) |
| { |
| gfc_ref *ref, *last = NULL; |
| |
| if (e->expr_type != EXPR_VARIABLE) |
| return false; |
| |
| for (ref = e->ref; ref; ref = ref->next) |
| if (ref->type == REF_COMPONENT) |
| last = ref; |
| |
| if (last && last->u.c.component->ts.type == BT_CLASS) |
| return CLASS_DATA (last->u.c.component)->attr.pointer_comp; |
| else if (last && last->u.c.component->ts.type == BT_DERIVED) |
| return last->u.c.component->ts.u.derived->attr.pointer_comp; |
| else if (last) |
| return false; |
| |
| if (e->ts.type == BT_CLASS) |
| return CLASS_DATA (e)->attr.pointer_comp; |
| else if (e->ts.type == BT_DERIVED) |
| return e->ts.u.derived->attr.pointer_comp; |
| else |
| return false; |
| } |
| |
| |
| /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4. |
| Note: A scalar is not regarded as "simply contiguous" by the standard. |
| if bool is not strict, some further checks are done - for instance, |
| a "(::1)" is accepted. */ |
| |
| bool |
| gfc_is_simply_contiguous (gfc_expr *expr, bool strict, bool permit_element) |
| { |
| bool colon; |
| int i; |
| gfc_array_ref *ar = NULL; |
| gfc_ref *ref, *part_ref = NULL; |
| gfc_symbol *sym; |
| |
| if (expr->expr_type == EXPR_ARRAY) |
| return true; |
| |
| if (expr->expr_type == EXPR_FUNCTION) |
| { |
| if (expr->value.function.esym) |
| return expr->value.function.esym->result->attr.contiguous; |
| else |
| { |
| /* Type-bound procedures. */ |
| gfc_symbol *s = expr->symtree->n.sym; |
| if (s->ts.type != BT_CLASS && s->ts.type != BT_DERIVED) |
| return false; |
| |
| gfc_ref *rc = NULL; |
| for (gfc_ref *r = expr->ref; r; r = r->next) |
| if (r->type == REF_COMPONENT) |
| rc = r; |
| |
| if (rc == NULL || rc->u.c.component == NULL |
| || rc->u.c.component->ts.interface == NULL) |
| return false; |
| |
| return rc->u.c.component->ts.interface->attr.contiguous; |
| } |
| } |
| else if (expr->expr_type != EXPR_VARIABLE) |
| return false; |
| |
| if (!permit_element && expr->rank == 0) |
| return false; |
| |
| for (ref = expr->ref; ref; ref = ref->next) |
| { |
| if (ar) |
| return false; /* Array shall be last part-ref. */ |
| |
| if (ref->type == REF_COMPONENT) |
| part_ref = ref; |
| else if (ref->type == REF_SUBSTRING) |
| return false; |
| else if (ref->u.ar.type != AR_ELEMENT) |
| ar = &ref->u.ar; |
| } |
| |
| sym = expr->symtree->n.sym; |
| if (expr->ts.type != BT_CLASS |
| && ((part_ref |
| && !part_ref->u.c.component->attr.contiguous |
| && part_ref->u.c.component->attr.pointer) |
| || (!part_ref |
| && !sym->attr.contiguous |
| && (sym->attr.pointer |
| || (sym->as && sym->as->type == AS_ASSUMED_RANK) |
| || (sym->as && sym->as->type == AS_ASSUMED_SHAPE))))) |
| return false; |
| |
| if (!ar || ar->type == AR_FULL) |
| return true; |
| |
| gcc_assert (ar->type == AR_SECTION); |
| |
| /* Check for simply contiguous array */ |
| colon = true; |
| for (i = 0; i < ar->dimen; i++) |
| { |
| if (ar->dimen_type[i] == DIMEN_VECTOR) |
| return false; |
| |
| if (ar->dimen_type[i] == DIMEN_ELEMENT) |
| { |
| colon = false; |
| continue; |
| } |
| |
| gcc_assert (ar->dimen_type[i] == DIMEN_RANGE); |
| |
| |
| /* If the previous section was not contiguous, that's an error, |
| unless we have effective only one element and checking is not |
| strict. */ |
| if (!colon && (strict || !ar->start[i] || !ar->end[i] |
| || ar->start[i]->expr_type != EXPR_CONSTANT |
| || ar->end[i]->expr_type != EXPR_CONSTANT |
| || mpz_cmp (ar->start[i]->value.integer, |
| ar->end[i]->value.integer) != 0)) |
| return false; |
| |
| /* Following the standard, "(::1)" or - if known at compile time - |
| "(lbound:ubound)" are not simply contiguous; if strict |
| is false, they are regarded as simply contiguous. */ |
| if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT |
| || ar->stride[i]->ts.type != BT_INTEGER |
| || mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0)) |
| return false; |
| |
| if (ar->start[i] |
| && (strict || ar->start[i]->expr_type != EXPR_CONSTANT |
| || !ar->as->lower[i] |
| || ar->as->lower[i]->expr_type != EXPR_CONSTANT |
| || mpz_cmp (ar->start[i]->value.integer, |
| ar->as->lower[i]->value.integer) != 0)) |
| colon = false; |
| |
| if (ar->end[i] |
| && (strict || ar->end[i]->expr_type != EXPR_CONSTANT |
| || !ar->as->upper[i] |
| || ar->as->upper[i]->expr_type != EXPR_CONSTANT |
| || mpz_cmp (ar->end[i]->value.integer, |
| ar->as->upper[i]->value.integer) != 0)) |
| colon = false; |
| } |
| |
| return true; |
| } |
| |
| /* Return true if the expression is guaranteed to be non-contiguous, |
| false if we cannot prove anything. It is probably best to call |
| this after gfc_is_simply_contiguous. If neither of them returns |
| true, we cannot say (at compile-time). */ |
| |
| bool |
| gfc_is_not_contiguous (gfc_expr *array) |
| { |
| int i; |
| gfc_array_ref *ar = NULL; |
| gfc_ref *ref; |
| bool previous_incomplete; |
| |
| for (ref = array->ref; ref; ref = ref->next) |
| { |
| /* Array-ref shall be last ref. */ |
| |
| if (ar) |
| return true; |
| |
| if (ref->type == REF_ARRAY) |
| ar = &ref->u.ar; |
| } |
| |
| if (ar == NULL || ar->type != AR_SECTION) |
| return false; |
| |
| previous_incomplete = false; |
| |
| /* Check if we can prove that the array is not contiguous. */ |
| |
| for (i = 0; i < ar->dimen; i++) |
| { |
| mpz_t arr_size, ref_size; |
| |
| if (gfc_ref_dimen_size (ar, i, &ref_size, NULL)) |
| { |
| if (gfc_dep_difference (ar->as->lower[i], ar->as->upper[i], &arr_size)) |
| { |
| /* a(2:4,2:) is known to be non-contiguous, but |
| a(2:4,i:i) can be contiguous. */ |
| if (previous_incomplete && mpz_cmp_si (ref_size, 1) != 0) |
| { |
| mpz_clear (arr_size); |
| mpz_clear (ref_size); |
| return true; |
| } |
| else if (mpz_cmp (arr_size, ref_size) != 0) |
| previous_incomplete = true; |
| |
| mpz_clear (arr_size); |
| } |
| |
| /* Check for a(::2), i.e. where the stride is not unity. |
| This is only done if there is more than one element in |
| the reference along this dimension. */ |
| |
| if (mpz_cmp_ui (ref_size, 1) > 0 && ar->type == AR_SECTION |
| && ar->dimen_type[i] == DIMEN_RANGE |
| && ar->stride[i] && ar->stride[i]->expr_type == EXPR_CONSTANT |
| && mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0) |
| return true; |
| |
| mpz_clear (ref_size); |
| } |
| } |
| /* We didn't find anything definitive. */ |
| return false; |
| } |
| |
| /* Build call to an intrinsic procedure. The number of arguments has to be |
| passed (rather than ending the list with a NULL value) because we may |
| want to add arguments but with a NULL-expression. */ |
| |
| gfc_expr* |
| gfc_build_intrinsic_call (gfc_namespace *ns, gfc_isym_id id, const char* name, |
| locus where, unsigned numarg, ...) |
| { |
| gfc_expr* result; |
| gfc_actual_arglist* atail; |
| gfc_intrinsic_sym* isym; |
| va_list ap; |
| unsigned i; |
| const char *mangled_name = gfc_get_string (GFC_PREFIX ("%s"), name); |
| |
| isym = gfc_intrinsic_function_by_id (id); |
| gcc_assert (isym); |
| |
| result = gfc_get_expr (); |
| result->expr_type = EXPR_FUNCTION; |
| result->ts = isym->ts; |
| result->where = where; |
| result->value.function.name = mangled_name; |
| result->value.function.isym = isym; |
| |
| gfc_get_sym_tree (mangled_name, ns, &result->symtree, false); |
| gfc_commit_symbol (result->symtree->n.sym); |
| gcc_assert (result->symtree |
| && (result->symtree->n.sym->attr.flavor == FL_PROCEDURE |
| || result->symtree->n.sym->attr.flavor == FL_UNKNOWN)); |
| result->symtree->n.sym->intmod_sym_id = id; |
| result->symtree->n.sym->attr.flavor = FL_PROCEDURE; |
| result->symtree->n.sym->attr.intrinsic = 1; |
| result->symtree->n.sym->attr.artificial = 1; |
| |
| va_start (ap, numarg); |
| atail = NULL; |
| for (i = 0; i < numarg; ++i) |
| { |
| if (atail) |
| { |
| atail->next = gfc_get_actual_arglist (); |
| atail = atail->next; |
| } |
| else |
| atail = result->value.function.actual = gfc_get_actual_arglist (); |
| |
| atail->expr = va_arg (ap, gfc_expr*); |
| } |
| va_end (ap); |
| |
| return result; |
| } |
| |
| |
| /* Check if an expression may appear in a variable definition context |
| (F2008, 16.6.7) or pointer association context (F2008, 16.6.8). |
| This is called from the various places when resolving |
| the pieces that make up such a context. |
| If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do |
| variables), some checks are not performed. |
| |
| Optionally, a possible error message can be suppressed if context is NULL |
| and just the return status (true / false) be requested. */ |
| |
| bool |
| gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, |
| bool own_scope, const char* context) |
| { |
| gfc_symbol* sym = NULL; |
| bool is_pointer; |
| bool check_intentin; |
| bool ptr_component; |
| symbol_attribute attr; |
| gfc_ref* ref; |
| int i; |
| |
| if (e->expr_type == EXPR_VARIABLE) |
| { |
| gcc_assert (e->symtree); |
| sym = e->symtree->n.sym; |
| } |
| else if (e->expr_type == EXPR_FUNCTION) |
| { |
| gcc_assert (e->symtree); |
| sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym; |
| } |
| |
| attr = gfc_expr_attr (e); |
| if (!pointer && e->expr_type == EXPR_FUNCTION && attr.pointer) |
| { |
| if (!(gfc_option.allow_std & GFC_STD_F2008)) |
| { |
| if (context) |
| gfc_error ("Fortran 2008: Pointer functions in variable definition" |
| " context (%s) at %L", context, &e->where); |
| return false; |
| } |
| } |
| else if (e->expr_type != EXPR_VARIABLE) |
| { |
| if (context) |
| gfc_error ("Non-variable expression in variable definition context (%s)" |
| " at %L", context, &e->where); |
| return false; |
| } |
| |
| if (!pointer && sym->attr.flavor == FL_PARAMETER) |
| { |
| if (context) |
| gfc_error ("Named constant %qs in variable definition context (%s)" |
| " at %L", sym->name, context, &e->where); |
| return false; |
| } |
| if (!pointer && sym->attr.flavor != FL_VARIABLE |
| && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result) |
| && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer)) |
| { |
| if (context) |
| gfc_error ("%qs in variable definition context (%s) at %L is not" |
| " a variable", sym->name, context, &e->where); |
| return false; |
| } |
| |
| /* Find out whether the expr is a pointer; this also means following |
| component references to the last one. */ |
| is_pointer = (attr.pointer || attr.proc_pointer); |
| if (pointer && !is_pointer) |
| { |
| if (context) |
| gfc_error ("Non-POINTER in pointer association context (%s)" |
| " at %L", context, &e->where); |
| return false; |
| } |
| |
| if (e->ts.type == BT_DERIVED |
| && e->ts.u.derived == NULL) |
| { |
| if (context) |
| gfc_error ("Type inaccessible in variable definition context (%s) " |
| "at %L", context, &e->where); |
| return false; |
| } |
| |
| /* F2008, C1303. */ |
| if (!alloc_obj |
| && (attr.lock_comp |
| || (e->ts.type == BT_DERIVED |
| && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV |
| && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE))) |
| { |
| if (context) |
| gfc_error ("LOCK_TYPE in variable definition context (%s) at %L", |
| context, &e->where); |
| return false; |
| } |
| |
| /* TS18508, C702/C203. */ |
| if (!alloc_obj |
| && (attr.lock_comp |
| || (e->ts.type == BT_DERIVED |
| && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV |
| && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE))) |
| { |
| if (context) |
| gfc_error ("LOCK_EVENT in variable definition context (%s) at %L", |
| context, &e->where); |
| return false; |
| } |
| |
| /* INTENT(IN) dummy argument. Check this, unless the object itself is the |
| component of sub-component of a pointer; we need to distinguish |
| assignment to a pointer component from pointer-assignment to a pointer |
| component. Note that (normal) assignment to procedure pointers is not |
| possible. */ |
| check_intentin = !own_scope; |
| ptr_component = (sym->ts.type == BT_CLASS && sym->ts.u.derived |
| && CLASS_DATA (sym)) |
| ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer; |
| for (ref = e->ref; ref && check_intentin; ref = ref->next) |
| { |
| if (ptr_component && ref->type == REF_COMPONENT) |
| check_intentin = false; |
| if (ref->type == REF_COMPONENT) |
| { |
| gfc_component *comp = ref->u.c.component; |
| ptr_component = (comp->ts.type == BT_CLASS && comp->attr.class_ok) |
| ? CLASS_DATA (comp)->attr.class_pointer |
| : comp->attr.pointer; |
| if (ptr_component && !pointer) |
| check_intentin = false; |
| } |
| } |
| |
| if (check_intentin |
| && (sym->attr.intent == INTENT_IN |
| || (sym->attr.select_type_temporary && sym->assoc |
| && sym->assoc->target && sym->assoc->target->symtree |
| && sym->assoc->target->symtree->n.sym->attr.intent == INTENT_IN))) |
| { |
| if (pointer && is_pointer) |
| { |
| if (context) |
| gfc_error ("Dummy argument %qs with INTENT(IN) in pointer" |
| " association context (%s) at %L", |
| sym->name, context, &e->where); |
| return false; |
| } |
| if (!pointer && !is_pointer && !sym->attr.pointer) |
| { |
| const char *name = sym->attr.select_type_temporary |
| ? sym->assoc->target->symtree->name : sym->name; |
| if (context) |
| gfc_error ("Dummy argument %qs with INTENT(IN) in variable" |
| " definition context (%s) at %L", |
| name, context, &e->where); |
| return false; |
| } |
| } |
| |
| /* PROTECTED and use-associated. */ |
| if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin) |
| { |
| if (pointer && is_pointer) |
| { |
| if (context) |
| gfc_error ("Variable %qs is PROTECTED and cannot appear in a" |
| " pointer association context (%s) at %L", |
| sym->name, context, &e->where); |
| return false; |
| } |
| if (!pointer && !is_pointer) |
| { |
| if (context) |
| gfc_error ("Variable %qs is PROTECTED and cannot appear in a" |
| " variable definition context (%s) at %L", |
| sym->name, context, &e->where); |
| return false; |
| } |
| } |
| |
| /* Variable not assignable from a PURE procedure but appears in |
| variable definition context. */ |
| if (!pointer && !own_scope && gfc_pure (NULL) && gfc_impure_variable (sym)) |
| { |
| if (context) |
| gfc_error ("Variable %qs cannot appear in a variable definition" |
| " context (%s) at %L in PURE procedure", |
| sym->name, context, &e->where); |
| return false; |
| } |
| |
| if (!pointer && context && gfc_implicit_pure (NULL) |
| && gfc_impure_variable (sym)) |
| { |
| gfc_namespace *ns; |
| gfc_symbol *sym; |
| |
| for (ns = gfc_current_ns; ns; ns = ns->parent) |
| { |
| sym = ns->proc_name; |
| if (sym == NULL) |
| break; |
| if (sym->attr.flavor == FL_PROCEDURE) |
| { |
| sym->attr.implicit_pure = 0; |
| break; |
| } |
| } |
| } |
| /* Check variable definition context for associate-names. */ |
| if (!pointer && sym->assoc && !sym->attr.select_rank_temporary) |
| { |
| const char* name; |
| gfc_association_list* assoc; |
| |
| gcc_assert (sym->assoc->target); |
| |
| /* If this is a SELECT TYPE temporary (the association is used internally |
| for SELECT TYPE), silently go over to the target. */ |
| if (sym->attr.select_type_temporary) |
| { |
| gfc_expr* t = sym->assoc->target; |
| |
| gcc_assert (t->expr_type == EXPR_VARIABLE); |
| name = t->symtree->name; |
| |
| if (t->symtree->n.sym->assoc) |
| assoc = t->symtree->n.sym->assoc; |
| else |
| assoc = sym->assoc; |
| } |
| else |
| { |
| name = sym->name; |
| assoc = sym->assoc; |
| } |
| gcc_assert (name && assoc); |
| |
| /* Is association to a valid variable? */ |
| if (!assoc->variable) |
| { |
| if (context) |
| { |
| if (assoc->target->expr_type == EXPR_VARIABLE) |
| gfc_error ("%qs at %L associated to vector-indexed target" |
| " cannot be used in a variable definition" |
| " context (%s)", |
| name, &e->where, context); |
| else |
| gfc_error ("%qs at %L associated to expression" |
| " cannot be used in a variable definition" |
| " context (%s)", |
| name, &e->where, context); |
| } |
| return false; |
| } |
| |
| /* Target must be allowed to appear in a variable definition context. */ |
| if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL)) |
| { |
| if (context) |
| gfc_error ("Associate-name %qs cannot appear in a variable" |
| " definition context (%s) at %L because its target" |
| " at %L cannot, either", |
| name, context, &e->where, |
| &assoc->target->where); |
| return false; |
| } |
| } |
| |
| /* Check for same value in vector expression subscript. */ |
| |
| if (e->rank > 0) |
| for (ref = e->ref; ref != NULL; ref = ref->next) |
| if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) |
| for (i = 0; i < GFC_MAX_DIMENSIONS |
| && ref->u.ar.dimen_type[i] != 0; i++) |
| if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) |
| { |
| gfc_expr *arr = ref->u.ar.start[i]; |
| if (arr->expr_type == EXPR_ARRAY) |
| { |
| gfc_constructor *c, *n; |
| gfc_expr *ec, *en; |
| |
| for (c = gfc_constructor_first (arr->value.constructor); |
| c != NULL; c = gfc_constructor_next (c)) |
| { |
| if (c == NULL || c->iterator != NULL) |
| continue; |
| |
| ec = c->expr; |
| |
| for (n = gfc_constructor_next (c); n != NULL; |
| n = gfc_constructor_next (n)) |
| { |
| if (n->iterator != NULL) |
| continue; |
| |
| en = n->expr; |
| if (gfc_dep_compare_expr (ec, en) == 0) |
| { |
| if (context) |
| gfc_error_now ("Elements with the same value " |
| "at %L and %L in vector " |
| "subscript in a variable " |
| "definition context (%s)", |
| &(ec->where), &(en->where), |
| context); |
| return false; |
| } |
| } |
| } |
| } |
| } |
| |
| return true; |
| } |