Skip to content
Permalink
Browse files

Add F2008 polymorphic allocatable assignment

This also fixes Flang issues #244 and #721.
  • Loading branch information...
gklimowicz committed Oct 2, 2019
1 parent c59750d commit 922736bb999d1295abe91b1119e2411098acf2a4
@@ -1527,3 +1527,4 @@ A DO CONCURRENT variable with LOCAL_INIT locality must have a host variable of t
.MS S 1214 "PGI Accelerator $ data clause may not follow a device_type clause."
.MS S 1215 "OpenACC data clause expected after $."
.MS S 1216 "Expression in assignment statement contains type bound procedure name $. This may be a function call that's missing parentheses."
.MS S 1217 "Left hand side of polymorphic assignment must be allocatable - $"
@@ -35,6 +35,8 @@ static TYPE_DESC * get_parent_pointer(TYPE_DESC *src_td, __INT_T level);
static void sourced_alloc_and_assign_array(int extent, char *ab, char *bb, TYPE_DESC *td);
static void sourced_alloc_and_assign_array_from_scalar(int extent, char *ab, char *bb, TYPE_DESC *td);

static void get_source_and_dest_sizes(F90_Desc *ad, F90_Desc *bd, int *dest_sz, int *src_sz, int *dest_is_array, int *src_is_array, TYPE_DESC **tad, TYPE_DESC **tbd, __INT_T flag);

#define ARG1_PTR 0x1
#define ARG1_ALLOC 0x2
#define ARG2_PTR 0x4
@@ -272,6 +274,58 @@ void ENTF90(SET_TYPE, set_type)(F90_Desc *dd, OBJECT_DESC *td)
}
}

/** \brief Check whether two polymorphic types are conformable.
*
* This routine is similar to the conformable routines in rdst.c, but
* it is for two polymorphic scalar objects instead of arrays.
*
* This is needed in polymorphic allocatable assignment. If two types
* are conformable or the type of the left hand side expression is large
* enough to hold the value(s) on the right hand side, then we do not have
* to reallocate the left hand side if it's already allocated.
*
* \param ab is the address of the first object.
* \param ab is the first object's descriptor.
* \param bd is the second object's descriptor.
* \param flag can be 0, 1, 2. See flag's description for poly_asn().
*
* \return 1 if types are conformable; 0 if types are not conformable but
* \param ab is big enough to hold \param bd; -1 if \param ab is not
* conformable, not big enough, or not allocated.
*/
int ENTF90(POLY_CONFORM_TYPES, poly_conform_types)(char *ab, F90_Desc *ad,
F90_Desc *bd, __INT_T flag)
{
/* Possible return values. Do not change the integer values */
typedef enum {
NOT_BIG_ENOUGH = -1, /* not conformable, not big enough */
BIG_ENOUGH = 0, /* not conformable but big enough */
CONFORMABLE = 1 /* conformable */
} CONFORM_TYPES;

OBJECT_DESC *src = (OBJECT_DESC *)bd;
OBJECT_DESC *dest = (OBJECT_DESC *)ad;
TYPE_DESC *src_td, *dest_td;
int src_sz, dest_sz;
int src_is_array = 0, dest_is_array = 0;

if (!I8(__fort_allocated)(ab)) {
return NOT_BIG_ENOUGH;
}

get_source_and_dest_sizes(ad, bd, &dest_sz, &src_sz, &dest_is_array,
&src_is_array, &dest_td, &src_td, flag);

if (dest_td != 0 && src_td != 0) {
if (dest_td == src_td && dest_sz == src_sz) {
return CONFORMABLE;
} else if (dest_sz >= src_sz) {
return BIG_ENOUGH;
}
}
return NOT_BIG_ENOUGH;
}

void ENTF90(TEST_AND_SET_TYPE, test_and_set_type)(F90_Desc *dd, OBJECT_DESC *td)
{
OBJECT_DESC *td2 = (OBJECT_DESC *)dd;
@@ -297,7 +351,7 @@ ENTF90(GET_OBJECT_SIZE, get_object_size)(F90_Desc *d)
return 0;

td = od->type;
return td ? td->obj.size : od->size;
return td && td != I8(__f03_ty_to_id)[__STR] ? td->obj.size : od->size;
}

__INT8_T
@@ -310,7 +364,8 @@ ENTF90(KGET_OBJECT_SIZE, kget_object_size)(F90_Desc *d)
return 0;

td = od->type;
return (__INT8_T)(td ? td->obj.size : od->size);
return (__INT8_T)(td && td != I8(__f03_ty_to_id)[__STR] ? td->obj.size :
od->size);
}

/** \brief Compute address of an element in a polymorphic array.
@@ -975,21 +1030,35 @@ sourced_alloc_and_assign_array_from_scalar(int extent, char *ab, char *bb,
}
}

void ENTF90(POLY_ASN, poly_asn)(char *ab, F90_Desc *ad, char *bb, F90_Desc *bd,
__INT_T flag)
/** \brief Computes destination/first object and source/second object sizes
* and other variables used by the poly_asn() and poly_conform_types()
* routines.
*
* \param ad is the destination/first descriptor in a polymorphic assignment
* or polymorphic type conformance test.
* \param bd is the source/second descriptor in a polymorphic assignment or
* polymorphic type conformance test.
* \param dest_sz is used to return the destination/first object's size.
* \param src_sz is used to return the source/second object's size.
* \param dest_is_array stores whether the destination/first object is an
* array.
* \param src_is_array stores whether the source/second object is an array.
* \param tad is used to return the destination/first object's type descriptor.
* \param tbd is used to return the source/second object's type descriptor.
* \param flag can be 0, 1, 2. See flag's description for poly_asn().
*/
static void
get_source_and_dest_sizes(F90_Desc *ad, F90_Desc *bd,
int *dest_sz, int *src_sz,
int *dest_is_array, int *src_is_array,
TYPE_DESC **tad, TYPE_DESC **tbd,
__INT_T flag)
{
/* Copy the contents of object bb to object ab
* Assumes destination descriptor, ad, is a full descriptor.
* If flag == 0, then source descriptor, bd, is a scalar "fake" descriptor
* If flag == 1, assume full descriptor for bd
* If flag == 2, assume full descriptor for bd and copy bd into ad.
*/

OBJECT_DESC *src = (OBJECT_DESC *)bd;
OBJECT_DESC *dest = (OBJECT_DESC *)ad;
TYPE_DESC *src_td, *dest_td;
int src_sz, dest_sz, sz;
int dest_is_array, src_is_array, i;

*dest_is_array = *src_is_array = 0;

if (dest) {
dest_td = dest->type ? dest->type : (TYPE_DESC *)ad;
@@ -1002,48 +1071,72 @@ void ENTF90(POLY_ASN, poly_asn)(char *ab, F90_Desc *ad, char *bb, F90_Desc *bd,
} else {
src_td = 0;
}
dest_is_array = src_is_array = 0;

if (src_td) {
if (bd && bd->tag == __DESC && bd->rank > 0) {
src_sz = bd->lsize * (size_t)src_td->obj.size;
src_is_array = 1;
*src_sz = bd->lsize * (size_t)src_td->obj.size;
*src_is_array = 1;
} else if (src_td->obj.baseTag == __STR) {
src_sz = (size_t)(ad->len * ad->lsize);
src_is_array = 1;
*src_sz = (size_t)(ad->len * ad->lsize);
*src_is_array = 1;
} else if (bd && (flag || bd->tag == __POLY || bd->tag == __DESC)) {
src_sz = (size_t)src_td->obj.size;
*src_sz = (size_t)src_td->obj.size;
} else {
src_sz = 0;
*src_sz = 0;
}
} else if (bd && !flag && ISSCALAR(bd) && bd->tag != __POLY &&
bd->tag < __NTYPES) {
#if defined(WINNT)
src_sz = __get_fort_size_of(bd->tag);
*src_sz = __get_fort_size_of(bd->tag);
#else
src_sz = __fort_size_of[bd->tag];
*src_sz = __fort_size_of[bd->tag];
#endif
} else {
src_sz = 0;
*src_sz = 0;
}

if (dest_td) {
if (ad && ad->tag == __DESC && ad->rank > 0) {
dest_sz = ad->lsize * (size_t)dest_td->obj.size;
dest_is_array = 1;
*dest_sz = ad->lsize * (size_t)dest_td->obj.size;
*dest_is_array = 1;
} else if (ad && ad->tag == __DESC && dest_td &&
dest_td->obj.tag == __POLY && ad->len > 0 && !ad->lsize &&
!ad->gsize && ad->kind > 0 && ad->kind < __NTYPES) {
dest_sz = (size_t)dest_td->obj.size * ad->len;
} else if (!src_sz || (ad && ad->tag == __DESC && dest_td &&
dest_td->obj.tag == __POLY)) {
dest_sz = (size_t)dest_td->obj.size;
*dest_sz = (size_t)dest_td->obj.size * ad->len;
} else if (!*src_sz || ((flag == 1 || (ad && ad->tag == __DESC)) &&
dest_td->obj.tag == __POLY)) {
*dest_sz = (size_t)dest_td->obj.size;
} else {
dest_sz = 0;
*dest_sz = 0;
}
} else {
dest_sz = 0;
*dest_sz = 0;
}

*tad = dest_td;
*tbd = src_td;

}

void ENTF90(POLY_ASN, poly_asn)(char *ab, F90_Desc *ad, char *bb, F90_Desc *bd,
__INT_T flag)
{
/* Copy the contents of object bb to object ab
* Assumes destination descriptor, ad, is a full descriptor.
* If flag == 0, then source descriptor, bd, is a scalar "fake" descriptor
* If flag == 1, assume full descriptor for bd
* If flag == 2, assume full descriptor for bd and copy bd into ad.
*/

OBJECT_DESC *src = (OBJECT_DESC *)bd;
OBJECT_DESC *dest = (OBJECT_DESC *)ad;
TYPE_DESC *src_td, *dest_td;
int src_sz, dest_sz, sz;
int dest_is_array, src_is_array, i;

get_source_and_dest_sizes(ad, bd, &dest_sz, &src_sz, &dest_is_array,
&src_is_array, &dest_td, &src_td, flag);

if (src_sz && src_td && src_td->obj.tag == __POLY &&
(!ad || ad->tag != __DESC || !dest_td || dest_td->obj.tag != __POLY))
sz = src_sz;
@@ -1063,7 +1156,7 @@ void ENTF90(POLY_ASN, poly_asn)(char *ab, F90_Desc *ad, char *bb, F90_Desc *bd,
for (i = 0; i < sz; i += src_sz) {
__fort_bcopy(ab + i, bb, src_sz);
}
} else {
} else {
__fort_bcopy(ab, bb, sz);
}

@@ -1083,11 +1176,11 @@ void ENTF90(POLY_ASN, poly_asn)(char *ab, F90_Desc *ad, char *bb, F90_Desc *bd,
if (flag) {
if (src_td && (src_td->obj.tag > 0 && src_td->obj.tag < __NTYPES) &&
!src_is_array && !dest_is_array) {
sourced_alloc_and_assign(ab, bb, src_td);
sourced_alloc_and_assign(ab, bb, src_td->obj.type);
} else if (dest_is_array && src_is_array) {
sourced_alloc_and_assign_array(ad->lsize, ab, bb, dest_td);
sourced_alloc_and_assign_array(ad->lsize, ab, bb, dest_td->obj.type);
} else if (dest_is_array) {
sourced_alloc_and_assign_array_from_scalar(ad->lsize, ab, bb, dest_td);
sourced_alloc_and_assign_array_from_scalar(ad->lsize, ab, bb, dest_td->obj.type);
}
}
}
@@ -2222,7 +2222,7 @@ set_type_in_descriptor(int descriptor_ast, int sptr, DTYPE dtype0,
type_ast = mk_unop(OP_VAL, mk_cval1(dtype_arg_ast, DT_INT), DT_INT);
}

if (type_ast > 0) {
if (type_ast > 0 && type_ast != descriptor_ast) {
int argt = mk_argt(2), astnew;
int func_ast = mk_id(sym_mkfunc_nodesc(mkRteRtnNm(func), DT_NONE));
ARGT_ARG(argt, 0) = descriptor_ast;
@@ -3000,7 +3000,8 @@ lower_stmt(int std, int ast, int lineno, int label)
case A_SUBSCR:
object = A_LOPG(src);
sptr = find_pointer_variable(object);
dtype = DTYPEG(sptr);
dtype = (src_dtype && CLASSG(sptr) && DTY(src_dtype) == TY_ARRAY) ?
src_dtype : DTYPEG(sptr);
if (DTY(dtype) == TY_ARRAY)
isarray = 1;
if (isarray && (!ADJARRG(sptr) || RESULTG(sptr))) {
@@ -4709,8 +4709,10 @@ propagate_byval_visit(int sptr)
void
lower_symbols(void)
{
int sptr;
SPTR sptr;
FILE *tfile;
bool is_interface;
SPTR scope;

if (OUTPUT_DWARF)
scan_for_dwarf_module();
@@ -4740,26 +4742,29 @@ lower_symbols(void)
lower_put_datatype_stb(BASETYPEG(sptr));
}
if (VISITG(sptr) && is_procedure_ptr(sptr)) {
/* FS#18789 - make sure we lower type and subtype of procedure ptr */
/* make sure we lower type and subtype of procedure ptr */
int dtype = DTYPEG(sptr);
lower_put_datatype_stb(dtype);
lower_put_datatype_stb(DTY(dtype + 1));
}
if (0 && VISITG(sptr) && STYPEG(sptr) == ST_TYPEDEF) {
int tag = DTY(DTYPEG(sptr) + 3);
if (VISITG(tag)) {
int sdsc = SDSCG(tag);
scope = SCOPEG(sptr);
is_interface = ((STYPEG(scope) == ST_PROC || STYPEG(scope) == ST_ENTRY) &&
IS_INTERFACEG(scope));

if (!is_interface && STYPEG(sptr) == ST_TYPEDEF) {
SPTR tag = DTY(DTYPEG(sptr) + 3);
if (!VISITG(tag)) {
SPTR sdsc = SDSCG(tag);
lower_put_datatype_stb(DTYPEG(tag));
lower_symbol_stb(tag);
VISITP(tag, 1);
if (sdsc && !VISITG(sdsc)) {
VISITP(sdsc, 1);
lower_put_datatype_stb(DTYPEG(sdsc));
}
}
} else if (!VISITG(sptr) && CLASSG(sptr) && DESCARRAYG(sptr) &&
STYPEG(sptr) == ST_DESCRIPTOR) {
SPTR scope = SCOPEG(sptr);
bool is_interface =
((STYPEG(scope) == ST_PROC || STYPEG(scope) == ST_ENTRY) &&
IS_INTERFACEG(scope));
if (PARENTG(sptr) && !is_interface) {
/* Only perform this if PARENT is set. Also do not create type
* descriptors for derived types defined inside interfaces. When
@@ -550,11 +550,8 @@ semant3(int rednum, SST *top)
} else {
sptr = SST_SYMG(RHS(2));
}
if (CLASSG(sptr) && !MONOMORPHICG(sptr)) {
error(155, 3, gbl.lineno,
"Left hand side of assignment"
" cannot be polymorphic -",
SYMNAME(sptr));
if (CLASSG(sptr) && !MONOMORPHICG(sptr) && !ALLOCATTRG(sptr)) {
error(1217, ERR_Severe, gbl.lineno, SYMNAME(sptr), CNULL);
}
chk_and_rewrite_cmplxpart_assn(RHS(2), RHS(5));

@@ -4091,7 +4088,7 @@ semant3(int rednum, SST *top)
*/

int new_sym, dty2, sz, dest_ast;
int flag_con = 1;
int flag_con = 2;
dty2 = dtype;
dest_ast = 0;
fidx = RTE_poly_asn;
@@ -1,5 +1,5 @@
/*
* Copyright (c) 1994-2018, NVIDIA CORPORATION. All rights reserved.
* Copyright (c) 1994-2019, NVIDIA CORPORATION. All rights reserved.
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
@@ -266,7 +266,7 @@ INT chk_scalar_inttyp(SST *, int, char *);
INT chk_arr_extent(SST *, char *);
INT chksubscr(SST *, int);
int casttyp(SST *, int);
void cngtyp(SST *, int);
void cngtyp(SST *, DTYPE);
void cngshape(SST *, SST *);
LOGICAL chkshape(SST *, SST *, LOGICAL);
int chklog(SST *);

0 comments on commit 922736b

Please sign in to comment.
You can’t perform that action at this time.