Mercurial > hg > CbC > CbC_gcc

comparison gcc/fortran/trans-types.c @ 145:1830386684a0

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc-9.2.0
author anatofuz
date Thu, 13 Feb 2020 11:34:05 +0900
parents 84e7813d76e9
children
comparison
equal deleted inserted replaced
131:84e7813d76e9 145:1830386684a0
1 /* Backend support for Fortran 95 basic types and derived types. 1 /* Backend support for Fortran 95 basic types and derived types.
2 Copyright (C) 2002-2018 Free Software Foundation, Inc. 2 Copyright (C) 2002-2020 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org> 3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl> 4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
5 5
6 This file is part of GCC. 6 This file is part of GCC.
7 7
1174 symbol that was declared of type C_PTR or C_FUNPTR. */ 1174 symbol that was declared of type C_PTR or C_FUNPTR. */
1175 if (spec->u.derived->ts.f90_type == BT_VOID) 1175 if (spec->u.derived->ts.f90_type == BT_VOID)
1176 { 1176 {
1177 spec->type = BT_INTEGER; 1177 spec->type = BT_INTEGER;
1178 spec->kind = gfc_index_integer_kind; 1178 spec->kind = gfc_index_integer_kind;
1179 spec->f90_type = BT_VOID; 1179 spec->f90_type = BT_VOID;
1180 spec->is_c_interop = 1; /* Mark as escaping later. */
1180 } 1181 }
1181 break; 1182 break;
1182 case BT_VOID: 1183 case BT_VOID:
1183 case BT_ASSUMED: 1184 case BT_ASSUMED:
1184 /* This is for the second arg to c_f_pointer and c_f_procpointer 1185 /* This is for the second arg to c_f_pointer and c_f_procpointer
1191 basetype = ptr_type_node; 1192 basetype = ptr_type_node;
1192 else 1193 else
1193 basetype = pfunc_type_node; 1194 basetype = pfunc_type_node;
1194 } 1195 }
1195 break; 1196 break;
1197 case BT_PROCEDURE:
1198 basetype = pfunc_type_node;
1199 break;
1196 default: 1200 default:
1197 gcc_unreachable (); 1201 gcc_unreachable ();
1198 } 1202 }
1199 return basetype; 1203 return basetype;
1200 } 1204 }
1811 sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen + codimen); 1815 sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen + codimen);
1812 TYPE_NAME (fat_type) = get_identifier (name); 1816 TYPE_NAME (fat_type) = get_identifier (name);
1813 TYPE_NAMELESS (fat_type) = 1; 1817 TYPE_NAMELESS (fat_type) = 1;
1814 1818
1815 /* Add the data member as the first element of the descriptor. */ 1819 /* Add the data member as the first element of the descriptor. */
1816 decl = gfc_add_field_to_struct_1 (fat_type, 1820 gfc_add_field_to_struct_1 (fat_type,
1817 get_identifier ("data"), 1821 get_identifier ("data"),
1818 (restricted 1822 (restricted
1819 ? prvoid_type_node 1823 ? prvoid_type_node
1820 : ptr_type_node), &chain); 1824 : ptr_type_node), &chain);
1821 1825
1822 /* Add the base component. */ 1826 /* Add the base component. */
1823 decl = gfc_add_field_to_struct_1 (fat_type, 1827 decl = gfc_add_field_to_struct_1 (fat_type,
1824 get_identifier ("offset"), 1828 get_identifier ("offset"),
1825 gfc_array_index_type, &chain); 1829 gfc_array_index_type, &chain);
2955 || (f->sym->ts.type == BT_DERIVED 2959 || (f->sym->ts.type == BT_DERIVED
2956 && (f->sym->ts.u.derived->attr.proc_pointer_comp 2960 && (f->sym->ts.u.derived->attr.proc_pointer_comp
2957 || f->sym->ts.u.derived->attr.pointer_comp)) 2961 || f->sym->ts.u.derived->attr.pointer_comp))
2958 || (f->sym->ts.type == BT_CLASS 2962 || (f->sym->ts.type == BT_CLASS
2959 && (CLASS_DATA (f->sym)->ts.u.derived->attr.proc_pointer_comp 2963 && (CLASS_DATA (f->sym)->ts.u.derived->attr.proc_pointer_comp
2960 || CLASS_DATA (f->sym)->ts.u.derived->attr.pointer_comp))) 2964 || CLASS_DATA (f->sym)->ts.u.derived->attr.pointer_comp))
2965 || (f->sym->ts.type == BT_INTEGER && f->sym->ts.is_c_interop))
2961 spec[spec_len++] = '.'; 2966 spec[spec_len++] = '.';
2962 else if (f->sym->attr.intent == INTENT_IN) 2967 else if (f->sym->attr.intent == INTENT_IN)
2963 spec[spec_len++] = 'r'; 2968 spec[spec_len++] = 'r';
2964 else if (f->sym) 2969 else if (f->sym)
2965 spec[spec_len++] = 'w'; 2970 spec[spec_len++] = 'w';
2968 tmp = build_tree_list (NULL_TREE, build_string (spec_len, spec)); 2973 tmp = build_tree_list (NULL_TREE, build_string (spec_len, spec));
2969 tmp = tree_cons (get_identifier ("fn spec"), tmp, TYPE_ATTRIBUTES (fntype)); 2974 tmp = tree_cons (get_identifier ("fn spec"), tmp, TYPE_ATTRIBUTES (fntype));
2970 return build_type_attribute_variant (fntype, tmp); 2975 return build_type_attribute_variant (fntype, tmp);
2971 } 2976 }
2972 2977
2973
2974 tree 2978 tree
2975 gfc_get_function_type (gfc_symbol * sym) 2979 gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args)
2976 { 2980 {
2977 tree type; 2981 tree type;
2978 vec<tree, va_gc> *typelist = NULL; 2982 vec<tree, va_gc> *typelist = NULL;
2979 gfc_formal_arglist *f; 2983 gfc_formal_arglist *f;
2980 gfc_symbol *arg; 2984 gfc_symbol *arg;
3028 /* Deferred character lengths are transferred by reference 3032 /* Deferred character lengths are transferred by reference
3029 so that the value can be returned. */ 3033 so that the value can be returned. */
3030 vec_safe_push (typelist, build_pointer_type(gfc_charlen_type_node)); 3034 vec_safe_push (typelist, build_pointer_type(gfc_charlen_type_node));
3031 } 3035 }
3032 } 3036 }
3037 if (sym->backend_decl == error_mark_node && actual_args != NULL
3038 && sym->formal == NULL && (sym->attr.proc == PROC_EXTERNAL
3039 || sym->attr.proc == PROC_UNKNOWN))
3040 gfc_get_formal_from_actual_arglist (sym, actual_args);
3033 3041
3034 /* Build the argument types for the function. */ 3042 /* Build the argument types for the function. */
3035 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next) 3043 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
3036 { 3044 {
3037 arg = f->sym; 3045 arg = f->sym;
3088 so that the value can be returned. */ 3096 so that the value can be returned. */
3089 type = build_pointer_type (gfc_charlen_type_node); 3097 type = build_pointer_type (gfc_charlen_type_node);
3090 3098
3091 vec_safe_push (typelist, type); 3099 vec_safe_push (typelist, type);
3092 } 3100 }
3101 /* For noncharacter scalar intrinsic types, VALUE passes the value,
3102 hence, the optional status cannot be transferred via a NULL pointer.
3103 Thus, we will use a hidden argument in that case. */
3104 else if (arg
3105 && arg->attr.optional
3106 && arg->attr.value
3107 && !arg->attr.dimension
3108 && arg->ts.type != BT_CLASS
3109 && !gfc_bt_struct (arg->ts.type))
3110 vec_safe_push (typelist, boolean_type_node);
3093 } 3111 }
3094 3112
3095 if (!vec_safe_is_empty (typelist) 3113 if (!vec_safe_is_empty (typelist)
3096 || sym->attr.is_main_program 3114 || sym->attr.is_main_program
3097 || sym->attr.if_source != IFSRC_UNKNOWN) 3115 || sym->attr.if_source != IFSRC_UNKNOWN)
3256 gfc_get_array_descr_info (const_tree type, struct array_descr_info *info) 3274 gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
3257 { 3275 {
3258 int rank, dim; 3276 int rank, dim;
3259 bool indirect = false; 3277 bool indirect = false;
3260 tree etype, ptype, t, base_decl; 3278 tree etype, ptype, t, base_decl;
3261 tree data_off, dim_off, dtype_off, dim_size, elem_size; 3279 tree data_off, span_off, dim_off, dtype_off, dim_size, elem_size;
3262 tree lower_suboff, upper_suboff, stride_suboff; 3280 tree lower_suboff, upper_suboff, stride_suboff;
3263 tree dtype, field, rank_off; 3281 tree dtype, field, rank_off;
3264 3282
3265 if (! GFC_DESCRIPTOR_TYPE_P (type)) 3283 if (! GFC_DESCRIPTOR_TYPE_P (type))
3266 { 3284 {
3313 } 3331 }
3314 info->base_decl = base_decl; 3332 info->base_decl = base_decl;
3315 if (indirect) 3333 if (indirect)
3316 base_decl = build1 (INDIRECT_REF, ptype, base_decl); 3334 base_decl = build1 (INDIRECT_REF, ptype, base_decl);
3317 3335
3318 elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype)); 3336 gfc_get_descriptor_offsets_for_info (type, &data_off, &dtype_off, &span_off,
3319 3337 &dim_off, &dim_size, &stride_suboff,
3320 gfc_get_descriptor_offsets_for_info (type, &data_off, &dtype_off, &dim_off,
3321 &dim_size, &stride_suboff,
3322 &lower_suboff, &upper_suboff); 3338 &lower_suboff, &upper_suboff);
3339
3340 t = fold_build_pointer_plus (base_decl, span_off);
3341 elem_size = build1 (INDIRECT_REF, gfc_array_index_type, t);
3323 3342
3324 t = base_decl; 3343 t = base_decl;
3325 if (!integer_zerop (data_off)) 3344 if (!integer_zerop (data_off))
3326 t = fold_build_pointer_plus (t, data_off); 3345 t = fold_build_pointer_plus (t, data_off);
3327 t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t); 3346 t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t);