Mercurial > hg > CbC > CbC_gcc

comparison gcc/fortran/dump-parse-tree.c @ 131:84e7813d76e9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc-8.2
author mir3636
date Thu, 25 Oct 2018 07:37:49 +0900
parents 04ced10e8804
children 1830386684a0
comparison
equal deleted inserted replaced
111:04ced10e8804 131:84e7813d76e9
1 /* Parse tree dumper 1 /* Parse tree dumper
2 Copyright (C) 2003-2017 Free Software Foundation, Inc. 2 Copyright (C) 2003-2018 Free Software Foundation, Inc.
3 Contributed by Steven Bosscher 3 Contributed by Steven Bosscher
4 4
5 This file is part of GCC. 5 This file is part of GCC.
6 6
7 GCC is free software; you can redistribute it and/or modify it under 7 GCC is free software; you can redistribute it and/or modify it under
346 } 346 }
347 } 347 }
348 348
349 349
350 static void 350 static void
351 show_char_const (const gfc_char_t *c, int length) 351 show_char_const (const gfc_char_t *c, gfc_charlen_t length)
352 { 352 {
353 int i;
354
355 fputc ('\'', dumpfile); 353 fputc ('\'', dumpfile);
356 for (i = 0; i < length; i++) 354 for (size_t i = 0; i < (size_t) length; i++)
357 { 355 {
358 if (c[i] == '\'') 356 if (c[i] == '\'')
359 fputs ("''", dumpfile); 357 fputs ("''", dumpfile);
360 else 358 else
361 fputs (gfc_print_wide_char (c[i]), dumpfile); 359 fputs (gfc_print_wide_char (c[i]), dumpfile);
463 461
464 fputc (')', dumpfile); 462 fputc (')', dumpfile);
465 break; 463 break;
466 464
467 case BT_HOLLERITH: 465 case BT_HOLLERITH:
468 fprintf (dumpfile, "%dH", p->representation.length); 466 fprintf (dumpfile, HOST_WIDE_INT_PRINT_DEC "H",
467 p->representation.length);
469 c = p->representation.string; 468 c = p->representation.string;
470 for (i = 0; i < p->representation.length; i++, c++) 469 for (i = 0; i < p->representation.length; i++, c++)
471 { 470 {
472 fputc (*c, dumpfile); 471 fputc (*c, dumpfile);
473 } 472 }
715 fputs (" SEQUENCE", dumpfile); 714 fputs (" SEQUENCE", dumpfile);
716 if (attr->elemental) 715 if (attr->elemental)
717 fputs (" ELEMENTAL", dumpfile); 716 fputs (" ELEMENTAL", dumpfile);
718 if (attr->pure) 717 if (attr->pure)
719 fputs (" PURE", dumpfile); 718 fputs (" PURE", dumpfile);
719 if (attr->implicit_pure)
720 fputs (" IMPLICIT_PURE", dumpfile);
720 if (attr->recursive) 721 if (attr->recursive)
721 fputs (" RECURSIVE", dumpfile); 722 fputs (" RECURSIVE", dumpfile);
722 723
723 fputc (')', dumpfile); 724 fputc (')', dumpfile);
724 } 725 }
1381 && list_type != OMP_LIST_COPYPRIVATE) 1382 && list_type != OMP_LIST_COPYPRIVATE)
1382 { 1383 {
1383 const char *type = NULL; 1384 const char *type = NULL;
1384 switch (list_type) 1385 switch (list_type)
1385 { 1386 {
1386 case OMP_LIST_USE_DEVICE: type = "USE_DEVICE"; break;
1387 case OMP_LIST_DEVICE_RESIDENT: type = "USE_DEVICE"; break;
1388 case OMP_LIST_CACHE: type = ""; break;
1389 case OMP_LIST_PRIVATE: type = "PRIVATE"; break; 1387 case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
1390 case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break; 1388 case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1391 case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break; 1389 case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
1390 case OMP_LIST_COPYPRIVATE: type = "COPYPRIVATE"; break;
1392 case OMP_LIST_SHARED: type = "SHARED"; break; 1391 case OMP_LIST_SHARED: type = "SHARED"; break;
1393 case OMP_LIST_COPYIN: type = "COPYIN"; break; 1392 case OMP_LIST_COPYIN: type = "COPYIN"; break;
1394 case OMP_LIST_UNIFORM: type = "UNIFORM"; break; 1393 case OMP_LIST_UNIFORM: type = "UNIFORM"; break;
1395 case OMP_LIST_ALIGNED: type = "ALIGNED"; break; 1394 case OMP_LIST_ALIGNED: type = "ALIGNED"; break;
1396 case OMP_LIST_LINEAR: type = "LINEAR"; break; 1395 case OMP_LIST_LINEAR: type = "LINEAR"; break;
1396 case OMP_LIST_DEPEND: type = "DEPEND"; break;
1397 case OMP_LIST_MAP: type = "MAP"; break;
1398 case OMP_LIST_TO: type = "TO"; break;
1399 case OMP_LIST_FROM: type = "FROM"; break;
1397 case OMP_LIST_REDUCTION: type = "REDUCTION"; break; 1400 case OMP_LIST_REDUCTION: type = "REDUCTION"; break;
1401 case OMP_LIST_DEVICE_RESIDENT: type = "DEVICE_RESIDENT"; break;
1402 case OMP_LIST_LINK: type = "LINK"; break;
1403 case OMP_LIST_USE_DEVICE: type = "USE_DEVICE"; break;
1404 case OMP_LIST_CACHE: type = "CACHE"; break;
1398 case OMP_LIST_IS_DEVICE_PTR: type = "IS_DEVICE_PTR"; break; 1405 case OMP_LIST_IS_DEVICE_PTR: type = "IS_DEVICE_PTR"; break;
1399 case OMP_LIST_USE_DEVICE_PTR: type = "USE_DEVICE_PTR"; break; 1406 case OMP_LIST_USE_DEVICE_PTR: type = "USE_DEVICE_PTR"; break;
1400 case OMP_LIST_DEPEND: type = "DEPEND"; break;
1401 default: 1407 default:
1402 gcc_unreachable (); 1408 gcc_unreachable ();
1403 } 1409 }
1404 fprintf (dumpfile, " %s(", type); 1410 fprintf (dumpfile, " %s(", type);
1405 show_omp_namelist (list_type, omp_clauses->lists[list_type]); 1411 show_omp_namelist (list_type, omp_clauses->lists[list_type]);
1867 1873
1868 case EXEC_FAIL_IMAGE: 1874 case EXEC_FAIL_IMAGE:
1869 fputs ("FAIL IMAGE ", dumpfile); 1875 fputs ("FAIL IMAGE ", dumpfile);
1870 break; 1876 break;
1871 1877
1878 case EXEC_CHANGE_TEAM:
1879 fputs ("CHANGE TEAM", dumpfile);
1880 break;
1881
1882 case EXEC_END_TEAM:
1883 fputs ("END TEAM", dumpfile);
1884 break;
1885
1886 case EXEC_FORM_TEAM:
1887 fputs ("FORM TEAM", dumpfile);
1888 break;
1889
1890 case EXEC_SYNC_TEAM:
1891 fputs ("SYNC TEAM", dumpfile);
1892 break;
1893
1872 case EXEC_SYNC_ALL: 1894 case EXEC_SYNC_ALL:
1873 fputs ("SYNC ALL ", dumpfile); 1895 fputs ("SYNC ALL ", dumpfile);
1874 if (c->expr2 != NULL) 1896 if (c->expr2 != NULL)
1875 { 1897 {
1876 fputs (" stat=", dumpfile); 1898 fputs (" stat=", dumpfile);
3005 *asterisk = false; 3027 *asterisk = false;
3006 *post = ""; 3028 *post = "";
3007 *type_name = "<error>"; 3029 *type_name = "<error>";
3008 if (ts->type == BT_REAL || ts->type == BT_INTEGER) 3030 if (ts->type == BT_REAL || ts->type == BT_INTEGER)
3009 { 3031 {
3010
3011 if (ts->is_c_interop && ts->interop_kind) 3032 if (ts->is_c_interop && ts->interop_kind)
3012 { 3033 {
3013 *type_name = ts->interop_kind->name + 2; 3034 *type_name = ts->interop_kind->name + 2;
3014 if (strcmp (*type_name, "signed_char") == 0) 3035 if (strcmp (*type_name, "signed_char") == 0)
3015 *type_name = "signed char"; 3036 *type_name = "signed char";
3020 } 3041 }
3021 else 3042 else
3022 { 3043 {
3023 /* The user did not specify a C interop type. Let's look through 3044 /* The user did not specify a C interop type. Let's look through
3024 the available table and use the first one, but warn. */ 3045 the available table and use the first one, but warn. */
3025 int i; 3046 for (int i = 0; i < ISOCBINDING_NUMBER; i++)
3026 for (i=0; i<ISOCBINDING_NUMBER; i++)
3027 { 3047 {
3028 if (c_interop_kinds_table[i].f90_type == ts->type 3048 if (c_interop_kinds_table[i].f90_type == ts->type
3029 && c_interop_kinds_table[i].value == ts->kind) 3049 && c_interop_kinds_table[i].value == ts->kind)
3030 { 3050 {
3031 *type_name = c_interop_kinds_table[i].name + 2; 3051 *type_name = c_interop_kinds_table[i].name + 2;
3034 else if (strcmp (*type_name, "size_t") == 0) 3054 else if (strcmp (*type_name, "size_t") == 0)
3035 *type_name = "ssize_t"; 3055 *type_name = "ssize_t";
3036 3056
3037 ret = T_WARN; 3057 ret = T_WARN;
3038 break; 3058 break;
3059 }
3060 }
3061 }
3062 }
3063 else if (ts->type == BT_LOGICAL)
3064 {
3065 if (ts->is_c_interop && ts->interop_kind)
3066 {
3067 *type_name = "_Bool";
3068 ret = T_OK;
3069 }
3070 else
3071 {
3072 /* Let's select an appropriate int, with a warning. */
3073 for (int i = 0; i < ISOCBINDING_NUMBER; i++)
3074 {
3075 if (c_interop_kinds_table[i].f90_type == BT_INTEGER
3076 && c_interop_kinds_table[i].value == ts->kind)
3077 {
3078 *type_name = c_interop_kinds_table[i].name + 2;
3079 ret = T_WARN;
3080 }
3081 }
3082 }
3083 }
3084 else if (ts->type == BT_CHARACTER)
3085 {
3086 if (ts->is_c_interop)
3087 {
3088 *type_name = "char";
3089 ret = T_OK;
3090 }
3091 else
3092 {
3093 /* Let's select an appropriate int, with a warning. */
3094 for (int i = 0; i < ISOCBINDING_NUMBER; i++)
3095 {
3096 if (c_interop_kinds_table[i].f90_type == BT_INTEGER
3097 && c_interop_kinds_table[i].value == ts->kind)
3098 {
3099 *type_name = c_interop_kinds_table[i].name + 2;
3100 ret = T_WARN;
3039 } 3101 }
3040 } 3102 }
3041 } 3103 }
3042 } 3104 }
3043 else if (ts->type == BT_DERIVED) 3105 else if (ts->type == BT_DERIVED)
3081 } 3143 }
3082 3144
3083 /* Write out a declaration. */ 3145 /* Write out a declaration. */
3084 static void 3146 static void
3085 write_decl (gfc_typespec *ts, gfc_array_spec *as, const char *sym_name, 3147 write_decl (gfc_typespec *ts, gfc_array_spec *as, const char *sym_name,
3086 bool func_ret) 3148 bool func_ret, locus *where)
3087 { 3149 {
3088 const char *pre, *type_name, *post; 3150 const char *pre, *type_name, *post;
3089 bool asterisk; 3151 bool asterisk;
3090 enum type_return rok; 3152 enum type_return rok;
3091 3153
3092 rok = get_c_type_name (ts, as, &pre, &type_name, &asterisk, &post, func_ret); 3154 rok = get_c_type_name (ts, as, &pre, &type_name, &asterisk, &post, func_ret);
3093 gcc_assert (rok != T_ERROR); 3155 if (rok == T_ERROR)
3094 fputs (type_name, dumpfile); 3156 {
3095 fputs (pre, dumpfile); 3157 gfc_error_now ("Cannot convert %qs to interoperable type at %L",
3096 if (asterisk) 3158 gfc_typename (ts), where);
3097 fputs ("*", dumpfile); 3159 fprintf (dumpfile, "/* Cannot convert '%s' to interoperable type */",
3098 3160 gfc_typename (ts));
3099 fputs (sym_name, dumpfile); 3161 return;
3100 fputs (post, dumpfile); 3162 }
3163 fputs (type_name, dumpfile);
3164 fputs (pre, dumpfile);
3165 if (asterisk)
3166 fputs ("*", dumpfile);
3167
3168 fputs (sym_name, dumpfile);
3169 fputs (post, dumpfile);
3101 3170
3102 if (rok == T_WARN) 3171 if (rok == T_WARN)
3103 fputs(" /* WARNING: non-interoperable KIND */", dumpfile); 3172 fprintf (dumpfile," /* WARNING: Converting '%s' to interoperable type */",
3173 gfc_typename (ts));
3104 } 3174 }
3105 3175
3106 /* Write out an interoperable type. It will be written as a typedef 3176 /* Write out an interoperable type. It will be written as a typedef
3107 for a struct. */ 3177 for a struct. */
3108 3178
3113 3183
3114 fprintf (dumpfile, "typedef struct %s {\n", sym->name); 3184 fprintf (dumpfile, "typedef struct %s {\n", sym->name);
3115 for (c = sym->components; c; c = c->next) 3185 for (c = sym->components; c; c = c->next)
3116 { 3186 {
3117 fputs (" ", dumpfile); 3187 fputs (" ", dumpfile);
3118 write_decl (&(c->ts), c->as, c->name, false); 3188 write_decl (&(c->ts), c->as, c->name, false, &sym->declared_at);
3119 fputs (";\n", dumpfile); 3189 fputs (";\n", dumpfile);
3120 } 3190 }
3121 3191
3122 fprintf (dumpfile, "} %s;\n", sym->name); 3192 fprintf (dumpfile, "} %s;\n", sym->name);
3123 } 3193 }
3135 sym_name = sym->binding_label; 3205 sym_name = sym->binding_label;
3136 else 3206 else
3137 sym_name = sym->name; 3207 sym_name = sym->name;
3138 3208
3139 fputs ("extern ", dumpfile); 3209 fputs ("extern ", dumpfile);
3140 write_decl (&(sym->ts), sym->as, sym_name, false); 3210 write_decl (&(sym->ts), sym->as, sym_name, false, &sym->declared_at);
3141 fputs (";\n", dumpfile); 3211 fputs (";\n", dumpfile);
3142 } 3212 }
3143 3213
3144 3214
3145 /* Write out a procedure, including its arguments. */ 3215 /* Write out a procedure, including its arguments. */
3162 { 3232 {
3163 fprintf (dumpfile, "void "); 3233 fprintf (dumpfile, "void ");
3164 fputs (sym_name, dumpfile); 3234 fputs (sym_name, dumpfile);
3165 } 3235 }
3166 else 3236 else
3167 write_decl (&(sym->ts), sym->as, sym->name, true); 3237 write_decl (&(sym->ts), sym->as, sym_name, true, &sym->declared_at);
3168 3238
3169 fputs (" (", dumpfile); 3239 fputs (" (", dumpfile);
3170 3240
3171 for (f = sym->formal; f; f = f->next) 3241 for (f = sym->formal; f; f = f->next)
3172 { 3242 {
3173 gfc_symbol *s; 3243 gfc_symbol *s;
3174 s = f->sym; 3244 s = f->sym;
3175 rok = get_c_type_name (&(s->ts), NULL, &pre, &type_name, &asterisk, 3245 rok = get_c_type_name (&(s->ts), NULL, &pre, &type_name, &asterisk,
3176 &post, false); 3246 &post, false);
3177 gcc_assert (rok != T_ERROR); 3247 if (rok == T_ERROR)
3248 {
3249 gfc_error_now ("Cannot convert %qs to interoperable type at %L",
3250 gfc_typename (&s->ts), &s->declared_at);
3251 fprintf (stderr, "/* Cannot convert '%s' to interoperable type */",
3252 gfc_typename (&s->ts));
3253 return;
3254 }
3178 3255
3179 if (!s->attr.value) 3256 if (!s->attr.value)
3180 asterisk = true; 3257 asterisk = true;
3181 3258
3182 if (s->attr.intent == INTENT_IN && !s->attr.value) 3259 if (s->attr.intent == INTENT_IN && !s->attr.value)
3193 fputs (s->name, dumpfile); 3270 fputs (s->name, dumpfile);
3194 fputs (post, dumpfile); 3271 fputs (post, dumpfile);
3195 if (rok == T_WARN) 3272 if (rok == T_WARN)
3196 fputs(" /* WARNING: non-interoperable KIND */ ", dumpfile); 3273 fputs(" /* WARNING: non-interoperable KIND */ ", dumpfile);
3197 3274
3198 fputs (f->next ? ", " : ")", dumpfile); 3275 if (f->next)
3199 } 3276 fputs(", ", dumpfile);
3200 fputs (";\n", dumpfile); 3277 }
3278 fputs (");\n", dumpfile);
3201 } 3279 }
3202 3280
3203 3281
3204 /* Write a C-interoperable declaration as a C prototype or extern 3282 /* Write a C-interoperable declaration as a C prototype or extern
3205 declaration. */ 3283 declaration. */