static int compare_parameter (gfc_symbol * formal, gfc_expr * actual, int ranks_must_agree, int is_elemental) { gfc_ref *ref; if (actual->ts.type == BT_PROCEDURE) { if (formal->attr.flavor != FL_PROCEDURE) return 0; if (formal->attr.function && !compare_type_rank (formal, actual->symtree->n.sym)) return 0; if (formal->attr.if_source == IFSRC_UNKNOWN) return 1; /* Assume match */ return compare_interfaces (formal, actual->symtree->n.sym, 0); } if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN) && !gfc_compare_types (&formal->ts, &actual->ts)) return 0; if (symbol_rank (formal) == actual->rank) return 1; /* At this point the ranks didn't agree. */ if (ranks_must_agree || formal->attr.pointer) return 0; if (actual->rank != 0) return is_elemental || formal->attr.dimension; /* At this point, we are considering a scalar passed to an array. This is legal if the scalar is an array element of the right sort. */ if (formal->as->type == AS_ASSUMED_SHAPE) return 0; for (ref = actual->ref; ref; ref = ref->next) if (ref->type == REF_SUBSTRING) return 0; for (ref = actual->ref; ref; ref = ref->next) if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT) break; if (ref == NULL) return 0; /* Not an array element */ return 1; }
static int compare_type_rank (gfc_symbol * s1, gfc_symbol * s2) { int r1, r2; r1 = (s1->as != NULL) ? s1->as->rank : 0; r2 = (s2->as != NULL) ? s2->as->rank : 0; if (r1 != r2) return 0; /* Ranks differ */ return gfc_compare_types (&s1->ts, &s2->ts); }
void gfc_assign_data_value_range (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index, mpz_t repeat) { gfc_ref *ref; gfc_expr *init, *expr; gfc_constructor *con, *last_con; gfc_symbol *symbol; gfc_typespec *last_ts; mpz_t offset; symbol = lvalue->symtree->n.sym; init = symbol->value; last_ts = &symbol->ts; last_con = NULL; mpz_init_set_si (offset, 0); /* Find/create the parent expressions for subobject references. */ for (ref = lvalue->ref; ref; ref = ref->next) { /* Use the existing initializer expression if it exists. Otherwise create a new one. */ if (init == NULL) expr = gfc_get_expr (); else expr = init; /* Find or create this element. */ switch (ref->type) { case REF_ARRAY: if (init == NULL) { /* The element typespec will be the same as the array typespec. */ expr->ts = *last_ts; /* Setup the expression to hold the constructor. */ expr->expr_type = EXPR_ARRAY; expr->rank = ref->u.ar.as->rank; } else gcc_assert (expr->expr_type == EXPR_ARRAY); if (ref->u.ar.type == AR_ELEMENT) { get_array_index (&ref->u.ar, &offset); /* This had better not be the bottom of the reference. We can still get to a full array via a component. */ gcc_assert (ref->next != NULL); } else { mpz_set (offset, index); /* We're at a full array or an array section. This means that we've better have found a full array, and that we're at the bottom of the reference. */ gcc_assert (ref->u.ar.type == AR_FULL); gcc_assert (ref->next == NULL); } /* Find the same element in the existing constructor. */ con = expr->value.constructor; con = find_con_by_offset (offset, con); /* Create a new constructor. */ if (con == NULL) { con = gfc_get_constructor (); mpz_set (con->n.offset, offset); if (ref->next == NULL) mpz_set (con->repeat, repeat); gfc_insert_constructor (expr, con); } else gcc_assert (ref->next != NULL); break; case REF_COMPONENT: if (init == NULL) { /* Setup the expression to hold the constructor. */ expr->expr_type = EXPR_STRUCTURE; expr->ts.type = BT_DERIVED; expr->ts.derived = ref->u.c.sym; } else gcc_assert (expr->expr_type == EXPR_STRUCTURE); last_ts = &ref->u.c.component->ts; /* Find the same element in the existing constructor. */ con = expr->value.constructor; con = find_con_by_component (ref->u.c.component, con); if (con == NULL) { /* Create a new constructor. */ con = gfc_get_constructor (); con->n.component = ref->u.c.component; con->next = expr->value.constructor; expr->value.constructor = con; } /* Since we're only intending to initialize arrays here, there better be an inner reference. */ gcc_assert (ref->next != NULL); break; case REF_SUBSTRING: default: gcc_unreachable (); } if (init == NULL) { /* Point the container at the new expression. */ if (last_con == NULL) symbol->value = expr; else last_con->expr = expr; } init = con->expr; last_con = con; } if (last_ts->type == BT_CHARACTER) expr = create_character_intializer (init, last_ts, NULL, rvalue); else { /* We should never be overwriting an existing initializer. */ gcc_assert (!init); expr = gfc_copy_expr (rvalue); if (!gfc_compare_types (&lvalue->ts, &expr->ts)) gfc_convert_type (expr, &lvalue->ts, 0); } if (last_con == NULL) symbol->value = expr; else last_con->expr = expr; }
void gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index) { gfc_ref *ref; gfc_expr *init; gfc_expr *expr; gfc_constructor *con; gfc_constructor *last_con; gfc_symbol *symbol; gfc_typespec *last_ts; mpz_t offset; symbol = lvalue->symtree->n.sym; init = symbol->value; last_ts = &symbol->ts; last_con = NULL; mpz_init_set_si (offset, 0); /* Find/create the parent expressions for subobject references. */ for (ref = lvalue->ref; ref; ref = ref->next) { /* Break out of the loop if we find a substring. */ if (ref->type == REF_SUBSTRING) { /* A substring should always be the last subobject reference. */ gcc_assert (ref->next == NULL); break; } /* Use the existing initializer expression if it exists. Otherwise create a new one. */ if (init == NULL) expr = gfc_get_expr (); else expr = init; /* Find or create this element. */ switch (ref->type) { case REF_ARRAY: if (init == NULL) { /* The element typespec will be the same as the array typespec. */ expr->ts = *last_ts; /* Setup the expression to hold the constructor. */ expr->expr_type = EXPR_ARRAY; expr->rank = ref->u.ar.as->rank; } else gcc_assert (expr->expr_type == EXPR_ARRAY); if (ref->u.ar.type == AR_ELEMENT) get_array_index (&ref->u.ar, &offset); else mpz_set (offset, index); /* Find the same element in the existing constructor. */ con = expr->value.constructor; con = find_con_by_offset (offset, con); if (con == NULL) { /* Create a new constructor. */ con = gfc_get_constructor (); mpz_set (con->n.offset, offset); gfc_insert_constructor (expr, con); } break; case REF_COMPONENT: if (init == NULL) { /* Setup the expression to hold the constructor. */ expr->expr_type = EXPR_STRUCTURE; expr->ts.type = BT_DERIVED; expr->ts.derived = ref->u.c.sym; } else gcc_assert (expr->expr_type == EXPR_STRUCTURE); last_ts = &ref->u.c.component->ts; /* Find the same element in the existing constructor. */ con = expr->value.constructor; con = find_con_by_component (ref->u.c.component, con); if (con == NULL) { /* Create a new constructor. */ con = gfc_get_constructor (); con->n.component = ref->u.c.component; con->next = expr->value.constructor; expr->value.constructor = con; } break; default: gcc_unreachable (); } if (init == NULL) { /* Point the container at the new expression. */ if (last_con == NULL) symbol->value = expr; else last_con->expr = expr; } init = con->expr; last_con = con; } if (ref || last_ts->type == BT_CHARACTER) expr = create_character_intializer (init, last_ts, ref, rvalue); else { /* Overwriting an existing initializer is non-standard but usually only provokes a warning from other compilers. */ if (init != NULL) { /* Order in which the expressions arrive here depends on whether they are from data statements or F95 style declarations. Therefore, check which is the most recent. */ #ifdef USE_MAPPED_LOCATION expr = (LOCATION_LINE (init->where.lb->location) > LOCATION_LINE (rvalue->where.lb->location)) ? init : rvalue; #else expr = (init->where.lb->linenum > rvalue->where.lb->linenum) ? init : rvalue; #endif gfc_notify_std (GFC_STD_GNU, "Extension: re-initialization " "of '%s' at %L", symbol->name, &expr->where); } expr = gfc_copy_expr (rvalue); if (!gfc_compare_types (&lvalue->ts, &expr->ts)) gfc_convert_type (expr, &lvalue->ts, 0); } if (last_con == NULL) symbol->value = expr; else last_con->expr = expr; }
static void show_namespace (gfc_namespace *ns) { gfc_interface *intr; gfc_namespace *save; int op; gfc_equiv *eq; int i; gcc_assert (ns); save = gfc_current_ns; show_indent (); fputs ("Namespace:", dumpfile); i = 0; do { int l = i; while (i < GFC_LETTERS - 1 && gfc_compare_types (&ns->default_type[i+1], &ns->default_type[l])) i++; if (i > l) fprintf (dumpfile, " %c-%c: ", l+'A', i+'A'); else fprintf (dumpfile, " %c: ", l+'A'); show_typespec(&ns->default_type[l]); i++; } while (i < GFC_LETTERS); if (ns->proc_name != NULL) { show_indent (); fprintf (dumpfile, "procedure name = %s", ns->proc_name->name); } ++show_level; gfc_current_ns = ns; gfc_traverse_symtree (ns->common_root, show_common); gfc_traverse_symtree (ns->sym_root, show_symtree); for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++) { /* User operator interfaces */ intr = ns->op[op]; if (intr == NULL) continue; show_indent (); fprintf (dumpfile, "Operator interfaces for %s:", gfc_op2string ((gfc_intrinsic_op) op)); for (; intr; intr = intr->next) fprintf (dumpfile, " %s", intr->sym->name); } if (ns->uop_root != NULL) { show_indent (); fputs ("User operators:\n", dumpfile); gfc_traverse_user_op (ns, show_uop); } for (eq = ns->equiv; eq; eq = eq->next) show_equiv (eq); fputc ('\n', dumpfile); show_indent (); fputs ("code:", dumpfile); show_code (show_level, ns->code); --show_level; for (ns = ns->contained; ns; ns = ns->sibling) { fputs ("\nCONTAINS\n", dumpfile); ++show_level; show_namespace (ns); --show_level; } fputc ('\n', dumpfile); gfc_current_ns = save; }
static bool check_data_pointer_types (gfc_expr *expr1, gfc_expr *expr2) { gfc_component *cm1; gfc_symbol *sym1; gfc_symbol *sym2; gfc_ref *ref1; bool seen_component_ref; if (expr1->expr_type != EXPR_VARIABLE || expr1->expr_type != EXPR_VARIABLE) return false; sym1 = expr1->symtree->n.sym; sym2 = expr2->symtree->n.sym; /* Keep it simple for now. */ if (sym1->ts.type == BT_DERIVED && sym2->ts.type == BT_DERIVED) return false; if (sym1->attr.pointer) { if (gfc_compare_types (&sym1->ts, &sym2->ts)) return false; } /* This is a conservative check on the components of the derived type if no component references have been seen. Since we will not dig into the components of derived type components, we play it safe by returning false. First we check the reference chain and then, if no component references have been seen, the components. */ seen_component_ref = false; if (sym1->ts.type == BT_DERIVED) { for (ref1 = expr1->ref; ref1; ref1 = ref1->next) { if (ref1->type != REF_COMPONENT) continue; if (ref1->u.c.component->ts.type == BT_DERIVED) return false; if ((sym2->attr.pointer || ref1->u.c.component->attr.pointer) && gfc_compare_types (&ref1->u.c.component->ts, &sym2->ts)) return false; seen_component_ref = true; } } if (sym1->ts.type == BT_DERIVED && !seen_component_ref) { for (cm1 = sym1->ts.u.derived->components; cm1; cm1 = cm1->next) { if (cm1->ts.type == BT_DERIVED) return false; if ((sym2->attr.pointer || cm1->attr.pointer) && gfc_compare_types (&cm1->ts, &sym2->ts)) return false; } } return true; }
bool gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index, mpz_t *repeat) { gfc_ref *ref; gfc_expr *init; gfc_expr *expr = NULL; gfc_constructor *con; gfc_constructor *last_con; gfc_symbol *symbol; gfc_typespec *last_ts; mpz_t offset; symbol = lvalue->symtree->n.sym; init = symbol->value; last_ts = &symbol->ts; last_con = NULL; mpz_init_set_si (offset, 0); /* Find/create the parent expressions for subobject references. */ for (ref = lvalue->ref; ref; ref = ref->next) { /* Break out of the loop if we find a substring. */ if (ref->type == REF_SUBSTRING) { /* A substring should always be the last subobject reference. */ gcc_assert (ref->next == NULL); break; } /* Use the existing initializer expression if it exists. Otherwise create a new one. */ if (init == NULL) expr = gfc_get_expr (); else expr = init; /* Find or create this element. */ switch (ref->type) { case REF_ARRAY: if (ref->u.ar.as->rank == 0) { gcc_assert (ref->u.ar.as->corank > 0); if (init == NULL) free (expr); continue; } if (init && expr->expr_type != EXPR_ARRAY) { gfc_error ("%qs at %L already is initialized at %L", lvalue->symtree->n.sym->name, &lvalue->where, &init->where); goto abort; } if (init == NULL) { /* The element typespec will be the same as the array typespec. */ expr->ts = *last_ts; /* Setup the expression to hold the constructor. */ expr->expr_type = EXPR_ARRAY; expr->rank = ref->u.ar.as->rank; } if (ref->u.ar.type == AR_ELEMENT) get_array_index (&ref->u.ar, &offset); else mpz_set (offset, index); /* Check the bounds. */ if (mpz_cmp_si (offset, 0) < 0) { gfc_error ("Data element below array lower bound at %L", &lvalue->where); goto abort; } else if (repeat != NULL && ref->u.ar.type != AR_ELEMENT) { mpz_t size, end; gcc_assert (ref->u.ar.type == AR_FULL && ref->next == NULL); mpz_init_set (end, offset); mpz_add (end, end, *repeat); if (spec_size (ref->u.ar.as, &size)) { if (mpz_cmp (end, size) > 0) { mpz_clear (size); gfc_error ("Data element above array upper bound at %L", &lvalue->where); goto abort; } mpz_clear (size); } con = gfc_constructor_lookup (expr->value.constructor, mpz_get_si (offset)); if (!con) { con = gfc_constructor_lookup_next (expr->value.constructor, mpz_get_si (offset)); if (con != NULL && mpz_cmp (con->offset, end) >= 0) con = NULL; } /* Overwriting an existing initializer is non-standard but usually only provokes a warning from other compilers. */ if (con != NULL && con->expr != NULL) { /* Order in which the expressions arrive here depends on whether they are from data statements or F95 style declarations. Therefore, check which is the most recent. */ gfc_expr *exprd; exprd = (LOCATION_LINE (con->expr->where.lb->location) > LOCATION_LINE (rvalue->where.lb->location)) ? con->expr : rvalue; if (gfc_notify_std (GFC_STD_GNU, "re-initialization of %qs at %L", symbol->name, &exprd->where) == false) return false; } while (con != NULL) { gfc_constructor *next_con = gfc_constructor_next (con); if (mpz_cmp (con->offset, end) >= 0) break; if (mpz_cmp (con->offset, offset) < 0) { gcc_assert (mpz_cmp_si (con->repeat, 1) > 0); mpz_sub (con->repeat, offset, con->offset); } else if (mpz_cmp_si (con->repeat, 1) > 0 && mpz_get_si (con->offset) + mpz_get_si (con->repeat) > mpz_get_si (end)) { int endi; splay_tree_node node = splay_tree_lookup (con->base, mpz_get_si (con->offset)); gcc_assert (node && con == (gfc_constructor *) node->value && node->key == (splay_tree_key) mpz_get_si (con->offset)); endi = mpz_get_si (con->offset) + mpz_get_si (con->repeat); if (endi > mpz_get_si (end) + 1) mpz_set_si (con->repeat, endi - mpz_get_si (end)); else mpz_set_si (con->repeat, 1); mpz_set (con->offset, end); node->key = (splay_tree_key) mpz_get_si (end); break; } else gfc_constructor_remove (con); con = next_con; } con = gfc_constructor_insert_expr (&expr->value.constructor, NULL, &rvalue->where, mpz_get_si (offset)); mpz_set (con->repeat, *repeat); repeat = NULL; mpz_clear (end); break; } else { mpz_t size; if (spec_size (ref->u.ar.as, &size)) { if (mpz_cmp (offset, size) >= 0) { mpz_clear (size); gfc_error ("Data element above array upper bound at %L", &lvalue->where); goto abort; } mpz_clear (size); } } con = gfc_constructor_lookup (expr->value.constructor, mpz_get_si (offset)); if (!con) { con = gfc_constructor_insert_expr (&expr->value.constructor, NULL, &rvalue->where, mpz_get_si (offset)); } else if (mpz_cmp_si (con->repeat, 1) > 0) { /* Need to split a range. */ if (mpz_cmp (con->offset, offset) < 0) { gfc_constructor *pred_con = con; con = gfc_constructor_insert_expr (&expr->value.constructor, NULL, &con->where, mpz_get_si (offset)); con->expr = gfc_copy_expr (pred_con->expr); mpz_add (con->repeat, pred_con->offset, pred_con->repeat); mpz_sub (con->repeat, con->repeat, offset); mpz_sub (pred_con->repeat, offset, pred_con->offset); } if (mpz_cmp_si (con->repeat, 1) > 0) { gfc_constructor *succ_con; succ_con = gfc_constructor_insert_expr (&expr->value.constructor, NULL, &con->where, mpz_get_si (offset) + 1); succ_con->expr = gfc_copy_expr (con->expr); mpz_sub_ui (succ_con->repeat, con->repeat, 1); mpz_set_si (con->repeat, 1); } } break; case REF_COMPONENT: if (init == NULL) { /* Setup the expression to hold the constructor. */ expr->expr_type = EXPR_STRUCTURE; expr->ts.type = BT_DERIVED; expr->ts.u.derived = ref->u.c.sym; } else gcc_assert (expr->expr_type == EXPR_STRUCTURE); last_ts = &ref->u.c.component->ts; /* Find the same element in the existing constructor. */ con = find_con_by_component (ref->u.c.component, expr->value.constructor); if (con == NULL) { /* Create a new constructor. */ con = gfc_constructor_append_expr (&expr->value.constructor, NULL, NULL); con->n.component = ref->u.c.component; } break; default: gcc_unreachable (); } if (init == NULL) { /* Point the container at the new expression. */ if (last_con == NULL) symbol->value = expr; else last_con->expr = expr; } init = con->expr; last_con = con; } mpz_clear (offset); gcc_assert (repeat == NULL); if (ref || last_ts->type == BT_CHARACTER) { if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL)) return false; expr = create_character_initializer (init, last_ts, ref, rvalue); } else { /* Overwriting an existing initializer is non-standard but usually only provokes a warning from other compilers. */ if (init != NULL) { /* Order in which the expressions arrive here depends on whether they are from data statements or F95 style declarations. Therefore, check which is the most recent. */ expr = (LOCATION_LINE (init->where.lb->location) > LOCATION_LINE (rvalue->where.lb->location)) ? init : rvalue; if (gfc_notify_std (GFC_STD_GNU, "re-initialization of %qs at %L", symbol->name, &expr->where) == false) return false; } expr = gfc_copy_expr (rvalue); if (!gfc_compare_types (&lvalue->ts, &expr->ts)) gfc_convert_type (expr, &lvalue->ts, 0); } if (last_con == NULL) symbol->value = expr; else last_con->expr = expr; return true; abort: if (!init) gfc_free_expr (expr); mpz_clear (offset); return false; }
void gfc_show_namespace (gfc_namespace * ns) { gfc_interface *intr; gfc_namespace *save; gfc_intrinsic_op op; gfc_equiv *eq; int i; save = gfc_current_ns; show_level++; show_indent (); gfc_status ("Namespace:"); if (ns != NULL) { i = 0; do { int l = i; while (i < GFC_LETTERS - 1 && gfc_compare_types(&ns->default_type[i+1], &ns->default_type[l])) i++; if (i > l) gfc_status(" %c-%c: ", l+'A', i+'A'); else gfc_status(" %c: ", l+'A'); gfc_show_typespec(&ns->default_type[l]); i++; } while (i < GFC_LETTERS); if (ns->proc_name != NULL) { show_indent (); gfc_status ("procedure name = %s", ns->proc_name->name); } gfc_current_ns = ns; gfc_traverse_symtree (ns->common_root, show_common); gfc_traverse_symtree (ns->sym_root, show_symtree); for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++) { /* User operator interfaces */ intr = ns->operator[op]; if (intr == NULL) continue; show_indent (); gfc_status ("Operator interfaces for %s:", gfc_op2string (op)); for (; intr; intr = intr->next) gfc_status (" %s", intr->sym->name); } if (ns->uop_root != NULL) { show_indent (); gfc_status ("User operators:\n"); gfc_traverse_user_op (ns, show_uop); } } for (eq = ns->equiv; eq; eq = eq->next) gfc_show_equiv (eq); gfc_status_char ('\n'); gfc_status_char ('\n'); gfc_show_code (0, ns->code); for (ns = ns->contained; ns; ns = ns->sibling) { show_indent (); gfc_status ("CONTAINS\n"); gfc_show_namespace (ns); } show_level--; gfc_status_char ('\n'); gfc_current_ns = save; }
gfc_try gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index) { gfc_ref *ref; gfc_expr *init; gfc_expr *expr; gfc_constructor *con; gfc_constructor *last_con; gfc_constructor *pred; gfc_symbol *symbol; gfc_typespec *last_ts; mpz_t offset; splay_tree spt; splay_tree_node sptn; symbol = lvalue->symtree->n.sym; init = symbol->value; last_ts = &symbol->ts; last_con = NULL; mpz_init_set_si (offset, 0); /* Find/create the parent expressions for subobject references. */ for (ref = lvalue->ref; ref; ref = ref->next) { /* Break out of the loop if we find a substring. */ if (ref->type == REF_SUBSTRING) { /* A substring should always be the last subobject reference. */ gcc_assert (ref->next == NULL); break; } /* Use the existing initializer expression if it exists. Otherwise create a new one. */ if (init == NULL) expr = gfc_get_expr (); else expr = init; /* Find or create this element. */ switch (ref->type) { case REF_ARRAY: if (init && expr->expr_type != EXPR_ARRAY) { gfc_error ("'%s' at %L already is initialized at %L", lvalue->symtree->n.sym->name, &lvalue->where, &init->where); return FAILURE; } if (init == NULL) { /* The element typespec will be the same as the array typespec. */ expr->ts = *last_ts; /* Setup the expression to hold the constructor. */ expr->expr_type = EXPR_ARRAY; expr->rank = ref->u.ar.as->rank; } if (ref->u.ar.type == AR_ELEMENT) get_array_index (&ref->u.ar, &offset); else mpz_set (offset, index); /* Check the bounds. */ if (mpz_cmp_si (offset, 0) < 0) { gfc_error ("Data element below array lower bound at %L", &lvalue->where); return FAILURE; } else { mpz_t size; if (spec_size (ref->u.ar.as, &size) == SUCCESS) { if (mpz_cmp (offset, size) >= 0) { mpz_clear (size); gfc_error ("Data element above array upper bound at %L", &lvalue->where); return FAILURE; } mpz_clear (size); } } /* Splay tree containing offset and gfc_constructor. */ spt = expr->con_by_offset; if (spt == NULL) { spt = splay_tree_new (splay_tree_compare_ints, NULL, NULL); expr->con_by_offset = spt; con = NULL; } else con = find_con_by_offset (spt, offset); if (con == NULL) { splay_tree_key j; /* Create a new constructor. */ con = gfc_get_constructor (); mpz_set (con->n.offset, offset); j = (splay_tree_key) mpz_get_si (offset); sptn = splay_tree_insert (spt, j, (splay_tree_value) con); /* Fix up the linked list. */ sptn = splay_tree_predecessor (spt, j); if (sptn == NULL) { /* Insert at the head. */ con->next = expr->value.constructor; expr->value.constructor = con; } else { /* Insert in the chain. */ pred = (gfc_constructor*) sptn->value; con->next = pred->next; pred->next = con; } } break; case REF_COMPONENT: if (init == NULL) { /* Setup the expression to hold the constructor. */ expr->expr_type = EXPR_STRUCTURE; expr->ts.type = BT_DERIVED; expr->ts.derived = ref->u.c.sym; } else gcc_assert (expr->expr_type == EXPR_STRUCTURE); last_ts = &ref->u.c.component->ts; /* Find the same element in the existing constructor. */ con = expr->value.constructor; con = find_con_by_component (ref->u.c.component, con); if (con == NULL) { /* Create a new constructor. */ con = gfc_get_constructor (); con->n.component = ref->u.c.component; con->next = expr->value.constructor; expr->value.constructor = con; } break; default: gcc_unreachable (); } if (init == NULL) { /* Point the container at the new expression. */ if (last_con == NULL) symbol->value = expr; else last_con->expr = expr; } init = con->expr; last_con = con; } if (ref || last_ts->type == BT_CHARACTER) expr = create_character_intializer (init, last_ts, ref, rvalue); else { /* Overwriting an existing initializer is non-standard but usually only provokes a warning from other compilers. */ if (init != NULL) { /* Order in which the expressions arrive here depends on whether they are from data statements or F95 style declarations. Therefore, check which is the most recent. */ expr = (LOCATION_LINE (init->where.lb->location) > LOCATION_LINE (rvalue->where.lb->location)) ? init : rvalue; gfc_notify_std (GFC_STD_GNU, "Extension: re-initialization " "of '%s' at %L", symbol->name, &expr->where); } expr = gfc_copy_expr (rvalue); if (!gfc_compare_types (&lvalue->ts, &expr->ts)) gfc_convert_type (expr, &lvalue->ts, 0); } if (last_con == NULL) symbol->value = expr; else last_con->expr = expr; return SUCCESS; }
int gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2) { gfc_component *dt1, *dt2; if (ts1->type != ts2->type) return 0; if (ts1->type != BT_DERIVED) return (ts1->kind == ts2->kind); /* Compare derived types. */ if (ts1->derived == ts2->derived) return 1; /* Special case for comparing derived types across namespaces. If the true names and module names are the same and the module name is nonnull, then they are equal. */ if (strcmp (ts1->derived->name, ts2->derived->name) == 0 && ((ts1->derived->module == NULL && ts2->derived->module == NULL) || (ts1->derived != NULL && ts2->derived != NULL && strcmp (ts1->derived->module, ts2->derived->module) == 0))) return 1; /* Compare type via the rules of the standard. Both types must have the SEQUENCE attribute to be equal. */ if (strcmp (ts1->derived->name, ts2->derived->name)) return 0; dt1 = ts1->derived->components; dt2 = ts2->derived->components; if (ts1->derived->attr.sequence == 0 || ts2->derived->attr.sequence == 0) return 0; /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a simple test can speed things up. Otherwise, lots of things have to match. */ for (;;) { if (strcmp (dt1->name, dt2->name) != 0) return 0; if (dt1->pointer != dt2->pointer) return 0; if (dt1->dimension != dt2->dimension) return 0; if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0) return 0; if (gfc_compare_types (&dt1->ts, &dt2->ts) == 0) return 0; dt1 = dt1->next; dt2 = dt2->next; if (dt1 == NULL && dt2 == NULL) break; if (dt1 == NULL || dt2 == NULL) return 0; } return 1; }
static void resolve_omp_atomic (gfc_code *code) { gfc_symbol *var; gfc_expr *expr2; code = code->block->next; gcc_assert (code->op == EXEC_ASSIGN); gcc_assert (code->next == NULL); if (code->expr1->expr_type != EXPR_VARIABLE || code->expr1->symtree == NULL || code->expr1->rank != 0 || (code->expr1->ts.type != BT_INTEGER && code->expr1->ts.type != BT_REAL && code->expr1->ts.type != BT_COMPLEX && code->expr1->ts.type != BT_LOGICAL)) { gfc_error ("!$OMP ATOMIC statement must set a scalar variable of " "intrinsic type at %L", &code->loc); return; } var = code->expr1->symtree->n.sym; expr2 = is_conversion (code->expr2, false); if (expr2 == NULL) expr2 = code->expr2; if (expr2->expr_type == EXPR_OP) { gfc_expr *v = NULL, *e, *c; gfc_intrinsic_op op = expr2->value.op.op; gfc_intrinsic_op alt_op = INTRINSIC_NONE; switch (op) { case INTRINSIC_PLUS: alt_op = INTRINSIC_MINUS; break; case INTRINSIC_TIMES: alt_op = INTRINSIC_DIVIDE; break; case INTRINSIC_MINUS: alt_op = INTRINSIC_PLUS; break; case INTRINSIC_DIVIDE: alt_op = INTRINSIC_TIMES; break; case INTRINSIC_AND: case INTRINSIC_OR: break; case INTRINSIC_EQV: alt_op = INTRINSIC_NEQV; break; case INTRINSIC_NEQV: alt_op = INTRINSIC_EQV; break; default: gfc_error ("!$OMP ATOMIC assignment operator must be " "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L", &expr2->where); return; } /* Check for var = var op expr resp. var = expr op var where expr doesn't reference var and var op expr is mathematically equivalent to var op (expr) resp. expr op var equivalent to (expr) op var. We rely here on the fact that the matcher for x op1 y op2 z where op1 and op2 have equal precedence returns (x op1 y) op2 z. */ e = expr2->value.op.op2; if (e->expr_type == EXPR_VARIABLE && e->symtree != NULL && e->symtree->n.sym == var) v = e; else if ((c = is_conversion (e, true)) != NULL && c->expr_type == EXPR_VARIABLE && c->symtree != NULL && c->symtree->n.sym == var) v = c; else { gfc_expr **p = NULL, **q; for (q = &expr2->value.op.op1; (e = *q) != NULL; ) if (e->expr_type == EXPR_VARIABLE && e->symtree != NULL && e->symtree->n.sym == var) { v = e; break; } else if ((c = is_conversion (e, true)) != NULL) q = &e->value.function.actual->expr; else if (e->expr_type != EXPR_OP || (e->value.op.op != op && e->value.op.op != alt_op) || e->rank != 0) break; else { p = q; q = &e->value.op.op1; } if (v == NULL) { gfc_error ("!$OMP ATOMIC assignment must be var = var op expr " "or var = expr op var at %L", &expr2->where); return; } if (p != NULL) { e = *p; switch (e->value.op.op) { case INTRINSIC_MINUS: case INTRINSIC_DIVIDE: case INTRINSIC_EQV: case INTRINSIC_NEQV: gfc_error ("!$OMP ATOMIC var = var op expr not " "mathematically equivalent to var = var op " "(expr) at %L", &expr2->where); break; default: break; } /* Canonicalize into var = var op (expr). */ *p = e->value.op.op2; e->value.op.op2 = expr2; e->ts = expr2->ts; if (code->expr2 == expr2) code->expr2 = expr2 = e; else code->expr2->value.function.actual->expr = expr2 = e; if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts)) { for (p = &expr2->value.op.op1; *p != v; p = &(*p)->value.function.actual->expr) ; *p = NULL; gfc_free_expr (expr2->value.op.op1); expr2->value.op.op1 = v; gfc_convert_type (v, &expr2->ts, 2); } } } if (e->rank != 0 || expr_references_sym (code->expr2, var, v)) { gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr " "must be scalar and cannot reference var at %L", &expr2->where); return; } } else if (expr2->expr_type == EXPR_FUNCTION && expr2->value.function.isym != NULL && expr2->value.function.esym == NULL && expr2->value.function.actual != NULL && expr2->value.function.actual->next != NULL) { gfc_actual_arglist *arg, *var_arg; switch (expr2->value.function.isym->id) { case GFC_ISYM_MIN: case GFC_ISYM_MAX: break; case GFC_ISYM_IAND: case GFC_ISYM_IOR: case GFC_ISYM_IEOR: if (expr2->value.function.actual->next->next != NULL) { gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR " "or IEOR must have two arguments at %L", &expr2->where); return; } break; default: gfc_error ("!$OMP ATOMIC assignment intrinsic must be " "MIN, MAX, IAND, IOR or IEOR at %L", &expr2->where); return; } var_arg = NULL; for (arg = expr2->value.function.actual; arg; arg = arg->next) { if ((arg == expr2->value.function.actual || (var_arg == NULL && arg->next == NULL)) && arg->expr->expr_type == EXPR_VARIABLE && arg->expr->symtree != NULL && arg->expr->symtree->n.sym == var) var_arg = arg; else if (expr_references_sym (arg->expr, var, NULL)) gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not " "reference '%s' at %L", var->name, &arg->expr->where); if (arg->expr->rank != 0) gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar " "at %L", &arg->expr->where); } if (var_arg == NULL) { gfc_error ("First or last !$OMP ATOMIC intrinsic argument must " "be '%s' at %L", var->name, &expr2->where); return; } if (var_arg != expr2->value.function.actual) { /* Canonicalize, so that var comes first. */ gcc_assert (var_arg->next == NULL); for (arg = expr2->value.function.actual; arg->next != var_arg; arg = arg->next) ; var_arg->next = expr2->value.function.actual; expr2->value.function.actual = var_arg; arg->next = NULL; } } else gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic " "on right hand side at %L", &expr2->where); }