Mercurial > hg > CbC > CbC_gcc

comparison gcc/fortran/class.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 /* Implementation of Fortran 2003 Polymorphism. 1 /* Implementation of Fortran 2003 Polymorphism.
2 Copyright (C) 2009-2017 Free Software Foundation, Inc. 2 Copyright (C) 2009-2018 Free Software Foundation, Inc.
3 Contributed by Paul Richard Thomas <pault@gcc.gnu.org> 3 Contributed by Paul Richard Thomas <pault@gcc.gnu.org>
4 and Janus Weil <janus@gcc.gnu.org> 4 and Janus Weil <janus@gcc.gnu.org>
5 5
6 This file is part of GCC. 6 This file is part of GCC.
7 7
33 declared type of the class variable and its attributes 33 declared type of the class variable and its attributes
34 (pointer/allocatable/dimension/...). 34 (pointer/allocatable/dimension/...).
35 * _vptr: A pointer to the vtable entry (see below) of the dynamic type. 35 * _vptr: A pointer to the vtable entry (see below) of the dynamic type.
36 36
37 Only for unlimited polymorphic classes: 37 Only for unlimited polymorphic classes:
38 * _len: An integer(4) to store the string length when the unlimited 38 * _len: An integer(C_SIZE_T) to store the string length when the unlimited
39 polymorphic pointer is used to point to a char array. The '_len' 39 polymorphic pointer is used to point to a char array. The '_len'
40 component will be zero when no character array is stored in 40 component will be zero when no character array is stored in
41 '_data'. 41 '_data'.
42 42
43 For each derived type we set up a "vtable" entry, i.e. a structure with the 43 For each derived type we set up a "vtable" entry, i.e. a structure with the
306 with_data = true; 306 with_data = true;
307 if (full_array) 307 if (full_array)
308 *full_array = true; 308 *full_array = true;
309 } 309 }
310 else if (ref->next && ref->next->type == REF_ARRAY 310 else if (ref->next && ref->next->type == REF_ARRAY
311 && !ref->next->next
312 && ref->type == REF_COMPONENT 311 && ref->type == REF_COMPONENT
313 && ref->next->u.ar.type != AR_ELEMENT) 312 && ref->next->u.ar.type != AR_ELEMENT)
314 { 313 {
315 with_data = true; 314 with_data = true;
316 if (full_array) 315 if (full_array)
600 599
601 bool 600 bool
602 gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, 601 gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
603 gfc_array_spec **as) 602 gfc_array_spec **as)
604 { 603 {
605 char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1]; 604 char tname[GFC_MAX_SYMBOL_LEN+1];
605 char *name;
606 gfc_symbol *fclass; 606 gfc_symbol *fclass;
607 gfc_symbol *vtab; 607 gfc_symbol *vtab;
608 gfc_component *c; 608 gfc_component *c;
609 gfc_namespace *ns; 609 gfc_namespace *ns;
610 int rank; 610 int rank;
631 631
632 /* Determine the name of the encapsulating type. */ 632 /* Determine the name of the encapsulating type. */
633 rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank; 633 rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank;
634 get_unique_hashed_string (tname, ts->u.derived); 634 get_unique_hashed_string (tname, ts->u.derived);
635 if ((*as) && attr->allocatable) 635 if ((*as) && attr->allocatable)
636 sprintf (name, "__class_%s_%d_%da", tname, rank, (*as)->corank); 636 name = xasprintf ("__class_%s_%d_%da", tname, rank, (*as)->corank);
637 else if ((*as) && attr->pointer) 637 else if ((*as) && attr->pointer)
638 sprintf (name, "__class_%s_%d_%dp", tname, rank, (*as)->corank); 638 name = xasprintf ("__class_%s_%d_%dp", tname, rank, (*as)->corank);
639 else if ((*as)) 639 else if ((*as))
640 sprintf (name, "__class_%s_%d_%dt", tname, rank, (*as)->corank); 640 name = xasprintf ("__class_%s_%d_%dt", tname, rank, (*as)->corank);
641 else if (attr->pointer) 641 else if (attr->pointer)
642 sprintf (name, "__class_%s_p", tname); 642 name = xasprintf ("__class_%s_p", tname);
643 else if (attr->allocatable) 643 else if (attr->allocatable)
644 sprintf (name, "__class_%s_a", tname); 644 name = xasprintf ("__class_%s_a", tname);
645 else 645 else
646 sprintf (name, "__class_%s_t", tname); 646 name = xasprintf ("__class_%s_t", tname);
647 647
648 if (ts->u.derived->attr.unlimited_polymorphic) 648 if (ts->u.derived->attr.unlimited_polymorphic)
649 { 649 {
650 /* Find the top-level namespace. */ 650 /* Find the top-level namespace. */
651 for (ns = gfc_current_ns; ns; ns = ns->parent) 651 for (ns = gfc_current_ns; ns; ns = ns->parent)
736 736
737 fclass->attr.is_class = 1; 737 fclass->attr.is_class = 1;
738 ts->u.derived = fclass; 738 ts->u.derived = fclass;
739 attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0; 739 attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
740 (*as) = NULL; 740 (*as) = NULL;
741 free (name);
741 return true; 742 return true;
742 } 743 }
743 744
744 745
745 /* Add a procedure pointer component to the vtype 746 /* Add a procedure pointer component to the vtype
1525 gfc_symbol *final, *array, *fini_coarray, *byte_stride, *sizes, *strides; 1526 gfc_symbol *final, *array, *fini_coarray, *byte_stride, *sizes, *strides;
1526 gfc_symbol *ptr = NULL, *idx, *idx2, *is_contiguous, *offset, *nelem; 1527 gfc_symbol *ptr = NULL, *idx, *idx2, *is_contiguous, *offset, *nelem;
1527 gfc_component *comp; 1528 gfc_component *comp;
1528 gfc_namespace *sub_ns; 1529 gfc_namespace *sub_ns;
1529 gfc_code *last_code, *block; 1530 gfc_code *last_code, *block;
1530 char name[GFC_MAX_SYMBOL_LEN+1]; 1531 char *name;
1531 bool finalizable_comp = false; 1532 bool finalizable_comp = false;
1532 bool expr_null_wrapper = false; 1533 bool expr_null_wrapper = false;
1533 gfc_expr *ancestor_wrapper = NULL, *rank; 1534 gfc_expr *ancestor_wrapper = NULL, *rank;
1534 gfc_iterator *iter; 1535 gfc_iterator *iter;
1535 1536
1604 if (!expr_null_wrapper) 1605 if (!expr_null_wrapper)
1605 ns->contained = sub_ns; 1606 ns->contained = sub_ns;
1606 sub_ns->resolved = 1; 1607 sub_ns->resolved = 1;
1607 1608
1608 /* Set up the procedure symbol. */ 1609 /* Set up the procedure symbol. */
1609 sprintf (name, "__final_%s", tname); 1610 name = xasprintf ("__final_%s", tname);
1610 gfc_get_symbol (name, sub_ns, &final); 1611 gfc_get_symbol (name, sub_ns, &final);
1611 sub_ns->proc_name = final; 1612 sub_ns->proc_name = final;
1612 final->attr.flavor = FL_PROCEDURE; 1613 final->attr.flavor = FL_PROCEDURE;
1613 final->attr.function = 1; 1614 final->attr.function = 1;
1614 final->attr.pure = 0; 1615 final->attr.pure = 0;
2170 } 2171 }
2171 2172
2172 gfc_free_expr (rank); 2173 gfc_free_expr (rank);
2173 vtab_final->initializer = gfc_lval_expr_from_sym (final); 2174 vtab_final->initializer = gfc_lval_expr_from_sym (final);
2174 vtab_final->ts.interface = final; 2175 vtab_final->ts.interface = final;
2176 free (name);
2175 } 2177 }
2176 2178
2177 2179
2178 /* Add procedure pointers for all type-bound procedures to a vtab. */ 2180 /* Add procedure pointers for all type-bound procedures to a vtab. */
2179 2181
2237 && ns->proc_name->attr.flavor == FL_MODULE) 2239 && ns->proc_name->attr.flavor == FL_MODULE)
2238 ns = gsym->ns; 2240 ns = gsym->ns;
2239 2241
2240 if (ns) 2242 if (ns)
2241 { 2243 {
2242 char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1]; 2244 char tname[GFC_MAX_SYMBOL_LEN+1];
2245 char *name;
2243 2246
2244 get_unique_hashed_string (tname, derived); 2247 get_unique_hashed_string (tname, derived);
2245 sprintf (name, "__vtab_%s", tname); 2248 name = xasprintf ("__vtab_%s", tname);
2246 2249
2247 /* Look for the vtab symbol in various namespaces. */ 2250 /* Look for the vtab symbol in various namespaces. */
2248 if (gsym && gsym->ns) 2251 if (gsym && gsym->ns)
2249 { 2252 {
2250 gfc_find_symbol (name, gsym->ns, 0, &vtab); 2253 gfc_find_symbol (name, gsym->ns, 0, &vtab);
2268 vtab->attr.target = 1; 2271 vtab->attr.target = 1;
2269 vtab->attr.save = SAVE_IMPLICIT; 2272 vtab->attr.save = SAVE_IMPLICIT;
2270 vtab->attr.vtab = 1; 2273 vtab->attr.vtab = 1;
2271 vtab->attr.access = ACCESS_PUBLIC; 2274 vtab->attr.access = ACCESS_PUBLIC;
2272 gfc_set_sym_referenced (vtab); 2275 gfc_set_sym_referenced (vtab);
2273 sprintf (name, "__vtype_%s", tname); 2276 name = xasprintf ("__vtype_%s", tname);
2274 2277
2275 gfc_find_symbol (name, ns, 0, &vtype); 2278 gfc_find_symbol (name, ns, 0, &vtype);
2276 if (vtype == NULL) 2279 if (vtype == NULL)
2277 { 2280 {
2278 gfc_component *c; 2281 gfc_component *c;
2311 2314
2312 /* Add component '_size'. */ 2315 /* Add component '_size'. */
2313 if (!gfc_add_component (vtype, "_size", &c)) 2316 if (!gfc_add_component (vtype, "_size", &c))
2314 goto cleanup; 2317 goto cleanup;
2315 c->ts.type = BT_INTEGER; 2318 c->ts.type = BT_INTEGER;
2316 c->ts.kind = 4; 2319 c->ts.kind = gfc_size_kind;
2317 c->attr.access = ACCESS_PRIVATE; 2320 c->attr.access = ACCESS_PRIVATE;
2318 /* Remember the derived type in ts.u.derived, 2321 /* Remember the derived type in ts.u.derived,
2319 so that the correct initializer can be set later on 2322 so that the correct initializer can be set later on
2320 (in gfc_conv_structure). */ 2323 (in gfc_conv_structure). */
2321 c->ts.u.derived = derived; 2324 c->ts.u.derived = derived;
2322 c->initializer = gfc_get_int_expr (gfc_default_integer_kind, 2325 c->initializer = gfc_get_int_expr (gfc_size_kind,
2323 NULL, 0); 2326 NULL, 0);
2324 2327
2325 /* Add component _extends. */ 2328 /* Add component _extends. */
2326 if (!gfc_add_component (vtype, "_extends", &c)) 2329 if (!gfc_add_component (vtype, "_extends", &c))
2327 goto cleanup; 2330 goto cleanup;
2371 || derived->attr.abstract) 2374 || derived->attr.abstract)
2372 c->initializer = gfc_get_null_expr (NULL); 2375 c->initializer = gfc_get_null_expr (NULL);
2373 else 2376 else
2374 { 2377 {
2375 /* Construct default initialization variable. */ 2378 /* Construct default initialization variable. */
2376 sprintf (name, "__def_init_%s", tname); 2379 name = xasprintf ("__def_init_%s", tname);
2377 gfc_get_symbol (name, ns, &def_init); 2380 gfc_get_symbol (name, ns, &def_init);
2378 def_init->attr.target = 1; 2381 def_init->attr.target = 1;
2379 def_init->attr.artificial = 1; 2382 def_init->attr.artificial = 1;
2380 def_init->attr.save = SAVE_IMPLICIT; 2383 def_init->attr.save = SAVE_IMPLICIT;
2381 def_init->attr.access = ACCESS_PUBLIC; 2384 def_init->attr.access = ACCESS_PUBLIC;
2404 gfc_namespace *sub_ns = gfc_get_namespace (ns, 0); 2407 gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
2405 sub_ns->sibling = ns->contained; 2408 sub_ns->sibling = ns->contained;
2406 ns->contained = sub_ns; 2409 ns->contained = sub_ns;
2407 sub_ns->resolved = 1; 2410 sub_ns->resolved = 1;
2408 /* Set up procedure symbol. */ 2411 /* Set up procedure symbol. */
2409 sprintf (name, "__copy_%s", tname); 2412 name = xasprintf ("__copy_%s", tname);
2410 gfc_get_symbol (name, sub_ns, &copy); 2413 gfc_get_symbol (name, sub_ns, &copy);
2411 sub_ns->proc_name = copy; 2414 sub_ns->proc_name = copy;
2412 copy->attr.flavor = FL_PROCEDURE; 2415 copy->attr.flavor = FL_PROCEDURE;
2413 copy->attr.subroutine = 1; 2416 copy->attr.subroutine = 1;
2414 copy->attr.pure = 1; 2417 copy->attr.pure = 1;
2481 2484
2482 sub_ns->sibling = ns->contained; 2485 sub_ns->sibling = ns->contained;
2483 ns->contained = sub_ns; 2486 ns->contained = sub_ns;
2484 sub_ns->resolved = 1; 2487 sub_ns->resolved = 1;
2485 /* Set up procedure symbol. */ 2488 /* Set up procedure symbol. */
2486 sprintf (name, "__deallocate_%s", tname); 2489 name = xasprintf ("__deallocate_%s", tname);
2487 gfc_get_symbol (name, sub_ns, &dealloc); 2490 gfc_get_symbol (name, sub_ns, &dealloc);
2488 sub_ns->proc_name = dealloc; 2491 sub_ns->proc_name = dealloc;
2489 dealloc->attr.flavor = FL_PROCEDURE; 2492 dealloc->attr.flavor = FL_PROCEDURE;
2490 dealloc->attr.subroutine = 1; 2493 dealloc->attr.subroutine = 1;
2491 dealloc->attr.pure = 1; 2494 dealloc->attr.pure = 1;
2530 2533
2531 have_vtype: 2534 have_vtype:
2532 vtab->ts.u.derived = vtype; 2535 vtab->ts.u.derived = vtype;
2533 vtab->value = gfc_default_initializer (&vtab->ts); 2536 vtab->value = gfc_default_initializer (&vtab->ts);
2534 } 2537 }
2538 free (name);
2535 } 2539 }
2536 2540
2537 found_sym = vtab; 2541 found_sym = vtab;
2538 2542
2539 cleanup: 2543 cleanup:
2621 if (!ns->parent) 2625 if (!ns->parent)
2622 break; 2626 break;
2623 2627
2624 if (ns) 2628 if (ns)
2625 { 2629 {
2626 char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1]; 2630 char tname[GFC_MAX_SYMBOL_LEN+1];
2631 char *name;
2627 2632
2628 /* Encode all types as TYPENAME_KIND_ including especially character 2633 /* Encode all types as TYPENAME_KIND_ including especially character
2629 arrays, whose length is now consistently stored in the _len component 2634 arrays, whose length is now consistently stored in the _len component
2630 of the class-variable. */ 2635 of the class-variable. */
2631 sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind); 2636 sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind);
2632 sprintf (name, "__vtab_%s", tname); 2637 name = xasprintf ("__vtab_%s", tname);
2633 2638
2634 /* Look for the vtab symbol in the top-level namespace only. */ 2639 /* Look for the vtab symbol in the top-level namespace only. */
2635 gfc_find_symbol (name, ns, 0, &vtab); 2640 gfc_find_symbol (name, ns, 0, &vtab);
2636 2641
2637 if (vtab == NULL) 2642 if (vtab == NULL)
2644 vtab->attr.target = 1; 2649 vtab->attr.target = 1;
2645 vtab->attr.save = SAVE_IMPLICIT; 2650 vtab->attr.save = SAVE_IMPLICIT;
2646 vtab->attr.vtab = 1; 2651 vtab->attr.vtab = 1;
2647 vtab->attr.access = ACCESS_PUBLIC; 2652 vtab->attr.access = ACCESS_PUBLIC;
2648 gfc_set_sym_referenced (vtab); 2653 gfc_set_sym_referenced (vtab);
2649 sprintf (name, "__vtype_%s", tname); 2654 name = xasprintf ("__vtype_%s", tname);
2650 2655
2651 gfc_find_symbol (name, ns, 0, &vtype); 2656 gfc_find_symbol (name, ns, 0, &vtype);
2652 if (vtype == NULL) 2657 if (vtype == NULL)
2653 { 2658 {
2654 gfc_component *c; 2659 gfc_component *c;
2677 2682
2678 /* Add component '_size'. */ 2683 /* Add component '_size'. */
2679 if (!gfc_add_component (vtype, "_size", &c)) 2684 if (!gfc_add_component (vtype, "_size", &c))
2680 goto cleanup; 2685 goto cleanup;
2681 c->ts.type = BT_INTEGER; 2686 c->ts.type = BT_INTEGER;
2682 c->ts.kind = 4; 2687 c->ts.kind = gfc_size_kind;
2683 c->attr.access = ACCESS_PRIVATE; 2688 c->attr.access = ACCESS_PRIVATE;
2684 2689
2685 /* Build a minimal expression to make use of 2690 /* Build a minimal expression to make use of
2686 target-memory.c/gfc_element_size for 'size'. Special handling 2691 target-memory.c/gfc_element_size for 'size'. Special handling
2687 for character arrays, that are not constant sized: to support 2692 for character arrays, that are not constant sized: to support
2688 len (str) * kind, only the kind information is stored in the 2693 len (str) * kind, only the kind information is stored in the
2689 vtab. */ 2694 vtab. */
2690 e = gfc_get_expr (); 2695 e = gfc_get_expr ();
2691 e->ts = *ts; 2696 e->ts = *ts;
2692 e->expr_type = EXPR_VARIABLE; 2697 e->expr_type = EXPR_VARIABLE;
2693 c->initializer = gfc_get_int_expr (gfc_default_integer_kind, 2698 c->initializer = gfc_get_int_expr (gfc_size_kind,
2694 NULL, 2699 NULL,
2695 ts->type == BT_CHARACTER 2700 ts->type == BT_CHARACTER
2696 ? ts->kind 2701 ? ts->kind
2697 : (int)gfc_element_size (e)); 2702 : gfc_element_size (e));
2698 gfc_free_expr (e); 2703 gfc_free_expr (e);
2699 2704
2700 /* Add component _extends. */ 2705 /* Add component _extends. */
2701 if (!gfc_add_component (vtype, "_extends", &c)) 2706 if (!gfc_add_component (vtype, "_extends", &c))
2702 goto cleanup; 2707 goto cleanup;
2720 c->attr.access = ACCESS_PRIVATE; 2725 c->attr.access = ACCESS_PRIVATE;
2721 c->tb = XCNEW (gfc_typebound_proc); 2726 c->tb = XCNEW (gfc_typebound_proc);
2722 c->tb->ppc = 1; 2727 c->tb->ppc = 1;
2723 2728
2724 if (ts->type != BT_CHARACTER) 2729 if (ts->type != BT_CHARACTER)
2725 sprintf (name, "__copy_%s", tname); 2730 name = xasprintf ("__copy_%s", tname);
2726 else 2731 else
2727 { 2732 {
2728 /* __copy is always the same for characters. 2733 /* __copy is always the same for characters.
2729 Check to see if copy function already exists. */ 2734 Check to see if copy function already exists. */
2730 sprintf (name, "__copy_character_%d", ts->kind); 2735 name = xasprintf ("__copy_character_%d", ts->kind);
2731 contained = ns->contained; 2736 contained = ns->contained;
2732 for (; contained; contained = contained->sibling) 2737 for (; contained; contained = contained->sibling)
2733 if (contained->proc_name 2738 if (contained->proc_name
2734 && strcmp (name, contained->proc_name->name) == 0) 2739 && strcmp (name, contained->proc_name->name) == 0)
2735 { 2740 {
2794 c->initializer = gfc_get_null_expr (NULL); 2799 c->initializer = gfc_get_null_expr (NULL);
2795 } 2800 }
2796 vtab->ts.u.derived = vtype; 2801 vtab->ts.u.derived = vtype;
2797 vtab->value = gfc_default_initializer (&vtab->ts); 2802 vtab->value = gfc_default_initializer (&vtab->ts);
2798 } 2803 }
2804 free (name);
2799 } 2805 }
2800 2806
2801 found_sym = vtab; 2807 found_sym = vtab;
2802 2808
2803 cleanup: 2809 cleanup: