void gfc_release_include_path (void) { gfc_directorylist *p; gfc_free (gfc_option.module_dir); while (include_dirs != NULL) { p = include_dirs; include_dirs = include_dirs->next; gfc_free (p->path); gfc_free (p); } }
tree gfc_conv_string_init (tree length, gfc_expr * expr) { char *s; HOST_WIDE_INT len; int slen; tree str; gcc_assert (expr->expr_type == EXPR_CONSTANT); gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1); gcc_assert (INTEGER_CST_P (length)); gcc_assert (TREE_INT_CST_HIGH (length) == 0); len = TREE_INT_CST_LOW (length); slen = expr->value.character.length; if (len > slen) { s = gfc_getmem (len); memcpy (s, expr->value.character.string, slen); memset (&s[slen], ' ', len - slen); str = gfc_build_string_const (len, s); gfc_free (s); } else str = gfc_build_string_const (len, expr->value.character.string); return str; }
tree gfc_conv_string_init (tree length, gfc_expr * expr) { gfc_char_t *s; HOST_WIDE_INT len; int slen; tree str; bool free_s = false; gcc_assert (expr->expr_type == EXPR_CONSTANT); gcc_assert (expr->ts.type == BT_CHARACTER); gcc_assert (INTEGER_CST_P (length)); gcc_assert (TREE_INT_CST_HIGH (length) == 0); len = TREE_INT_CST_LOW (length); slen = expr->value.character.length; if (len > slen) { s = gfc_get_wide_string (len); memcpy (s, expr->value.character.string, slen * sizeof (gfc_char_t)); gfc_wide_memset (&s[slen], ' ', len - slen); free_s = true; } else s = expr->value.character.string; str = gfc_build_wide_string_const (expr->ts.kind, len, s); if (free_s) gfc_free (s); return str; }
void gfc_trans_runtime_check (tree cond, const char * msgid, stmtblock_t * pblock, locus * where) { stmtblock_t block; tree body; tree tmp; tree args; char * message; int line; if (integer_zerop (cond)) return; /* The code to generate the error. */ gfc_start_block (&block); if (where) { #ifdef USE_MAPPED_LOCATION line = LOCATION_LINE (where->lb->location); #else line = where->lb->linenum; #endif asprintf (&message, "%s (in file '%s', at line %d)", _(msgid), where->lb->file->filename, line); } else asprintf (&message, "%s (in file '%s', around line %d)", _(msgid), gfc_source_file, input_line + 1); tmp = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message)); gfc_free(message); args = gfc_chainon_list (NULL_TREE, tmp); tmp = build_function_call_expr (gfor_fndecl_runtime_error, args); gfc_add_expr_to_block (&block, tmp); body = gfc_finish_block (&block); if (integer_onep (cond)) { gfc_add_expr_to_block (pblock, body); } else { /* Tell the compiler that this isn't likely. */ cond = fold_convert (long_integer_type_node, cond); tmp = gfc_chainon_list (NULL_TREE, cond); tmp = gfc_chainon_list (tmp, build_int_cst (long_integer_type_node, 0)); cond = build_function_call_expr (built_in_decls[BUILT_IN_EXPECT], tmp); cond = fold_convert (boolean_type_node, cond); tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ()); gfc_add_expr_to_block (pblock, tmp); } }
void gfc_free_interface (gfc_interface * intr) { gfc_interface *next; for (; intr; intr = next) { next = intr->next; gfc_free (intr); } }
void gfc_scanner_done_1 (void) { gfc_linebuf *lb; gfc_file *f; while(line_head != NULL) { lb = line_head->next; gfc_free(line_head); line_head = lb; } while(file_head != NULL) { f = file_head->next; gfc_free(file_head->filename); gfc_free(file_head); file_head = f; } }
void gfc_free_omp_clauses (gfc_omp_clauses *c) { int i; if (c == NULL) return; gfc_free_expr (c->if_expr); gfc_free_expr (c->num_threads); gfc_free_expr (c->chunk_size); for (i = 0; i < OMP_LIST_NUM; i++) gfc_free_namelist (c->lists[i]); gfc_free (c); }
void gfc_free_array_spec (gfc_array_spec * as) { int i; if (as == NULL) return; for (i = 0; i < as->rank; i++) { gfc_free_expr (as->lower[i]); gfc_free_expr (as->upper[i]); } gfc_free (as); }
static int check_interface0 (gfc_interface * p, const char *interface_name) { gfc_interface *psave, *q, *qlast; psave = p; /* Make sure all symbols in the interface have been defined as functions or subroutines. */ for (; p; p = p->next) if (!p->sym->attr.function && !p->sym->attr.subroutine) { gfc_error ("Procedure '%s' in %s at %L is neither function nor " "subroutine", p->sym->name, interface_name, &p->sym->declared_at); return 1; } p = psave; /* Remove duplicate interfaces in this interface list. */ for (; p; p = p->next) { qlast = p; for (q = p->next; q;) { if (p->sym != q->sym) { qlast = q; q = q->next; } else { /* Duplicate interface */ qlast->next = q->next; gfc_free (q); q = qlast->next; } } } return 0; }
tree gfc_build_wide_string_const (int kind, int length, const gfc_char_t *string) { int i; tree str, len; size_t size; char *s; i = gfc_validate_kind (BT_CHARACTER, kind, false); size = length * gfc_character_kinds[i].bit_size / 8; s = XCNEWVAR (char, size); gfc_encode_character (kind, length, string, (unsigned char *) s, size); str = build_string (size, s); gfc_free (s); len = build_int_cst (NULL_TREE, length); TREE_TYPE (str) = build_array_type (gfc_get_char_type (kind), build_range_type (gfc_charlen_type_node, integer_one_node, len)); return str; }
static void preprocessor_line (char *c) { bool flag[5]; int i, line; char *filename; gfc_file *f; int escaped; c++; while (*c == ' ' || *c == '\t') c++; if (*c < '0' || *c > '9') goto bad_cpp_line; line = atoi (c); c = strchr (c, ' '); if (c == NULL) { /* No file name given. Set new line number. */ current_file->line = line; return; } /* Skip spaces. */ while (*c == ' ' || *c == '\t') c++; /* Skip quote. */ if (*c != '"') goto bad_cpp_line; ++c; filename = c; /* Make filename end at quote. */ escaped = false; while (*c && ! (! escaped && *c == '"')) { if (escaped) escaped = false; else escaped = *c == '\\'; ++c; } if (! *c) /* Preprocessor line has no closing quote. */ goto bad_cpp_line; *c++ = '\0'; /* Get flags. */ flag[1] = flag[2] = flag[3] = flag[4] = false; for (;;) { c = strchr (c, ' '); if (c == NULL) break; c++; i = atoi (c); if (1 <= i && i <= 4) flag[i] = true; } /* Interpret flags. */ if (flag[1]) /* Starting new file. */ { f = get_file (filename, LC_RENAME); f->up = current_file; current_file = f; } if (flag[2]) /* Ending current file. */ { if (!current_file->up || strcmp (current_file->up->filename, filename) != 0) { gfc_warning_now ("%s:%d: file %s left but not entered", current_file->filename, current_file->line, filename); return; } current_file = current_file->up; } /* The name of the file can be a temporary file produced by cpp. Replace the name if it is different. */ if (strcmp (current_file->filename, filename) != 0) { gfc_free (current_file->filename); current_file->filename = gfc_getmem (strlen (filename) + 1); strcpy (current_file->filename, filename); } /* Set new line number. */ current_file->line = line; return; bad_cpp_line: gfc_warning_now ("%s:%d: Illegal preprocessor directive", current_file->filename, current_file->line); current_file->line++; }
static void gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) { gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL; gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL; gfc_symbol init_val_sym, outer_sym, intrinsic_sym; gfc_expr *e1, *e2, *e3, *e4; gfc_ref *ref; tree decl, backend_decl, stmt; locus old_loc = gfc_current_locus; const char *iname; gfc_try t; decl = OMP_CLAUSE_DECL (c); gfc_current_locus = where; /* Create a fake symbol for init value. */ memset (&init_val_sym, 0, sizeof (init_val_sym)); init_val_sym.ns = sym->ns; init_val_sym.name = sym->name; init_val_sym.ts = sym->ts; init_val_sym.attr.referenced = 1; init_val_sym.declared_at = where; init_val_sym.attr.flavor = FL_VARIABLE; backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym)); init_val_sym.backend_decl = backend_decl; /* Create a fake symbol for the outer array reference. */ outer_sym = *sym; outer_sym.as = gfc_copy_array_spec (sym->as); outer_sym.attr.dummy = 0; outer_sym.attr.result = 0; outer_sym.attr.flavor = FL_VARIABLE; outer_sym.backend_decl = create_tmp_var_raw (TREE_TYPE (decl), NULL); /* Create fake symtrees for it. */ symtree1 = gfc_new_symtree (&root1, sym->name); symtree1->n.sym = sym; gcc_assert (symtree1 == root1); symtree2 = gfc_new_symtree (&root2, sym->name); symtree2->n.sym = &init_val_sym; gcc_assert (symtree2 == root2); symtree3 = gfc_new_symtree (&root3, sym->name); symtree3->n.sym = &outer_sym; gcc_assert (symtree3 == root3); /* Create expressions. */ e1 = gfc_get_expr (); e1->expr_type = EXPR_VARIABLE; e1->where = where; e1->symtree = symtree1; e1->ts = sym->ts; e1->ref = ref = gfc_get_ref (); ref->type = REF_ARRAY; ref->u.ar.where = where; ref->u.ar.as = sym->as; ref->u.ar.type = AR_FULL; ref->u.ar.dimen = 0; t = gfc_resolve_expr (e1); gcc_assert (t == SUCCESS); e2 = gfc_get_expr (); e2->expr_type = EXPR_VARIABLE; e2->where = where; e2->symtree = symtree2; e2->ts = sym->ts; t = gfc_resolve_expr (e2); gcc_assert (t == SUCCESS); e3 = gfc_copy_expr (e1); e3->symtree = symtree3; t = gfc_resolve_expr (e3); gcc_assert (t == SUCCESS); iname = NULL; switch (OMP_CLAUSE_REDUCTION_CODE (c)) { case PLUS_EXPR: case MINUS_EXPR: e4 = gfc_add (e3, e1); break; case MULT_EXPR: e4 = gfc_multiply (e3, e1); break; case TRUTH_ANDIF_EXPR: e4 = gfc_and (e3, e1); break; case TRUTH_ORIF_EXPR: e4 = gfc_or (e3, e1); break; case EQ_EXPR: e4 = gfc_eqv (e3, e1); break; case NE_EXPR: e4 = gfc_neqv (e3, e1); break; case MIN_EXPR: iname = "min"; break; case MAX_EXPR: iname = "max"; break; case BIT_AND_EXPR: iname = "iand"; break; case BIT_IOR_EXPR: iname = "ior"; break; case BIT_XOR_EXPR: iname = "ieor"; break; default: gcc_unreachable (); } if (iname != NULL) { memset (&intrinsic_sym, 0, sizeof (intrinsic_sym)); intrinsic_sym.ns = sym->ns; intrinsic_sym.name = iname; intrinsic_sym.ts = sym->ts; intrinsic_sym.attr.referenced = 1; intrinsic_sym.attr.intrinsic = 1; intrinsic_sym.attr.function = 1; intrinsic_sym.result = &intrinsic_sym; intrinsic_sym.declared_at = where; symtree4 = gfc_new_symtree (&root4, iname); symtree4->n.sym = &intrinsic_sym; gcc_assert (symtree4 == root4); e4 = gfc_get_expr (); e4->expr_type = EXPR_FUNCTION; e4->where = where; e4->symtree = symtree4; e4->value.function.isym = gfc_find_function (iname); e4->value.function.actual = gfc_get_actual_arglist (); e4->value.function.actual->expr = e3; e4->value.function.actual->next = gfc_get_actual_arglist (); e4->value.function.actual->next->expr = e1; } /* e1 and e3 have been stored as arguments of e4, avoid sharing. */ e1 = gfc_copy_expr (e1); e3 = gfc_copy_expr (e3); t = gfc_resolve_expr (e4); gcc_assert (t == SUCCESS); /* Create the init statement list. */ pushlevel (0); if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)) && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_ALLOCATABLE) { /* If decl is an allocatable array, it needs to be allocated with the same bounds as the outer var. */ tree type = TREE_TYPE (decl), rank, size, esize, ptr; stmtblock_t block; gfc_start_block (&block); gfc_add_modify (&block, decl, outer_sym.backend_decl); rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; size = gfc_conv_descriptor_ubound_get (decl, rank); size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size, gfc_conv_descriptor_lbound_get (decl, rank)); size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size, gfc_index_one_node); if (GFC_TYPE_ARRAY_RANK (type) > 1) size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, gfc_conv_descriptor_stride_get (decl, rank)); esize = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (gfc_get_element_type (type))); size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize); size = gfc_evaluate_now (fold_convert (size_type_node, size), &block); ptr = gfc_allocate_array_with_status (&block, build_int_cst (pvoid_type_node, 0), size, NULL, NULL); gfc_conv_descriptor_data_set (&block, decl, ptr); gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false)); stmt = gfc_finish_block (&block); } else stmt = gfc_trans_assignment (e1, e2, false); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0)); else poplevel (0, 0, 0); OMP_CLAUSE_REDUCTION_INIT (c) = stmt; /* Create the merge statement list. */ pushlevel (0); if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)) && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_ALLOCATABLE) { /* If decl is an allocatable array, it needs to be deallocated afterwards. */ stmtblock_t block; gfc_start_block (&block); gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false)); gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl)); stmt = gfc_finish_block (&block); } else stmt = gfc_trans_assignment (e3, e4, false); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0)); else poplevel (0, 0, 0); OMP_CLAUSE_REDUCTION_MERGE (c) = stmt; /* And stick the placeholder VAR_DECL into the clause as well. */ OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_sym.backend_decl; gfc_current_locus = old_loc; gfc_free_expr (e1); gfc_free_expr (e2); gfc_free_expr (e3); gfc_free_expr (e4); gfc_free (symtree1); gfc_free (symtree2); gfc_free (symtree3); if (symtree4) gfc_free (symtree4); gfc_free_array_spec (outer_sym.as); }
load_file (char *filename, bool initial) { char *line; gfc_linebuf *b; gfc_file *f; FILE *input; int len, line_len; for (f = current_file; f; f = f->up) if (strcmp (filename, f->filename) == 0) { gfc_error_now ("File '%s' is being included recursively", filename); return FAILURE; } if (initial) { input = gfc_open_file (filename); if (input == NULL) { gfc_error_now ("Can't open file '%s'", filename); return FAILURE; } } else { input = gfc_open_included_file (filename, false); if (input == NULL) { gfc_error_now ("Can't open included file '%s'", filename); return FAILURE; } } /* Load the file. */ f = get_file (filename, initial ? LC_RENAME : LC_ENTER); f->up = current_file; current_file = f; current_file->line = 1; line = NULL; line_len = 0; for (;;) { int trunc = load_line (input, &line, &line_len); len = strlen (line); if (feof (input) && len == 0) break; /* There are three things this line can be: a line of Fortran source, an include line or a C preprocessor directive. */ if (line[0] == '#') { preprocessor_line (line); continue; } if (include_line (line)) { current_file->line++; continue; } /* Add line. */ b = gfc_getmem (gfc_linebuf_header_size + len + 1); #ifdef USE_MAPPED_LOCATION b->location = linemap_line_start (&line_table, current_file->line++, 120); #else b->linenum = current_file->line++; #endif b->file = current_file; b->truncated = trunc; strcpy (b->line, line); if (line_head == NULL) line_head = b; else line_tail->next = b; line_tail = b; } /* Release the line buffer allocated in load_line. */ gfc_free (line); fclose (input); current_file = current_file->up; #ifdef USE_MAPPED_LOCATION linemap_add (&line_table, LC_LEAVE, 0, NULL, 0); #endif return SUCCESS; }
static void create_common (gfc_common_head *com, segment_info *head, bool saw_equiv) { segment_info *s, *next_s; tree union_type; tree *field_link; tree field; tree field_init = NULL_TREE; record_layout_info rli; tree decl; bool is_init = false; bool is_saved = false; /* Declare the variables inside the common block. If the current common block contains any equivalence object, then make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the alias analyzer work well when there is no address overlapping for common variables in the current common block. */ if (saw_equiv) union_type = make_node (UNION_TYPE); else union_type = make_node (RECORD_TYPE); rli = start_record_layout (union_type); field_link = &TYPE_FIELDS (union_type); /* Check for overlapping initializers and replace them with a single, artificial field that contains all the data. */ if (saw_equiv) field = get_init_field (head, union_type, &field_init, rli); else field = NULL_TREE; if (field != NULL_TREE) { is_init = true; *field_link = field; field_link = &DECL_CHAIN (field); } for (s = head; s; s = s->next) { build_field (s, union_type, rli); /* Link the field into the type. */ *field_link = s->field; field_link = &DECL_CHAIN (s->field); /* Has initial value. */ if (s->sym->value) is_init = true; /* Has SAVE attribute. */ if (s->sym->attr.save) is_saved = true; } finish_record_layout (rli, true); if (com) decl = build_common_decl (com, union_type, is_init); else decl = build_equiv_decl (union_type, is_init, is_saved); if (is_init) { tree ctor, tmp; VEC(constructor_elt,gc) *v = NULL; if (field != NULL_TREE && field_init != NULL_TREE) CONSTRUCTOR_APPEND_ELT (v, field, field_init); else for (s = head; s; s = s->next) { if (s->sym->value) { /* Add the initializer for this field. */ tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts, TREE_TYPE (s->field), s->sym->attr.dimension, s->sym->attr.pointer || s->sym->attr.allocatable, false); CONSTRUCTOR_APPEND_ELT (v, s->field, tmp); } } gcc_assert (!VEC_empty (constructor_elt, v)); ctor = build_constructor (union_type, v); TREE_CONSTANT (ctor) = 1; TREE_STATIC (ctor) = 1; DECL_INITIAL (decl) = ctor; #ifdef ENABLE_CHECKING { tree field, value; unsigned HOST_WIDE_INT idx; FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value) gcc_assert (TREE_CODE (field) == FIELD_DECL); } #endif } /* Build component reference for each variable. */ for (s = head; s; s = next_s) { tree var_decl; var_decl = build_decl (s->sym->declared_at.lb->location, VAR_DECL, DECL_NAME (s->field), TREE_TYPE (s->field)); TREE_STATIC (var_decl) = TREE_STATIC (decl); TREE_USED (var_decl) = TREE_USED (decl); if (s->sym->attr.use_assoc) DECL_IGNORED_P (var_decl) = 1; if (s->sym->attr.target) TREE_ADDRESSABLE (var_decl) = 1; /* This is a fake variable just for debugging purposes. */ TREE_ASM_WRITTEN (var_decl) = 1; /* Fake variables are not visible from other translation units. */ TREE_PUBLIC (var_decl) = 0; /* To preserve identifier names in COMMON, chain to procedure scope unless at top level in a module definition. */ if (com && s->sym->ns->proc_name && s->sym->ns->proc_name->attr.flavor == FL_MODULE) var_decl = pushdecl_top_level (var_decl); else gfc_add_decl_to_function (var_decl); SET_DECL_VALUE_EXPR (var_decl, fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (s->field), decl, s->field, NULL_TREE)); DECL_HAS_VALUE_EXPR_P (var_decl) = 1; GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1; if (s->sym->attr.assign) { gfc_allocate_lang_decl (var_decl); GFC_DECL_ASSIGN (var_decl) = 1; GFC_DECL_STRING_LEN (var_decl) = GFC_DECL_STRING_LEN (s->field); GFC_DECL_ASSIGN_ADDR (var_decl) = GFC_DECL_ASSIGN_ADDR (s->field); } s->sym->backend_decl = var_decl; next_s = s->next; gfc_free (s); } }
static tree get_init_field (segment_info *head, tree union_type, tree *field_init, record_layout_info rli) { segment_info *s; HOST_WIDE_INT length = 0; HOST_WIDE_INT offset = 0; unsigned HOST_WIDE_INT known_align, desired_align; bool overlap = false; tree tmp, field; tree init; unsigned char *data, *chk; VEC(constructor_elt,gc) *v = NULL; tree type = unsigned_char_type_node; int i; /* Obtain the size of the union and check if there are any overlapping initializers. */ for (s = head; s; s = s->next) { HOST_WIDE_INT slen = s->offset + s->length; if (s->sym->value) { if (s->offset < offset) overlap = true; offset = slen; } length = length < slen ? slen : length; } if (!overlap) return NULL_TREE; /* Now absorb all the initializer data into a single vector, whilst checking for overlapping, unequal values. */ data = (unsigned char*)gfc_getmem ((size_t)length); chk = (unsigned char*)gfc_getmem ((size_t)length); /* TODO - change this when default initialization is implemented. */ memset (data, '\0', (size_t)length); memset (chk, '\0', (size_t)length); for (s = head; s; s = s->next) if (s->sym->value) gfc_merge_initializers (s->sym->ts, s->sym->value, &data[s->offset], &chk[s->offset], (size_t)s->length); for (i = 0; i < length; i++) CONSTRUCTOR_APPEND_ELT (v, NULL, build_int_cst (type, data[i])); gfc_free (data); gfc_free (chk); /* Build a char[length] array to hold the initializers. Much of what follows is borrowed from build_field, above. */ tmp = build_int_cst (gfc_array_index_type, length - 1); tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp); tmp = build_array_type (type, tmp); field = build_decl (gfc_current_locus.lb->location, FIELD_DECL, NULL_TREE, tmp); known_align = BIGGEST_ALIGNMENT; desired_align = update_alignment_for_field (rli, field, known_align); if (desired_align > known_align) DECL_PACKED (field) = 1; DECL_FIELD_CONTEXT (field) = union_type; DECL_FIELD_OFFSET (field) = size_int (0); DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node; SET_DECL_OFFSET_ALIGN (field, known_align); rli->offset = size_binop (MAX_EXPR, rli->offset, size_binop (PLUS_EXPR, DECL_FIELD_OFFSET (field), DECL_SIZE_UNIT (field))); init = build_constructor (TREE_TYPE (field), v); TREE_CONSTANT (init) = 1; *field_init = init; for (s = head; s; s = s->next) { if (s->sym->value == NULL) continue; gfc_free_expr (s->sym->value); s->sym->value = NULL; } return field; }
gfc_try 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; 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) gfc_free (expr); continue; } 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); 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) == SUCCESS) { 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,"Extension: " "re-initialization of '%s' at %L", symbol->name, &exprd->where) == FAILURE) return FAILURE; } 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) == SUCCESS) { 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 FAILURE; 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,"Extension: " "re-initialization of '%s' at %L", symbol->name, &expr->where) == FAILURE) return FAILURE; } 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; abort: mpz_clear (offset); return FAILURE; }
static void create_common (gfc_common_head *com) { segment_info *s, *next_s; tree union_type; tree *field_link; record_layout_info rli; tree decl; bool is_init = false; /* Declare the variables inside the common block. */ union_type = make_node (UNION_TYPE); rli = start_record_layout (union_type); field_link = &TYPE_FIELDS (union_type); for (s = current_common; s; s = s->next) { build_field (s, union_type, rli); /* Link the field into the type. */ *field_link = s->field; field_link = &TREE_CHAIN (s->field); /* Has initial value. */ if (s->sym->value) is_init = true; } finish_record_layout (rli, true); if (com) decl = build_common_decl (com, union_type, is_init); else decl = build_equiv_decl (union_type, is_init); if (is_init) { tree list, ctor, tmp; HOST_WIDE_INT offset = 0; list = NULL_TREE; for (s = current_common; s; s = s->next) { if (s->sym->value) { if (s->offset < offset) { /* We have overlapping initializers. It could either be partially initialized arrays (legal), or the user specified multiple initial values (illegal). We don't implement this yet, so bail out. */ gfc_todo_error ("Initialization of overlapping variables"); } /* Add the initializer for this field. */ tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts, TREE_TYPE (s->field), s->sym->attr.dimension, s->sym->attr.pointer || s->sym->attr.allocatable); list = tree_cons (s->field, tmp, list); offset = s->offset + s->length; } } gcc_assert (list); ctor = build1 (CONSTRUCTOR, union_type, nreverse(list)); TREE_CONSTANT (ctor) = 1; TREE_INVARIANT (ctor) = 1; TREE_STATIC (ctor) = 1; DECL_INITIAL (decl) = ctor; #ifdef ENABLE_CHECKING for (tmp = CONSTRUCTOR_ELTS (ctor); tmp; tmp = TREE_CHAIN (tmp)) gcc_assert (TREE_CODE (TREE_PURPOSE (tmp)) == FIELD_DECL); #endif } /* Build component reference for each variable. */ for (s = current_common; s; s = next_s) { s->sym->backend_decl = build3 (COMPONENT_REF, TREE_TYPE (s->field), decl, s->field, NULL_TREE); next_s = s->next; gfc_free (s); } }
void gfc_restore_backend_locus (locus * loc) { gfc_set_backend_locus (loc); gfc_free (loc->lb); }
static int count_types_test (gfc_formal_arglist * f1, gfc_formal_arglist * f2) { int rc, ac1, ac2, i, j, k, n1; gfc_formal_arglist *f; typedef struct { int flag; gfc_symbol *sym; } arginfo; arginfo *arg; n1 = 0; for (f = f1; f; f = f->next) n1++; /* Build an array of integers that gives the same integer to arguments of the same type/rank. */ arg = gfc_getmem (n1 * sizeof (arginfo)); f = f1; for (i = 0; i < n1; i++, f = f->next) { arg[i].flag = -1; arg[i].sym = f->sym; } k = 0; for (i = 0; i < n1; i++) { if (arg[i].flag != -1) continue; if (arg[i].sym->attr.optional) continue; /* Skip optional arguments */ arg[i].flag = k; /* Find other nonoptional arguments of the same type/rank. */ for (j = i + 1; j < n1; j++) if (!arg[j].sym->attr.optional && compare_type_rank_if (arg[i].sym, arg[j].sym)) arg[j].flag = k; k++; } /* Now loop over each distinct type found in f1. */ k = 0; rc = 0; for (i = 0; i < n1; i++) { if (arg[i].flag != k) continue; ac1 = 1; for (j = i + 1; j < n1; j++) if (arg[j].flag == k) ac1++; /* Count the number of arguments in f2 with that type, including those that are optional. */ ac2 = 0; for (f = f2; f; f = f->next) if (compare_type_rank_if (arg[i].sym, f->sym)) ac2++; if (ac1 > ac2) { rc = 1; break; } k++; } gfc_free (arg); return rc; }
static tree trans_runtime_error_vararg (bool error, locus* where, const char* msgid, va_list ap) { stmtblock_t block; tree tmp; tree arg, arg2; tree *argarray; tree fntype; char *message; const char *p; int line, nargs, i; location_t loc; /* Compute the number of extra arguments from the format string. */ for (p = msgid, nargs = 0; *p; p++) if (*p == '%') { p++; if (*p != '%') nargs++; } /* The code to generate the error. */ gfc_start_block (&block); if (where) { line = LOCATION_LINE (where->lb->location); asprintf (&message, "At line %d of file %s", line, where->lb->file->filename); } else asprintf (&message, "In file '%s', around line %d", gfc_source_file, input_line + 1); arg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const (message)); gfc_free(message); asprintf (&message, "%s", _(msgid)); arg2 = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const (message)); gfc_free(message); /* Build the argument array. */ argarray = XALLOCAVEC (tree, nargs + 2); argarray[0] = arg; argarray[1] = arg2; for (i = 0; i < nargs; i++) argarray[2 + i] = va_arg (ap, tree); /* Build the function call to runtime_(warning,error)_at; because of the variable number of arguments, we can't use build_call_expr_loc dinput_location, irectly. */ if (error) fntype = TREE_TYPE (gfor_fndecl_runtime_error_at); else fntype = TREE_TYPE (gfor_fndecl_runtime_warning_at); loc = where ? where->lb->location : input_location; tmp = fold_builtin_call_array (loc, TREE_TYPE (fntype), fold_build1_loc (loc, ADDR_EXPR, build_pointer_type (fntype), error ? gfor_fndecl_runtime_error_at : gfor_fndecl_runtime_warning_at), nargs + 2, argarray); gfc_add_expr_to_block (&block, tmp); return gfc_finish_block (&block); }
tree gfc_conv_mpfr_to_tree (mpfr_t f, int kind) { tree res; tree type; mp_exp_t exp; char *p; char *q; int n; int edigits; for (n = 0; gfc_real_kinds[n].kind != 0; n++) { if (gfc_real_kinds[n].kind == kind) break; } gcc_assert (gfc_real_kinds[n].kind); n = MAX (abs (gfc_real_kinds[n].min_exponent), abs (gfc_real_kinds[n].max_exponent)); edigits = 1; while (n > 0) { n = n / 10; edigits += 3; } if (kind == gfc_default_double_kind) p = mpfr_get_str (NULL, &exp, 10, 17, f, GFC_RND_MODE); else p = mpfr_get_str (NULL, &exp, 10, 8, f, GFC_RND_MODE); /* We also have one minus sign, "e", "." and a null terminator. */ q = (char *) gfc_getmem (strlen (p) + edigits + 4); if (p[0]) { if (p[0] == '-') { strcpy (&q[2], &p[1]); q[0] = '-'; q[1] = '.'; } else { strcpy (&q[1], p); q[0] = '.'; } strcat (q, "e"); sprintf (&q[strlen (q)], "%d", (int) exp); } else { strcpy (q, "0"); } type = gfc_get_real_type (kind); res = build_real (type, REAL_VALUE_ATOF (q, TYPE_MODE (type))); gfc_free (q); gfc_free (p); return res; }
static void gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) { gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL; gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL; gfc_symbol init_val_sym, outer_sym, intrinsic_sym; gfc_expr *e1, *e2, *e3, *e4; gfc_ref *ref; tree decl, backend_decl, stmt; locus old_loc = gfc_current_locus; const char *iname; try t; decl = OMP_CLAUSE_DECL (c); gfc_current_locus = where; /* Create a fake symbol for init value. */ memset (&init_val_sym, 0, sizeof (init_val_sym)); init_val_sym.ns = sym->ns; init_val_sym.name = sym->name; init_val_sym.ts = sym->ts; init_val_sym.attr.referenced = 1; init_val_sym.declared_at = where; init_val_sym.attr.flavor = FL_VARIABLE; backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym)); init_val_sym.backend_decl = backend_decl; /* Create a fake symbol for the outer array reference. */ outer_sym = *sym; outer_sym.as = gfc_copy_array_spec (sym->as); outer_sym.attr.dummy = 0; outer_sym.attr.result = 0; outer_sym.attr.flavor = FL_VARIABLE; outer_sym.backend_decl = create_tmp_var_raw (TREE_TYPE (decl), NULL); /* Create fake symtrees for it. */ symtree1 = gfc_new_symtree (&root1, sym->name); symtree1->n.sym = sym; gcc_assert (symtree1 == root1); symtree2 = gfc_new_symtree (&root2, sym->name); symtree2->n.sym = &init_val_sym; gcc_assert (symtree2 == root2); symtree3 = gfc_new_symtree (&root3, sym->name); symtree3->n.sym = &outer_sym; gcc_assert (symtree3 == root3); /* Create expressions. */ e1 = gfc_get_expr (); e1->expr_type = EXPR_VARIABLE; e1->where = where; e1->symtree = symtree1; e1->ts = sym->ts; e1->ref = ref = gfc_get_ref (); ref->u.ar.where = where; ref->u.ar.as = sym->as; ref->u.ar.type = AR_FULL; ref->u.ar.dimen = 0; t = gfc_resolve_expr (e1); gcc_assert (t == SUCCESS); e2 = gfc_get_expr (); e2->expr_type = EXPR_VARIABLE; e2->where = where; e2->symtree = symtree2; e2->ts = sym->ts; t = gfc_resolve_expr (e2); gcc_assert (t == SUCCESS); e3 = gfc_copy_expr (e1); e3->symtree = symtree3; t = gfc_resolve_expr (e3); gcc_assert (t == SUCCESS); iname = NULL; switch (OMP_CLAUSE_REDUCTION_CODE (c)) { case PLUS_EXPR: case MINUS_EXPR: e4 = gfc_add (e3, e1); break; case MULT_EXPR: e4 = gfc_multiply (e3, e1); break; case TRUTH_ANDIF_EXPR: e4 = gfc_and (e3, e1); break; case TRUTH_ORIF_EXPR: e4 = gfc_or (e3, e1); break; case EQ_EXPR: e4 = gfc_eqv (e3, e1); break; case NE_EXPR: e4 = gfc_neqv (e3, e1); break; case MIN_EXPR: iname = "min"; break; case MAX_EXPR: iname = "max"; break; case BIT_AND_EXPR: iname = "iand"; break; case BIT_IOR_EXPR: iname = "ior"; break; case BIT_XOR_EXPR: iname = "ieor"; break; default: gcc_unreachable (); } if (iname != NULL) { memset (&intrinsic_sym, 0, sizeof (intrinsic_sym)); intrinsic_sym.ns = sym->ns; intrinsic_sym.name = iname; intrinsic_sym.ts = sym->ts; intrinsic_sym.attr.referenced = 1; intrinsic_sym.attr.intrinsic = 1; intrinsic_sym.attr.function = 1; intrinsic_sym.result = &intrinsic_sym; intrinsic_sym.declared_at = where; symtree4 = gfc_new_symtree (&root4, iname); symtree4->n.sym = &intrinsic_sym; gcc_assert (symtree4 == root4); e4 = gfc_get_expr (); e4->expr_type = EXPR_FUNCTION; e4->where = where; e4->symtree = symtree4; e4->value.function.isym = gfc_find_function (iname); e4->value.function.actual = gfc_get_actual_arglist (); e4->value.function.actual->expr = e3; e4->value.function.actual->next = gfc_get_actual_arglist (); e4->value.function.actual->next->expr = e1; } /* e1 and e3 have been stored as arguments of e4, avoid sharing. */ e1 = gfc_copy_expr (e1); e3 = gfc_copy_expr (e3); t = gfc_resolve_expr (e4); gcc_assert (t == SUCCESS); /* Create the init statement list. */ pushlevel (0); stmt = gfc_trans_assignment (e1, e2, false); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0)); else poplevel (0, 0, 0); OMP_CLAUSE_REDUCTION_INIT (c) = stmt; /* Create the merge statement list. */ pushlevel (0); stmt = gfc_trans_assignment (e3, e4, false); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0)); else poplevel (0, 0, 0); OMP_CLAUSE_REDUCTION_MERGE (c) = stmt; /* And stick the placeholder VAR_DECL into the clause as well. */ OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_sym.backend_decl; gfc_current_locus = old_loc; gfc_free_expr (e1); gfc_free_expr (e2); gfc_free_expr (e3); gfc_free_expr (e4); gfc_free (symtree1); gfc_free (symtree2); gfc_free (symtree3); if (symtree4) gfc_free (symtree4); gfc_free_array_spec (outer_sym.as); } static tree gfc_trans_omp_reduction_list (gfc_namelist *namelist, tree list, enum tree_code reduction_code, locus where) { for (; namelist != NULL; namelist = namelist->next) if (namelist->sym->attr.referenced) { tree t = gfc_trans_omp_variable (namelist->sym); if (t != error_mark_node) { tree node = build_omp_clause (OMP_CLAUSE_REDUCTION); OMP_CLAUSE_DECL (node) = t; OMP_CLAUSE_REDUCTION_CODE (node) = reduction_code; if (namelist->sym->attr.dimension) gfc_trans_omp_array_reduction (node, namelist->sym, where); list = gfc_trans_add_clause (node, list); } } return list; } static tree gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, locus where) { tree omp_clauses = NULL_TREE, chunk_size, c, old_clauses; int list; enum omp_clause_code clause_code; gfc_se se; if (clauses == NULL) return NULL_TREE; for (list = 0; list < OMP_LIST_NUM; list++) { gfc_namelist *n = clauses->lists[list]; if (n == NULL) continue; if (list >= OMP_LIST_REDUCTION_FIRST && list <= OMP_LIST_REDUCTION_LAST) { enum tree_code reduction_code; switch (list) { case OMP_LIST_PLUS: reduction_code = PLUS_EXPR; break; case OMP_LIST_MULT: reduction_code = MULT_EXPR; break; case OMP_LIST_SUB: reduction_code = MINUS_EXPR; break; case OMP_LIST_AND: reduction_code = TRUTH_ANDIF_EXPR; break; case OMP_LIST_OR: reduction_code = TRUTH_ORIF_EXPR; break; case OMP_LIST_EQV: reduction_code = EQ_EXPR; break; case OMP_LIST_NEQV: reduction_code = NE_EXPR; break; case OMP_LIST_MAX: reduction_code = MAX_EXPR; break; case OMP_LIST_MIN: reduction_code = MIN_EXPR; break; case OMP_LIST_IAND: reduction_code = BIT_AND_EXPR; break; case OMP_LIST_IOR: reduction_code = BIT_IOR_EXPR; break; case OMP_LIST_IEOR: reduction_code = BIT_XOR_EXPR; break; default: gcc_unreachable (); } old_clauses = omp_clauses; omp_clauses = gfc_trans_omp_reduction_list (n, omp_clauses, reduction_code, where); continue; } switch (list) { case OMP_LIST_PRIVATE: clause_code = OMP_CLAUSE_PRIVATE; goto add_clause; case OMP_LIST_SHARED: clause_code = OMP_CLAUSE_SHARED; goto add_clause; case OMP_LIST_FIRSTPRIVATE: clause_code = OMP_CLAUSE_FIRSTPRIVATE; goto add_clause; case OMP_LIST_LASTPRIVATE: clause_code = OMP_CLAUSE_LASTPRIVATE; goto add_clause; case OMP_LIST_COPYIN: clause_code = OMP_CLAUSE_COPYIN; goto add_clause; case OMP_LIST_COPYPRIVATE: clause_code = OMP_CLAUSE_COPYPRIVATE; /* FALLTHROUGH */ add_clause: omp_clauses = gfc_trans_omp_variable_list (clause_code, n, omp_clauses); break; default: break; } } if (clauses->if_expr) { tree if_var; gfc_init_se (&se, NULL); gfc_conv_expr (&se, clauses->if_expr); gfc_add_block_to_block (block, &se.pre); if_var = gfc_evaluate_now (se.expr, block); gfc_add_block_to_block (block, &se.post); c = build_omp_clause (OMP_CLAUSE_IF); OMP_CLAUSE_IF_EXPR (c) = if_var; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->num_threads) { tree num_threads; gfc_init_se (&se, NULL); gfc_conv_expr (&se, clauses->num_threads); gfc_add_block_to_block (block, &se.pre); num_threads = gfc_evaluate_now (se.expr, block); gfc_add_block_to_block (block, &se.post); c = build_omp_clause (OMP_CLAUSE_NUM_THREADS); OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } chunk_size = NULL_TREE; if (clauses->chunk_size) { gfc_init_se (&se, NULL); gfc_conv_expr (&se, clauses->chunk_size); gfc_add_block_to_block (block, &se.pre); chunk_size = gfc_evaluate_now (se.expr, block); gfc_add_block_to_block (block, &se.post); } if (clauses->sched_kind != OMP_SCHED_NONE) { c = build_omp_clause (OMP_CLAUSE_SCHEDULE); OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size; switch (clauses->sched_kind) { case OMP_SCHED_STATIC: OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC; break; case OMP_SCHED_DYNAMIC: OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC; break; case OMP_SCHED_GUIDED: OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED; break; case OMP_SCHED_RUNTIME: OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME; break; default: gcc_unreachable (); } omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN) { c = build_omp_clause (OMP_CLAUSE_DEFAULT); switch (clauses->default_sharing) { case OMP_DEFAULT_NONE: OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE; break; case OMP_DEFAULT_SHARED: OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED; break; case OMP_DEFAULT_PRIVATE: OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE; break; default: gcc_unreachable (); } omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->nowait) { c = build_omp_clause (OMP_CLAUSE_NOWAIT); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->ordered) { c = build_omp_clause (OMP_CLAUSE_ORDERED); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } return omp_clauses; }