/* Write a constant expression in binary form to a buffer. */ int gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer, size_t buffer_size) { if (source == NULL) return 0; if (source->expr_type == EXPR_ARRAY) return encode_array (source, buffer, buffer_size); gcc_assert (source->expr_type == EXPR_CONSTANT || source->expr_type == EXPR_STRUCTURE || source->expr_type == EXPR_SUBSTRING); /* If we already have a target-memory representation, we use that rather than recreating one. */ if (source->representation.string) { memcpy (buffer, source->representation.string, source->representation.length); return source->representation.length; } switch (source->ts.type) { case BT_INTEGER: return encode_integer (source->ts.kind, source->value.integer, buffer, buffer_size); case BT_REAL: return encode_float (source->ts.kind, source->value.real, buffer, buffer_size); case BT_COMPLEX: return encode_complex (source->ts.kind, source->value.complex.r, source->value.complex.i, buffer, buffer_size); case BT_LOGICAL: return encode_logical (source->ts.kind, source->value.logical, buffer, buffer_size); case BT_CHARACTER: if (source->expr_type == EXPR_CONSTANT || source->ref == NULL) return encode_character (source->value.character.length, source->value.character.string, buffer, buffer_size); else { int start, end; gcc_assert (source->expr_type == EXPR_SUBSTRING); gfc_extract_int (source->ref->u.ss.start, &start); gfc_extract_int (source->ref->u.ss.end, &end); return encode_character (MAX(end - start + 1, 0), &source->value.character.string[start-1], buffer, buffer_size); } case BT_DERIVED: return encode_derived (source, buffer, buffer_size); default: gfc_internal_error ("Invalid expression in gfc_target_encode_expr."); return 0; } }
size_t gfc_target_expr_size (gfc_expr *e) { tree type; gcc_assert (e != NULL); if (e->expr_type == EXPR_ARRAY) return size_array (e); switch (e->ts.type) { case BT_INTEGER: return size_integer (e->ts.kind); case BT_REAL: return size_float (e->ts.kind); case BT_COMPLEX: return size_complex (e->ts.kind); case BT_LOGICAL: return size_logical (e->ts.kind); case BT_CHARACTER: if (e->expr_type == EXPR_SUBSTRING && e->ref) { int start, end; gfc_extract_int (e->ref->u.ss.start, &start); gfc_extract_int (e->ref->u.ss.end, &end); return size_character (MAX(end - start + 1, 0), e->ts.kind); } else return size_character (e->value.character.length, e->ts.kind); case BT_HOLLERITH: return e->representation.length; case BT_DERIVED: type = gfc_typenode_for_spec (&e->ts); return int_size_in_bytes (type); default: gfc_internal_error ("Invalid expression in gfc_target_expr_size."); return 0; } }
static gfc_expr * create_character_intializer (gfc_expr * init, gfc_typespec * ts, gfc_ref * ref, gfc_expr * rvalue) { int len; int start; int end; char *dest; gfc_extract_int (ts->cl->length, &len); if (init == NULL) { /* Create a new initializer. */ init = gfc_get_expr (); init->expr_type = EXPR_CONSTANT; init->ts = *ts; dest = gfc_getmem (len + 1); dest[len] = '\0'; init->value.character.length = len; init->value.character.string = dest; /* Blank the string if we're only setting a substring. */ if (ref != NULL) memset (dest, ' ', len); } else dest = init->value.character.string; if (ref) { gfc_expr *start_expr, *end_expr; gcc_assert (ref->type == REF_SUBSTRING); /* Only set a substring of the destination. Fortran substring bounds are one-based [start, end], we want zero based [start, end). */ start_expr = gfc_copy_expr (ref->u.ss.start); end_expr = gfc_copy_expr (ref->u.ss.end); if ((gfc_simplify_expr (start_expr, 1) == FAILURE) || (gfc_simplify_expr (end_expr, 1)) == FAILURE) { gfc_error ("failure to simplify substring reference in DATA" "statement at %L", &ref->u.ss.start->where); return NULL; } gfc_extract_int (start_expr, &start); start--; gfc_extract_int (end_expr, &end); } else { /* Set the whole string. */ start = 0; end = len; } /* Copy the initial value. */ len = rvalue->value.character.length; if (len > end - start) { len = end - start; gfc_warning_now ("initialization string truncated to match variable " "at %L", &rvalue->where); } memcpy (&dest[start], rvalue->value.character.string, len); /* Pad with spaces. Substrings will already be blanked. */ if (len < end - start && ref == NULL) memset (&dest[start + len], ' ', end - (start + len)); if (rvalue->ts.type == BT_HOLLERITH) init->from_H = 1; return init; }
static gfc_expr * create_character_initializer (gfc_expr *init, gfc_typespec *ts, gfc_ref *ref, gfc_expr *rvalue) { int len, start, end, tlen; gfc_char_t *dest; bool alloced_init = false; gfc_extract_int (ts->u.cl->length, &len); if (init == NULL) { /* Create a new initializer. */ init = gfc_get_character_expr (ts->kind, NULL, NULL, len); init->ts = *ts; alloced_init = true; } dest = init->value.character.string; if (ref) { gfc_expr *start_expr, *end_expr; gcc_assert (ref->type == REF_SUBSTRING); /* Only set a substring of the destination. Fortran substring bounds are one-based [start, end], we want zero based [start, end). */ start_expr = gfc_copy_expr (ref->u.ss.start); end_expr = gfc_copy_expr (ref->u.ss.end); if ((!gfc_simplify_expr(start_expr, 1)) || !(gfc_simplify_expr(end_expr, 1))) { gfc_error ("failure to simplify substring reference in DATA " "statement at %L", &ref->u.ss.start->where); gfc_free_expr (start_expr); gfc_free_expr (end_expr); if (alloced_init) gfc_free_expr (init); return NULL; } gfc_extract_int (start_expr, &start); gfc_free_expr (start_expr); start--; gfc_extract_int (end_expr, &end); gfc_free_expr (end_expr); } else { /* Set the whole string. */ start = 0; end = len; } /* Copy the initial value. */ if (rvalue->ts.type == BT_HOLLERITH) len = rvalue->representation.length - rvalue->ts.u.pad; else len = rvalue->value.character.length; tlen = end - start; if (len > tlen) { if (tlen < 0) { gfc_warning_now (0, "Unused initialization string at %L because " "variable has zero length", &rvalue->where); len = 0; } else { gfc_warning_now (0, "Initialization string at %L was truncated to " "fit the variable (%d/%d)", &rvalue->where, tlen, len); len = tlen; } } if (rvalue->ts.type == BT_HOLLERITH) { int i; for (i = 0; i < len; i++) dest[start+i] = rvalue->representation.string[i]; } else memcpy (&dest[start], rvalue->value.character.string, len * sizeof (gfc_char_t)); /* Pad with spaces. Substrings will already be blanked. */ if (len < tlen && ref == NULL) gfc_wide_memset (&dest[start + len], ' ', end - (start + len)); if (rvalue->ts.type == BT_HOLLERITH) { init->representation.length = init->value.character.length; init->representation.string = gfc_widechar_to_char (init->value.character.string, init->value.character.length); } return init; }
static match gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask) { gfc_omp_clauses *c = gfc_get_omp_clauses (); locus old_loc; bool needs_space = true, first = true; *cp = NULL; while (1) { if ((first || gfc_match_char (',') != MATCH_YES) && (needs_space && gfc_match_space () != MATCH_YES)) break; needs_space = false; first = false; gfc_gobble_whitespace (); if ((mask & OMP_CLAUSE_IF) && c->if_expr == NULL && gfc_match ("if ( %e )", &c->if_expr) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_NUM_THREADS) && c->num_threads == NULL && gfc_match ("num_threads ( %e )", &c->num_threads) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_PRIVATE) && gfc_match_omp_variable_list ("private (", &c->lists[OMP_LIST_PRIVATE], true) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_FIRSTPRIVATE) && gfc_match_omp_variable_list ("firstprivate (", &c->lists[OMP_LIST_FIRSTPRIVATE], true) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_LASTPRIVATE) && gfc_match_omp_variable_list ("lastprivate (", &c->lists[OMP_LIST_LASTPRIVATE], true) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_COPYPRIVATE) && gfc_match_omp_variable_list ("copyprivate (", &c->lists[OMP_LIST_COPYPRIVATE], true) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_SHARED) && gfc_match_omp_variable_list ("shared (", &c->lists[OMP_LIST_SHARED], true) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_COPYIN) && gfc_match_omp_variable_list ("copyin (", &c->lists[OMP_LIST_COPYIN], true) == MATCH_YES) continue; old_loc = gfc_current_locus; if ((mask & OMP_CLAUSE_REDUCTION) && gfc_match ("reduction ( ") == MATCH_YES) { int reduction = OMP_LIST_NUM; char buffer[GFC_MAX_SYMBOL_LEN + 1]; if (gfc_match_char ('+') == MATCH_YES) reduction = OMP_LIST_PLUS; else if (gfc_match_char ('*') == MATCH_YES) reduction = OMP_LIST_MULT; else if (gfc_match_char ('-') == MATCH_YES) reduction = OMP_LIST_SUB; else if (gfc_match (".and.") == MATCH_YES) reduction = OMP_LIST_AND; else if (gfc_match (".or.") == MATCH_YES) reduction = OMP_LIST_OR; else if (gfc_match (".eqv.") == MATCH_YES) reduction = OMP_LIST_EQV; else if (gfc_match (".neqv.") == MATCH_YES) reduction = OMP_LIST_NEQV; else if (gfc_match_name (buffer) == MATCH_YES) { gfc_symbol *sym; const char *n = buffer; gfc_find_symbol (buffer, NULL, 1, &sym); if (sym != NULL) { if (sym->attr.intrinsic) n = sym->name; else if ((sym->attr.flavor != FL_UNKNOWN && sym->attr.flavor != FL_PROCEDURE) || sym->attr.external || sym->attr.generic || sym->attr.entry || sym->attr.result || sym->attr.dummy || sym->attr.subroutine || sym->attr.pointer || sym->attr.target || sym->attr.cray_pointer || sym->attr.cray_pointee || (sym->attr.proc != PROC_UNKNOWN && sym->attr.proc != PROC_INTRINSIC) || sym->attr.if_source != IFSRC_UNKNOWN || sym == sym->ns->proc_name) { gfc_error_now ("%s is not INTRINSIC procedure name " "at %C", buffer); sym = NULL; } else n = sym->name; } if (strcmp (n, "max") == 0) reduction = OMP_LIST_MAX; else if (strcmp (n, "min") == 0) reduction = OMP_LIST_MIN; else if (strcmp (n, "iand") == 0) reduction = OMP_LIST_IAND; else if (strcmp (n, "ior") == 0) reduction = OMP_LIST_IOR; else if (strcmp (n, "ieor") == 0) reduction = OMP_LIST_IEOR; if (reduction != OMP_LIST_NUM && sym != NULL && ! sym->attr.intrinsic && ! sym->attr.use_assoc && ((sym->attr.flavor == FL_UNKNOWN && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE) || gfc_add_intrinsic (&sym->attr, NULL) == FAILURE)) { gfc_free_omp_clauses (c); return MATCH_ERROR; } } if (reduction != OMP_LIST_NUM && gfc_match_omp_variable_list (" :", &c->lists[reduction], false) == MATCH_YES) continue; else gfc_current_locus = old_loc; } if ((mask & OMP_CLAUSE_DEFAULT) && c->default_sharing == OMP_DEFAULT_UNKNOWN) { if (gfc_match ("default ( shared )") == MATCH_YES) c->default_sharing = OMP_DEFAULT_SHARED; else if (gfc_match ("default ( private )") == MATCH_YES) c->default_sharing = OMP_DEFAULT_PRIVATE; else if (gfc_match ("default ( none )") == MATCH_YES) c->default_sharing = OMP_DEFAULT_NONE; else if (gfc_match ("default ( firstprivate )") == MATCH_YES) c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE; if (c->default_sharing != OMP_DEFAULT_UNKNOWN) continue; } old_loc = gfc_current_locus; if ((mask & OMP_CLAUSE_SCHEDULE) && c->sched_kind == OMP_SCHED_NONE && gfc_match ("schedule ( ") == MATCH_YES) { if (gfc_match ("static") == MATCH_YES) c->sched_kind = OMP_SCHED_STATIC; else if (gfc_match ("dynamic") == MATCH_YES) c->sched_kind = OMP_SCHED_DYNAMIC; else if (gfc_match ("guided") == MATCH_YES) c->sched_kind = OMP_SCHED_GUIDED; else if (gfc_match ("runtime") == MATCH_YES) c->sched_kind = OMP_SCHED_RUNTIME; else if (gfc_match ("auto") == MATCH_YES) c->sched_kind = OMP_SCHED_AUTO; if (c->sched_kind != OMP_SCHED_NONE) { match m = MATCH_NO; if (c->sched_kind != OMP_SCHED_RUNTIME && c->sched_kind != OMP_SCHED_AUTO) m = gfc_match (" , %e )", &c->chunk_size); if (m != MATCH_YES) m = gfc_match_char (')'); if (m != MATCH_YES) c->sched_kind = OMP_SCHED_NONE; } if (c->sched_kind != OMP_SCHED_NONE) continue; else gfc_current_locus = old_loc; } if ((mask & OMP_CLAUSE_ORDERED) && !c->ordered && gfc_match ("ordered") == MATCH_YES) { c->ordered = needs_space = true; continue; } if ((mask & OMP_CLAUSE_UNTIED) && !c->untied && gfc_match ("untied") == MATCH_YES) { c->untied = needs_space = true; continue; } if ((mask & OMP_CLAUSE_COLLAPSE) && !c->collapse) { gfc_expr *cexpr = NULL; match m = gfc_match ("collapse ( %e )", &cexpr); if (m == MATCH_YES) { int collapse; const char *p = gfc_extract_int (cexpr, &collapse); if (p) { gfc_error_now (p); collapse = 1; } else if (collapse <= 0) { gfc_error_now ("COLLAPSE clause argument not" " constant positive integer at %C"); collapse = 1; } c->collapse = collapse; gfc_free_expr (cexpr); continue; } } break; } if (gfc_match_omp_eos () != MATCH_YES) { gfc_free_omp_clauses (c); return MATCH_ERROR; } *cp = c; return MATCH_YES; }