diff --git a/runtime/flang/rdst.c b/runtime/flang/rdst.c index 9c74dce320b..e66070ec770 100644 --- a/runtime/flang/rdst.c +++ b/runtime/flang/rdst.c @@ -2032,6 +2032,12 @@ init_unassociated_pointer_desc(F90_Desc *d) F90_DIM_LSTRIDE_P(d, 0, 0); } +void +ENTF90(INIT_DESC, init_desc)(F90_Desc *dd) +{ + init_unassociated_pointer_desc(dd); +} + /** \brief Copy argument if necessary * * when passing an array section to an assumed-shape dummy argument, diff --git a/test/f90_correct/inc/al09.mk b/test/f90_correct/inc/al09.mk new file mode 100644 index 00000000000..ac0ebcfb4ce --- /dev/null +++ b/test/f90_correct/inc/al09.mk @@ -0,0 +1,38 @@ +# +# Copyright (c) 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. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. +# + +########## Make rule for test al09 ######## + + +al09: run + + +build: $(SRC)/al09.f90 + -$(RM) al09.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/al09.f90 -o al09.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) al09.$(OBJX) check.$(OBJX) $(LIBS) -o al09.$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test al09 + al09.$(EXESUFFIX) + +verify: ; + +al09.run: run + diff --git a/test/f90_correct/inc/al10.mk b/test/f90_correct/inc/al10.mk new file mode 100644 index 00000000000..063d2bafdb0 --- /dev/null +++ b/test/f90_correct/inc/al10.mk @@ -0,0 +1,38 @@ +# +# Copyright (c) 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. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. +# + +########## Make rule for test al10 ######## + + +al10: run + + +build: $(SRC)/al10.f90 + -$(RM) al10.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/al10.f90 -o al10.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) al10.$(OBJX) check.$(OBJX) $(LIBS) -o al10.$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test al10 + al10.$(EXESUFFIX) + +verify: ; + +al10.run: run + diff --git a/test/f90_correct/lit/al09.sh b/test/f90_correct/lit/al09.sh new file mode 100644 index 00000000000..7cfd881c8d7 --- /dev/null +++ b/test/f90_correct/lit/al09.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 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. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/al10.sh b/test/f90_correct/lit/al10.sh new file mode 100644 index 00000000000..7cfd881c8d7 --- /dev/null +++ b/test/f90_correct/lit/al10.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 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. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/src/al09.f90 b/test/f90_correct/src/al09.f90 new file mode 100644 index 00000000000..eb0acf26498 --- /dev/null +++ b/test/f90_correct/src/al09.f90 @@ -0,0 +1,32 @@ +! Copyright (c) 1990-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. +! You may obtain a copy of the License at +! +! http://www.apache.org/licenses/LICENSE-2.0 +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. +! +! Test of issue #721 +! +logical :: failed=.FALSE. +character(:), allocatable :: a, b +a = 'foo' +call move_alloc(a, b) +if (allocated(a)) failed=.TRUE. +if (.not.allocated(b)) failed=.TRUE. +if (len(b) /= 3) failed=.TRUE. +if (b /= 'foo') failed=.TRUE. + +if (failed) then + call check(0,1,1) +else + call check(1,1,1) +end if + +end diff --git a/test/f90_correct/src/al10.f90 b/test/f90_correct/src/al10.f90 new file mode 100644 index 00000000000..1a8da5feb05 --- /dev/null +++ b/test/f90_correct/src/al10.f90 @@ -0,0 +1,43 @@ +! Copyright (c) 1990-2012, 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. +! You may obtain a copy of the License at +! +! http://www.apache.org/licenses/LICENSE-2.0 +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. +! +! Test of issue #720 +! +logical :: failed=.FALSE. +type, abstract :: json_value +end type + +type, extends(json_value) :: json_string + character(:), allocatable :: value +end type + +class(json_value), allocatable :: a + +allocate(a, source=json_string('foo')) ! <== SEG FAULT HERE + +select type(a) +type is (json_string) + if (len(a%value) /= 3) failed=.TRUE. + if (a%value /= 'foo') failed=.TRUE. +class default + failed=.TRUE. +end select + +if (failed) then + call check(0,1,1) +else + call check(1,1,1) +end if + +end diff --git a/tools/flang1/flang1exe/semant.h b/tools/flang1/flang1exe/semant.h index 07cd9d62048..5c240438dcb 100644 --- a/tools/flang1/flang1exe/semant.h +++ b/tools/flang1/flang1exe/semant.h @@ -1038,6 +1038,7 @@ VAR *gen_varref_var(int, DTYPE); void sem_fini(void); int gen_set_type(int dest_ast, int src_ast, int std, LOGICAL insert_before, LOGICAL intrin_type); +int mk_init_desc_call(int arg0); int mk_set_type_call(int arg0, int arg1, LOGICAL intrin_type); /* semant.c */ diff --git a/tools/flang1/flang1exe/semutil2.c b/tools/flang1/flang1exe/semutil2.c index 77a0339c007..a35784237e8 100644 --- a/tools/flang1/flang1exe/semutil2.c +++ b/tools/flang1/flang1exe/semutil2.c @@ -12574,6 +12574,7 @@ gen_automatic_reallocation(int lhs, int rhs, int std) int argt; int ifast, innerifast, binopast; int lhs_len, rhs_len; + int lhs_desc; /* generate * if( allocated(lhs ) then @@ -12583,6 +12584,7 @@ gen_automatic_reallocation(int lhs, int rhs, int std) * allocate(lhs) * ifend * else + * init_desc(lhs$desc) * lhs$len = rhs$len * allocate(lhs) * ifend @@ -12637,6 +12639,10 @@ gen_automatic_reallocation(int lhs, int rhs, int std) std = add_stmt_after(mk_stmt(A_ENDIF, 0), std); std = add_stmt_after(mk_stmt(A_ELSE, 0), std); + lhs_desc = find_descriptor_ast(memsym_of_ast(lhs), lhs); + ast = mk_init_desc_call(lhs_desc); + std = add_stmt_after(ast, std); + len_stmt = mk_assn_stmt(get_len_of_deferchar_ast(lhs), rhs_len, DT_INT); std = add_stmt_after(len_stmt, std); ast = mk_stmt(A_ALLOC, 0); @@ -12644,7 +12650,6 @@ gen_automatic_reallocation(int lhs, int rhs, int std) A_SRCP(ast, lhs); A_FIRSTALLOCP(ast, 1); std = add_stmt_after(ast, std); - add_stmt_after(mk_stmt(A_ENDIF, 0), std); check_and_add_auto_dealloc_from_ast(lhs); @@ -13800,6 +13805,21 @@ is_dealloc_std(int std) } } +int +mk_init_desc_call(int arg0) +{ + int newargt, func, astnew; + + newargt = mk_argt(1); + ARGT_ARG(newargt, 0) = arg0; + + func = mk_id(sym_mkfunc_nodesc( + mkRteRtnNm(RTE_init_desc), DT_NONE)); + astnew = mk_func_node(A_CALL, func, 1, newargt); + + return astnew; +} + /** \brief Creates an ast that represents a call to a set type runtime routine. * * \param arg0 is the ast of the descriptor that receives the type from arg1. diff --git a/tools/shared/rtlRtns.c b/tools/shared/rtlRtns.c index 27f3b2935b7..ce7a4a782bb 100644 --- a/tools/shared/rtlRtns.c +++ b/tools/shared/rtlRtns.c @@ -139,6 +139,7 @@ FtnRteRtn ftnRtlRtns[] = { {"ichar", "", false, "k"}, {"imodulov", "", false, ""}, {"indexa", "", false, "k"}, + {"init_desc", "", true, ""}, {"init_from_desc", "", true, ""}, {"init_unl_poly_desc", "", true, ""}, {"int", "", false, ""}, diff --git a/tools/shared/rtlRtns.h b/tools/shared/rtlRtns.h index fea3865aba3..a0988ce725c 100644 --- a/tools/shared/rtlRtns.h +++ b/tools/shared/rtlRtns.h @@ -144,6 +144,7 @@ typedef enum { RTE_ichar, RTE_imodulov, RTE_indexa, + RTE_init_desc, RTE_init_from_desc, RTE_init_unl_poly_desc, RTE_int,