Fix for issues 720 and 721

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,

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
+

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
+

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

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

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

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

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 */

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,14 +12639,17 @@ 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);
   A_TKNP(ast, TK_ALLOCATE);
   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.

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, ""},

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,