diff --git a/test/f90_correct/inc/bound1.mk b/test/f90_correct/inc/bound1.mk new file mode 100644 index 00000000000..84211b05071 --- /dev/null +++ b/test/f90_correct/inc/bound1.mk @@ -0,0 +1,19 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +$(TEST): run + +build: $(SRC)/$(TEST).f90 + -$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).f90 -o $(TEST).$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) $(TEST).$(OBJX) $(LIBS) -o $(TEST).$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test $(TEST) + $(TEST).$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/bound10.mk b/test/f90_correct/inc/bound10.mk new file mode 100644 index 00000000000..19c7f740659 --- /dev/null +++ b/test/f90_correct/inc/bound10.mk @@ -0,0 +1,14 @@ +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +build: $(SRC)/$(TEST).f90 + @echo ------------------------------------ building test $(TEST) + -$(FC) -c $(SRC)/$(TEST).f90 > $(TEST).rslt 2>&1 + +run: + @echo ------------------------------------ nothing to run for test $(TEST) + +verify: $(TEST).rslt + @echo ------------------------------------ verifying test $(TEST) + $(COMP_CHECK) $(SRC)/$(TEST).f90 $(TEST).rslt $(FC) diff --git a/test/f90_correct/inc/bound11.mk b/test/f90_correct/inc/bound11.mk new file mode 100644 index 00000000000..84211b05071 --- /dev/null +++ b/test/f90_correct/inc/bound11.mk @@ -0,0 +1,19 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +$(TEST): run + +build: $(SRC)/$(TEST).f90 + -$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).f90 -o $(TEST).$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) $(TEST).$(OBJX) $(LIBS) -o $(TEST).$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test $(TEST) + $(TEST).$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/bound12.mk b/test/f90_correct/inc/bound12.mk new file mode 100644 index 00000000000..84211b05071 --- /dev/null +++ b/test/f90_correct/inc/bound12.mk @@ -0,0 +1,19 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +$(TEST): run + +build: $(SRC)/$(TEST).f90 + -$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).f90 -o $(TEST).$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) $(TEST).$(OBJX) $(LIBS) -o $(TEST).$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test $(TEST) + $(TEST).$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/bound13.mk b/test/f90_correct/inc/bound13.mk new file mode 100644 index 00000000000..84211b05071 --- /dev/null +++ b/test/f90_correct/inc/bound13.mk @@ -0,0 +1,19 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +$(TEST): run + +build: $(SRC)/$(TEST).f90 + -$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).f90 -o $(TEST).$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) $(TEST).$(OBJX) $(LIBS) -o $(TEST).$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test $(TEST) + $(TEST).$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/bound14.mk b/test/f90_correct/inc/bound14.mk new file mode 100644 index 00000000000..b4334c98e74 --- /dev/null +++ b/test/f90_correct/inc/bound14.mk @@ -0,0 +1,19 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +$(TEST): run + +build: $(SRC)/$(TEST).F90 + -$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).F90 -o $(TEST).$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) $(TEST).$(OBJX) $(LIBS) -o $(TEST).$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test $(TEST) + $(TEST).$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/bound15.mk b/test/f90_correct/inc/bound15.mk new file mode 100644 index 00000000000..84211b05071 --- /dev/null +++ b/test/f90_correct/inc/bound15.mk @@ -0,0 +1,19 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +$(TEST): run + +build: $(SRC)/$(TEST).f90 + -$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).f90 -o $(TEST).$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) $(TEST).$(OBJX) $(LIBS) -o $(TEST).$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test $(TEST) + $(TEST).$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/bound16.mk b/test/f90_correct/inc/bound16.mk new file mode 100644 index 00000000000..84211b05071 --- /dev/null +++ b/test/f90_correct/inc/bound16.mk @@ -0,0 +1,19 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +$(TEST): run + +build: $(SRC)/$(TEST).f90 + -$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).f90 -o $(TEST).$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) $(TEST).$(OBJX) $(LIBS) -o $(TEST).$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test $(TEST) + $(TEST).$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/bound2.mk b/test/f90_correct/inc/bound2.mk new file mode 100644 index 00000000000..84211b05071 --- /dev/null +++ b/test/f90_correct/inc/bound2.mk @@ -0,0 +1,19 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +$(TEST): run + +build: $(SRC)/$(TEST).f90 + -$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).f90 -o $(TEST).$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) $(TEST).$(OBJX) $(LIBS) -o $(TEST).$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test $(TEST) + $(TEST).$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/bound3.mk b/test/f90_correct/inc/bound3.mk new file mode 100644 index 00000000000..84211b05071 --- /dev/null +++ b/test/f90_correct/inc/bound3.mk @@ -0,0 +1,19 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +$(TEST): run + +build: $(SRC)/$(TEST).f90 + -$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).f90 -o $(TEST).$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) $(TEST).$(OBJX) $(LIBS) -o $(TEST).$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test $(TEST) + $(TEST).$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/bound4.mk b/test/f90_correct/inc/bound4.mk new file mode 100644 index 00000000000..84211b05071 --- /dev/null +++ b/test/f90_correct/inc/bound4.mk @@ -0,0 +1,19 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +$(TEST): run + +build: $(SRC)/$(TEST).f90 + -$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).f90 -o $(TEST).$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) $(TEST).$(OBJX) $(LIBS) -o $(TEST).$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test $(TEST) + $(TEST).$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/bound5.mk b/test/f90_correct/inc/bound5.mk new file mode 100644 index 00000000000..f4ac81dd0e9 --- /dev/null +++ b/test/f90_correct/inc/bound5.mk @@ -0,0 +1,19 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +$(TEST): run + +build: $(SRC)/$(TEST).f90 + -$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(FC) -Hy,68,1 -My,68,1 -c $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).f90 -o $(TEST).$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) $(TEST).$(OBJX) $(LIBS) -o $(TEST).$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test $(TEST) + $(TEST).$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/bound6.mk b/test/f90_correct/inc/bound6.mk new file mode 100644 index 00000000000..84211b05071 --- /dev/null +++ b/test/f90_correct/inc/bound6.mk @@ -0,0 +1,19 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +$(TEST): run + +build: $(SRC)/$(TEST).f90 + -$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).f90 -o $(TEST).$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) $(TEST).$(OBJX) $(LIBS) -o $(TEST).$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test $(TEST) + $(TEST).$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/bound7.mk b/test/f90_correct/inc/bound7.mk new file mode 100644 index 00000000000..f4ac81dd0e9 --- /dev/null +++ b/test/f90_correct/inc/bound7.mk @@ -0,0 +1,19 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +$(TEST): run + +build: $(SRC)/$(TEST).f90 + -$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(FC) -Hy,68,1 -My,68,1 -c $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).f90 -o $(TEST).$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) $(TEST).$(OBJX) $(LIBS) -o $(TEST).$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test $(TEST) + $(TEST).$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/bound8.mk b/test/f90_correct/inc/bound8.mk new file mode 100644 index 00000000000..84211b05071 --- /dev/null +++ b/test/f90_correct/inc/bound8.mk @@ -0,0 +1,19 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +$(TEST): run + +build: $(SRC)/$(TEST).f90 + -$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).f90 -o $(TEST).$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) $(TEST).$(OBJX) $(LIBS) -o $(TEST).$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test $(TEST) + $(TEST).$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/bound9.mk b/test/f90_correct/inc/bound9.mk new file mode 100644 index 00000000000..19c7f740659 --- /dev/null +++ b/test/f90_correct/inc/bound9.mk @@ -0,0 +1,14 @@ +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +build: $(SRC)/$(TEST).f90 + @echo ------------------------------------ building test $(TEST) + -$(FC) -c $(SRC)/$(TEST).f90 > $(TEST).rslt 2>&1 + +run: + @echo ------------------------------------ nothing to run for test $(TEST) + +verify: $(TEST).rslt + @echo ------------------------------------ verifying test $(TEST) + $(COMP_CHECK) $(SRC)/$(TEST).f90 $(TEST).rslt $(FC) diff --git a/test/f90_correct/lit/bound1.sh b/test/f90_correct/lit/bound1.sh new file mode 100644 index 00000000000..3880a96ea63 --- /dev/null +++ b/test/f90_correct/lit/bound1.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# 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/bound10.sh b/test/f90_correct/lit/bound10.sh new file mode 100644 index 00000000000..3880a96ea63 --- /dev/null +++ b/test/f90_correct/lit/bound10.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# 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/bound11.sh b/test/f90_correct/lit/bound11.sh new file mode 100644 index 00000000000..3880a96ea63 --- /dev/null +++ b/test/f90_correct/lit/bound11.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# 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/bound12.sh b/test/f90_correct/lit/bound12.sh new file mode 100644 index 00000000000..3880a96ea63 --- /dev/null +++ b/test/f90_correct/lit/bound12.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# 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/bound13.sh b/test/f90_correct/lit/bound13.sh new file mode 100644 index 00000000000..3880a96ea63 --- /dev/null +++ b/test/f90_correct/lit/bound13.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# 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/bound14.sh b/test/f90_correct/lit/bound14.sh new file mode 100644 index 00000000000..3880a96ea63 --- /dev/null +++ b/test/f90_correct/lit/bound14.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# 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/bound15.sh b/test/f90_correct/lit/bound15.sh new file mode 100644 index 00000000000..3880a96ea63 --- /dev/null +++ b/test/f90_correct/lit/bound15.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# 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/bound16.sh b/test/f90_correct/lit/bound16.sh new file mode 100644 index 00000000000..3880a96ea63 --- /dev/null +++ b/test/f90_correct/lit/bound16.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# 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/bound2.sh b/test/f90_correct/lit/bound2.sh new file mode 100644 index 00000000000..3880a96ea63 --- /dev/null +++ b/test/f90_correct/lit/bound2.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# 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/bound3.sh b/test/f90_correct/lit/bound3.sh new file mode 100644 index 00000000000..3880a96ea63 --- /dev/null +++ b/test/f90_correct/lit/bound3.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# 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/bound4.sh b/test/f90_correct/lit/bound4.sh new file mode 100644 index 00000000000..3880a96ea63 --- /dev/null +++ b/test/f90_correct/lit/bound4.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# 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/bound5.sh b/test/f90_correct/lit/bound5.sh new file mode 100644 index 00000000000..3880a96ea63 --- /dev/null +++ b/test/f90_correct/lit/bound5.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# 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/bound6.sh b/test/f90_correct/lit/bound6.sh new file mode 100644 index 00000000000..3880a96ea63 --- /dev/null +++ b/test/f90_correct/lit/bound6.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# 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/bound7.sh b/test/f90_correct/lit/bound7.sh new file mode 100644 index 00000000000..3880a96ea63 --- /dev/null +++ b/test/f90_correct/lit/bound7.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# 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/bound8.sh b/test/f90_correct/lit/bound8.sh new file mode 100644 index 00000000000..3880a96ea63 --- /dev/null +++ b/test/f90_correct/lit/bound8.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# 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/bound9.sh b/test/f90_correct/lit/bound9.sh new file mode 100644 index 00000000000..3880a96ea63 --- /dev/null +++ b/test/f90_correct/lit/bound9.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# 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/bound1.f90 b/test/f90_correct/src/bound1.f90 new file mode 100644 index 00000000000..54e2649deea --- /dev/null +++ b/test/f90_correct/src/bound1.f90 @@ -0,0 +1,31 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Test for LBOUND and UBOUND in type specification. + +program test + implicit none + integer :: x(2,3,4) + integer, allocatable :: y(:) + integer :: i + + y = foo(x) + if (size(y) /= 24 .or. any(y /= 1)) STOP 1 + y = bar(x) + if (size(y) /= 3 .or. any(y /= 2)) STOP 2 + print *, "PASS" +contains + function foo(a) + integer :: a(:, :, :) + integer :: foo(1:product(ubound(a))) + foo = 1 + end function + + function bar(a) + integer :: a(:, :, :) + integer :: bar(1:sum(lbound(a))) + bar = 2 + end function +end program diff --git a/test/f90_correct/src/bound10.f90 b/test/f90_correct/src/bound10.f90 new file mode 100644 index 00000000000..5c75cefda76 --- /dev/null +++ b/test/f90_correct/src/bound10.f90 @@ -0,0 +1,22 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Test for restrictions about LBOUND and UBOUND. + +program test + implicit none + integer, allocatable :: x(:, :, :) + + allocate(x(2, 3, 4)) +contains + subroutine test_assumed_size(a) + integer :: a(4:7, 9:*) + !{error "PGF90-S-0084-Illegal use of symbol a - ubound of assumed size array is unknown"} + print *, ubound(a) + !{error "PGF90-S-0084-Illegal use of symbol a - ubound of assumed size array is unknown"} + print *, ubound(a, 2) + end subroutine +end program + diff --git a/test/f90_correct/src/bound11.f90 b/test/f90_correct/src/bound11.f90 new file mode 100644 index 00000000000..6c5f783a3c1 --- /dev/null +++ b/test/f90_correct/src/bound11.f90 @@ -0,0 +1,69 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Test for LBOUND and UBOUND of assumed-shape formal in type specification. + +program test + implicit none + integer :: x(2,3,4) + integer, allocatable :: x_alloc(:, :, :) + integer, pointer :: x_ptr(:, :, :) + integer, allocatable :: arr_res(:) + character(len=:), allocatable :: char_res + integer :: i + + allocate(x_alloc(2:3, 3:5, 4:7)) + allocate(x_ptr(2:3, 3:5, 4:7)) + + arr_res = array_test_specified_lb(1, 0, -1, x) + if (size(arr_res) /= 8 .or. any(arr_res /= 1)) STOP 1 + arr_res = array_test_specified_lb(2, 1, 0, x(2:, 3:, 2:)) + if (size(arr_res) /= 4 .or. any(arr_res /= 1)) STOP 2 + arr_res = array_test_missing_lb(x_alloc) + if (size(arr_res) /= 3 .or. any(arr_res /= 2)) STOP 3 + arr_res = array_test_specified_lb(1, 0, -1, x_alloc) + if (size(arr_res) /= 8 .or. any(arr_res /= 1)) STOP 4 + arr_res = array_test_missing_lb(x_ptr) + if (size(arr_res) /= 3 .or. any(arr_res /= 2)) STOP 5 + + char_res = char_test_specified_lb(1, 0, -1, x) + if (len(char_res) /= 8 .or. char_res /= 'aaaaaaaa') STOP 6 + char_res = char_test_specified_lb(2, 1, 0, x(2:, 3:, 2:)) + if (len(char_res) /= 4 .or. char_res /= 'aaaa') STOP 7 + char_res = char_test_missing_lb(x_alloc) + if (len(char_res) /= 3 .or. char_res /= 'bbb') STOP 8 + char_res = char_test_specified_lb(1, 0, -1, x_alloc) + if (len(char_res) /= 8 .or. char_res /= 'aaaaaaaa') STOP 9 + char_res = char_test_missing_lb(x_ptr) + if (len(char_res) /= 3 .or. char_res /= 'bbb') STOP 10 + + print *, "PASS" +contains + function array_test_specified_lb(l1, l2, l3, a) result(res) + integer :: l1, l2, l3 + integer :: a(l1:, l2:, l3:) + integer :: res(1:product(ubound(a))) + res = 1 + end function + + function array_test_missing_lb(a) result(res) + integer :: a(:, :, :) + integer :: res(1:sum(lbound(a))) + res = 2 + end function + + function char_test_specified_lb(l1, l2, l3, a) result(res) + integer :: l1, l2, l3 + integer :: a(l1:, l2:, l3:) + character(len=product(ubound(a))) :: res + res = repeat('a', product(ubound(a))) + end function + + function char_test_missing_lb(a) result(res) + integer :: a(:, :, :) + character(len=sum(lbound(a))) :: res + res = repeat('b', sum(lbound(a))) + end function +end program diff --git a/test/f90_correct/src/bound12.f90 b/test/f90_correct/src/bound12.f90 new file mode 100644 index 00000000000..4bc1cb1ea1c --- /dev/null +++ b/test/f90_correct/src/bound12.f90 @@ -0,0 +1,81 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Test for LBOUND and UBOUND of assumed-shape formal in type specification when +! DIM is present. + +program test + implicit none + integer :: x(2,3,4) + integer, allocatable :: x_alloc(:, :, :) + integer, pointer :: x_ptr(:, :, :) + integer, allocatable :: arr_res(:) + character(len=:), allocatable :: char_res + integer :: i + + allocate(x_alloc(2:3, 3:5, 4:7)) + allocate(x_ptr(2:3, 3:5, 4:7)) + + arr_res = array_test_specified_lb(1, 0, -1, x) + if (size(arr_res) /= 8 .or. any(arr_res /= 1)) STOP 1 + arr_res = array_test_specified_lb(2, 1, 0, x(2:, 3:, 2:)) + if (size(arr_res) /= 4 .or. any(arr_res /= 1)) STOP 2 + arr_res = array_test_missing_lb(x_alloc) + if (size(arr_res) /= 3 .or. any(arr_res /= 2)) STOP 3 + arr_res = array_test_specified_lb(1, 0, -1, x_alloc) + if (size(arr_res) /= 8 .or. any(arr_res /= 1)) STOP 4 + arr_res = array_test_missing_lb(x_ptr) + if (size(arr_res) /= 3 .or. any(arr_res /= 2)) STOP 5 + + char_res = char_test_specified_lb(1, 0, -1, x) + if (len(char_res) /= 8 .or. char_res /= 'aaaaaaaa') STOP 6 + char_res = char_test_specified_lb(2, 1, 0, x(2:, 3:, 2:)) + if (len(char_res) /= 4 .or. char_res /= 'aaaa') STOP 7 + char_res = char_test_missing_lb(x_alloc) + if (len(char_res) /= 3 .or. char_res /= 'bbb') STOP 8 + char_res = char_test_specified_lb(1, 0, -1, x_alloc) + if (len(char_res) /= 8 .or. char_res /= 'aaaaaaaa') STOP 9 + char_res = char_test_missing_lb(x_ptr) + if (len(char_res) /= 3 .or. char_res /= 'bbb') STOP 10 + + arr_res = test_noncnst_dim(1, 0, -1, x, 1, 2, 3) + if (size(arr_res) /= 8 .or. any(arr_res /= 1)) STOP 11 + + print *, "PASS" +contains + function array_test_specified_lb(l1, l2, l3, a) result(res) + integer :: l1, l2, l3 + integer :: a(l1:, l2:, l3:) + integer :: res(1:ubound(a, 1) * ubound(a, 2) * ubound(a, 3)) + res = 1 + end function + + function array_test_missing_lb(a) result(res) + integer :: a(:, :, :) + integer :: res(1:lbound(a, 1) + lbound(a, 2) + lbound(a, 3)) + res = 2 + end function + + function char_test_specified_lb(l1, l2, l3, a) result(res) + integer :: l1, l2, l3 + integer :: a(l1:, l2:, l3:) + character(len=ubound(a, 1) * ubound(a, 2) * ubound(a, 3)) :: res + res = repeat('a', ubound(a, 1) * ubound(a, 2) * ubound(a, 3)) + end function + + function char_test_missing_lb(a) result(res) + integer :: a(:, :, :) + character(len=lbound(a, 1) + lbound(a, 2) + lbound(a, 3)) :: res + res = repeat('b', lbound(a, 1) + lbound(a, 2) + lbound(a, 3)) + end function + + function test_noncnst_dim(l1, l2, l3, a, d1, d2, d3) result(res) + integer :: l1, l2, l3 + integer :: a(l1:, l2:, l3:) + integer :: d1, d2, d3 + integer :: res(1:ubound(a, d1) * ubound(a, d2) * ubound(a, d3)) + res = 1 + end function +end program diff --git a/test/f90_correct/src/bound13.f90 b/test/f90_correct/src/bound13.f90 new file mode 100644 index 00000000000..c96225144ad --- /dev/null +++ b/test/f90_correct/src/bound13.f90 @@ -0,0 +1,51 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Test for LBOUND and UBOUND of assumed-shape formal in type specification. + +program test + implicit none + integer :: x(2,3,4) + integer, allocatable :: y(:) + type t + integer, allocatable :: arr(:) + end type + type(t) :: z(8) + integer :: i + + y = test_binary_expr(3, 4, 5, x) + if (size(y) /= 910 .or. any(y /= 1)) STOP 1 + y = test_unary_expr(1, 2, 3, x) + if (size(y) /= 288 .or. any(y /= 2)) STOP 2 + + do i = 1, 8 + z(i)%arr = i * [1, 2, 3, 4, 5, 6, 7, 8, 9] + enddo + y = test_subscript_expr(1, 2, -2, x, z) + if (size(y) /= 8 .or. any(y /= 3)) STOP 3 + print *, "PASS" +contains + function test_binary_expr(l1, l2, l3, a) result(res) + integer :: l1, l2, l3 + integer :: a(l1:, l2:, l3:) + integer :: res(1:product(ubound(a) + lbound(a))) + res = 1 + end function + + function test_unary_expr(l1, l2, l3, a) result(res) + integer :: l1, l2, l3 + integer :: a(l1:, l2:, l3:) + integer :: res(1:product(-ubound(a)) * sum(-lbound(a))) + res = 2 + end function + + function test_subscript_expr(l1, l2, l3, a, b) result(res) + integer :: l1, l2, l3 + integer :: a(l1:, l2:, l3:) + type(t) :: b(:) + integer :: res(1: b(product(ubound(a)))%arr(sum(lbound(a)))) + res = 3 + end function +end program diff --git a/test/f90_correct/src/bound14.F90 b/test/f90_correct/src/bound14.F90 new file mode 100644 index 00000000000..7812061e9bf --- /dev/null +++ b/test/f90_correct/src/bound14.F90 @@ -0,0 +1,29 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Test for LBOUND and UBOUND in data initialization when DIM is present. + +program test + use iso_fortran_env + implicit none + + integer, parameter :: sp1 = real_kinds(lbound(real_kinds,dim=1)) + integer, parameter :: dp1 = real_kinds(lbound(real_kinds,dim=1)+1) +#ifdef __flang_quadfp__ + integer, parameter :: qp1 = real_kinds(lbound(real_kinds,dim=1)+2) +#endif + integer, parameter :: sp2 = real_kinds(ubound(real_kinds,dim=1)-2) + integer, parameter :: dp2 = real_kinds(ubound(real_kinds,dim=1)-1) +#ifdef __flang_quadfp__ + integer, parameter :: qp2 = real_kinds(ubound(real_kinds,dim=1)) +#endif + + if (sp1 /= 4 .or. sp2 /= 4) STOP 1 + if (dp1 /= 8 .or. dp2 /= 8) STOP 2 +#ifdef __flang_quadfp__ + if (qp1 /= 16 .or. qp2 /= 16) STOP 3 +#endif + print *, "PASS" +end program diff --git a/test/f90_correct/src/bound15.f90 b/test/f90_correct/src/bound15.f90 new file mode 100644 index 00000000000..998381f6af3 --- /dev/null +++ b/test/f90_correct/src/bound15.f90 @@ -0,0 +1,25 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Test the fix for the LBOUND/UBOUND regression, where the subscript expression +! as the ARRAY argument has a scalar index in some dimension. + +program test + implicit none + integer :: arr1(2:4, 3:8) + integer, pointer :: arr2(:, :, :) + integer, allocatable :: res(:) + + res = ubound(arr1(3, 4:7)) + if (size(res) /= 1 .or. res(1) /= 4) STOP 1 + res = lbound(arr1(3, 4:7)) + if (size(res) /= 1 .or. res(1) /= 1) STOP 2 + allocate(arr2(2:4, 3:8, 4:10)) + res = ubound(arr2(3, 4:7, 5)) + if (size(res) /= 1 .or. res(1) /= 4) STOP 3 + res = lbound(arr2(3, 4:7, 5)) + if (size(res) /= 1 .or. res(1) /= 1) STOP 4 + print *, "PASS" +end program diff --git a/test/f90_correct/src/bound16.f90 b/test/f90_correct/src/bound16.f90 new file mode 100644 index 00000000000..3284e442912 --- /dev/null +++ b/test/f90_correct/src/bound16.f90 @@ -0,0 +1,71 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Test the fix for the LBOUND/UBOUND regression, where the LBOUND/UBOUND call +! nested within the SIZE call has a defer-shape ARRAY parameter and a DIM +! parameter. + +module m + implicit none + type t1 + character, pointer :: arr1(:) + end type + type t2 + type(t1), pointer :: arr2(:) + integer, pointer :: arr3(:) + end type +contains + function test_default(a) result(ret) + type(t2) :: a + character(len=size(a%arr2(ubound(a%arr3, 1))%arr1)) :: ret + ret = repeat('a', len(ret)) + end function + + function test_kind1(a) result(ret) + type(t2) :: a + character(len=size(a%arr2(ubound(a%arr3, 1, kind=1))%arr1)) :: ret + ret = repeat('b', len(ret)) + end function + + function test_kind2(a) result(ret) + type(t2) :: a + character(len=size(a%arr2(ubound(a%arr3, 1, kind=2))%arr1)) :: ret + ret = repeat('c', len(ret)) + end function + + function test_kind4(a) result(ret) + type(t2) :: a + character(len=size(a%arr2(ubound(a%arr3, 1, kind=4))%arr1)) :: ret + ret = repeat('d', len(ret)) + end function + + function test_kind8(a) result(ret) + type(t2) :: a + character(len=size(a%arr2(ubound(a%arr3, 1, kind=8))%arr1)) :: ret + ret = repeat('e', len(ret)) + end function +end module + +program test + use m + implicit none + type(t2) :: x + character(len=:), allocatable :: y + + allocate(x%arr2(5)) + allocate(x%arr3(2:4)) + allocate(x%arr2(4)%arr1(2:10)) + y = test_default(x) + if (len(y) /= 9 .or. y /= 'aaaaaaaaa') STOP 1 + y = test_kind1(x) + if (len(y) /= 9 .or. y /= 'bbbbbbbbb') STOP 2 + y = test_kind2(x) + if (len(y) /= 9 .or. y /= 'ccccccccc') STOP 3 + y = test_kind4(x) + if (len(y) /= 9 .or. y /= 'ddddddddd') STOP 4 + y = test_kind8(x) + if (len(y) /= 9 .or. y /= 'eeeeeeeee') STOP 5 + print *, "PASS" +end program diff --git a/test/f90_correct/src/bound2.f90 b/test/f90_correct/src/bound2.f90 new file mode 100644 index 00000000000..ee8eb91c7e7 --- /dev/null +++ b/test/f90_correct/src/bound2.f90 @@ -0,0 +1,19 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Test for LBOUND and UBOUND when the array is assumed-rank. + +program test + implicit none + integer :: x(2,3,4) + call test_assumed_rank(x) + print *, "PASS" +contains + subroutine test_assumed_rank(a) + integer :: a(..) + if (size(lbound(a)) /= 3 .or. any(lbound(a) /= 1)) STOP 1 + if (size(ubound(a)) /= 3 .or. any(ubound(a) /= [2, 3, 4])) STOP 2 + end subroutine +end program diff --git a/test/f90_correct/src/bound3.f90 b/test/f90_correct/src/bound3.f90 new file mode 100644 index 00000000000..c1efde79d54 --- /dev/null +++ b/test/f90_correct/src/bound3.f90 @@ -0,0 +1,20 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Test for LBOUND and UBOUND when the array is assumed-size. + +program test + implicit none + integer :: x(2,3,4) + call test_assumed_size(x) + print *, "PASS" +contains + subroutine test_assumed_size(a) + integer :: a(2:5, 4:*) + if (size(lbound(a)) /= 2 .or. any(lbound(a) /= [2, 4])) STOP 1 + if (any([lbound(a, 1), lbound(a, 2)] /= [2, 4])) STOP 2 + if (ubound(a, 1) /= 5) STOP 3 + end subroutine +end program diff --git a/test/f90_correct/src/bound4.f90 b/test/f90_correct/src/bound4.f90 new file mode 100644 index 00000000000..bf6b4d3417b --- /dev/null +++ b/test/f90_correct/src/bound4.f90 @@ -0,0 +1,78 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Test for LBOUND and UBOUND when the array is deferred-shape. + +program test + implicit none + integer, allocatable :: x(:, :, :, :) + integer, pointer :: y(:, :, :, :) + integer :: i + integer :: n + integer, parameter :: default_kind = kind(i) + + n = 2 + x = reshape([(i, i=1,120)], [2, 3, 4, 5]) + allocate(y(1:2, 2:4, 3:6, 4:8)) + + call test_dim_present(x, y) + call test_dim_missing(x, y) + call test_component() + print *, "PASS" +contains + subroutine test_dim_present(a, b) + integer, allocatable :: a(:, :, :, :) + integer, pointer :: b(:, :, :, :) + if (kind(ubound(a, 1)) /= default_kind .or. ubound(a, 1) /= 2) STOP 1 + if (kind(ubound(a, 1, 1)) /= 1 .or. ubound(a, 1, 1) /= 2) STOP 2 + if (kind(ubound(a, n, 2)) /= 2 .or. ubound(a, n, 2) /= 3) STOP 3 + if (kind(ubound(a, n+1, 4)) /= 4 .or. ubound(a, n+1, 4) /= 4) STOP 4 + if (kind(ubound(a, 4, 8)) /= 8 .or. ubound(a, 4, 8) /= 5) STOP 5 + if (kind(lbound(b, 1)) /= default_kind .or. lbound(b, 1) /= 1) STOP 6 + if (kind(lbound(b, 1, 1)) /= 1 .or. lbound(b, 1, 1) /= 1) STOP 7 + if (kind(lbound(b, n, 2)) /= 2 .or. lbound(b, n, 2) /= 2) STOP 8 + if (kind(lbound(b, n+1, 4)) /= 4 .or. lbound(b, n+1, 4) /= 3) STOP 9 + if (kind(lbound(b, 4, 8)) /= 8 .or. lbound(b, 4, 8) /= 4) STOP 10 + end subroutine + + subroutine test_dim_missing (a, b) + integer, allocatable :: a(:, :, :, :) + integer, pointer :: b(:, :, :, :) + if (kind(ubound(a)) /= default_kind .or. size(ubound(a)) /= 4 .or. & + any(ubound(a) /= [2, 3, 4, 5])) STOP 11 + if (kind(ubound(a, kind=1)) /= 1 .or. size(ubound(a, kind=1)) /= 4 .or. & + any(ubound(a, kind=1) /= [2, 3, 4, 5])) STOP 12 + if (kind(ubound(a, kind=2)) /= 2 .or. size(ubound(a, kind=2)) /= 4 .or. & + any(ubound(a, kind=2) /= [2, 3, 4, 5])) STOP 13 + if (kind(ubound(a, kind=4)) /= 4 .or. size(ubound(a, kind=4)) /= 4 .or. & + any(ubound(a, kind=4) /= [2, 3, 4, 5])) STOP 14 + if (kind(ubound(a, kind=8)) /= 8 .or. size(ubound(a, kind=8)) /= 4 .or. & + any(ubound(a, kind=8) /= [2, 3, 4, 5])) STOP 15 + if (kind(lbound(b)) /= default_kind .or. size(lbound(b)) /= 4 .or. & + any(lbound(b) /= [1, 2, 3, 4])) STOP 16 + if (kind(lbound(b, kind=1)) /= 1 .or. size(lbound(b, kind=1)) /= 4 .or. & + any(lbound(b, kind=1) /= [1, 2, 3, 4])) STOP 17 + if (kind(lbound(b, kind=2)) /= 2 .or. size(lbound(b, kind=2)) /= 4 .or. & + any(lbound(b, kind=2) /= [1, 2, 3, 4])) STOP 18 + if (kind(lbound(b, kind=4)) /= 4 .or. size(lbound(b, kind=4)) /= 4 .or. & + any(lbound(b, kind=4) /= [1, 2, 3, 4])) STOP 19 + if (kind(lbound(b, kind=8)) /= 8 .or. size(lbound(b, kind=8)) /= 4 .or. & + any(lbound(b, kind=8) /= [1, 2, 3, 4])) STOP 20 + end subroutine + + subroutine test_component() + type t + integer, allocatable :: x(:, :, :, :) + integer, pointer :: y(:, :, :, :) + end type + type(t) :: a + a%x = reshape([(i, i=1,120)], [2, 3, 4, 5]) + allocate(a%y(1:2, 2:4, 3:6, 4:8)) + if (any(lbound(a%x) /= 1)) STOP 21 + if (any(ubound(a%x) /= [2, 3, 4, 5])) STOP 22 + if (any(lbound(a%y) /= [1, 2, 3, 4])) STOP 23 + if (any(ubound(a%y) /= [2, 4, 6, 8])) STOP 24 + end subroutine +end program diff --git a/test/f90_correct/src/bound5.f90 b/test/f90_correct/src/bound5.f90 new file mode 100644 index 00000000000..8f4940f65c0 --- /dev/null +++ b/test/f90_correct/src/bound5.f90 @@ -0,0 +1,79 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Test for LBOUND and UBOUND when the array is deferred-shape. +! The options -Hy,68,1 and -My,68,1 are required. + +program test + implicit none + integer, allocatable :: x(:, :, :, :) + integer, pointer :: y(:, :, :, :) + integer :: i + integer :: n + integer, parameter :: default_kind = kind(i) + + n = 2 + x = reshape([(i, i=1,120)], [2, 3, 4, 5]) + allocate(y(1:2, 2:4, 3:6, 4:8)) + + call test_dim_present(x, y) + call test_dim_missing(x, y) + call test_component() + print *, "PASS" +contains + subroutine test_dim_present(a, b) + integer, allocatable :: a(:, :, :, :) + integer, pointer :: b(:, :, :, :) + if (kind(ubound(a, 1)) /= default_kind .or. ubound(a, 1) /= 2) STOP 1 + if (kind(ubound(a, 1, 1)) /= 1 .or. ubound(a, 1, 1) /= 2) STOP 2 + if (kind(ubound(a, n, 2)) /= 2 .or. ubound(a, n, 2) /= 3) STOP 3 + if (kind(ubound(a, n+1, 4)) /= 4 .or. ubound(a, n+1, 4) /= 4) STOP 4 + if (kind(ubound(a, 4, 8)) /= 8 .or. ubound(a, 4, 8) /= 5) STOP 5 + if (kind(lbound(b, 1)) /= default_kind .or. lbound(b, 1) /= 1) STOP 6 + if (kind(lbound(b, 1, 1)) /= 1 .or. lbound(b, 1, 1) /= 1) STOP 7 + if (kind(lbound(b, n, 2)) /= 2 .or. lbound(b, n, 2) /= 2) STOP 8 + if (kind(lbound(b, n+1, 4)) /= 4 .or. lbound(b, n+1, 4) /= 3) STOP 9 + if (kind(lbound(b, 4, 8)) /= 8 .or. lbound(b, 4, 8) /= 4) STOP 10 + end subroutine + + subroutine test_dim_missing (a, b) + integer, allocatable :: a(:, :, :, :) + integer, pointer :: b(:, :, :, :) + if (kind(ubound(a)) /= default_kind .or. size(ubound(a)) /= 4 .or. & + any(ubound(a) /= [2, 3, 4, 5])) STOP 11 + if (kind(ubound(a, kind=1)) /= 1 .or. size(ubound(a, kind=1)) /= 4 .or. & + any(ubound(a, kind=1) /= [2, 3, 4, 5])) STOP 12 + if (kind(ubound(a, kind=2)) /= 2 .or. size(ubound(a, kind=2)) /= 4 .or. & + any(ubound(a, kind=2) /= [2, 3, 4, 5])) STOP 13 + if (kind(ubound(a, kind=4)) /= 4 .or. size(ubound(a, kind=4)) /= 4 .or. & + any(ubound(a, kind=4) /= [2, 3, 4, 5])) STOP 14 + if (kind(ubound(a, kind=8)) /= 8 .or. size(ubound(a, kind=8)) /= 4 .or. & + any(ubound(a, kind=8) /= [2, 3, 4, 5])) STOP 15 + if (kind(lbound(b)) /= default_kind .or. size(lbound(b)) /= 4 .or. & + any(lbound(b) /= [1, 2, 3, 4])) STOP 16 + if (kind(lbound(b, kind=1)) /= 1 .or. size(lbound(b, kind=1)) /= 4 .or. & + any(lbound(b, kind=1) /= [1, 2, 3, 4])) STOP 17 + if (kind(lbound(b, kind=2)) /= 2 .or. size(lbound(b, kind=2)) /= 4 .or. & + any(lbound(b, kind=2) /= [1, 2, 3, 4])) STOP 18 + if (kind(lbound(b, kind=4)) /= 4 .or. size(lbound(b, kind=4)) /= 4 .or. & + any(lbound(b, kind=4) /= [1, 2, 3, 4])) STOP 19 + if (kind(lbound(b, kind=8)) /= 8 .or. size(lbound(b, kind=8)) /= 4 .or. & + any(lbound(b, kind=8) /= [1, 2, 3, 4])) STOP 20 + end subroutine + + subroutine test_component() + type t + integer, allocatable :: x(:, :, :, :) + integer, pointer :: y(:, :, :, :) + end type + type(t) :: a + a%x = reshape([(i, i=1,120)], [2, 3, 4, 5]) + allocate(a%y(1:2, 2:4, 3:6, 4:8)) + if (any(lbound(a%x) /= 1)) STOP 21 + if (any(ubound(a%x) /= [2, 3, 4, 5])) STOP 22 + if (any(lbound(a%y) /= [1, 2, 3, 4])) STOP 23 + if (any(ubound(a%y) /= [2, 4, 6, 8])) STOP 24 + end subroutine +end program diff --git a/test/f90_correct/src/bound6.f90 b/test/f90_correct/src/bound6.f90 new file mode 100644 index 00000000000..0a7b8584ea7 --- /dev/null +++ b/test/f90_correct/src/bound6.f90 @@ -0,0 +1,140 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Test for LBOUND and UBOUND when the array is assumed-shape. + +program test + implicit none + integer, allocatable :: x(:, :, :, :) + integer, parameter :: default_kind = kind(x) + + allocate(x(1:2, 2:4, 3:6, 4:8)) + call test_assumed_shape(x) + call test_assumed_shape_with_lower_bound(1, 3, 2, 4, x) + print *, "PASS" +contains + subroutine test_assumed_shape(a) + integer :: a(:, :, :, :) + integer :: l_exp(4), u_exp(4), i + + l_exp = [1, 1, 1, 1] + u_exp = [2, 3, 4, 5] + ! DIM is constant + if (any([lbound(a, 1), lbound(a, 2), lbound(a, 3), lbound(a, 4)] /= & + l_exp)) STOP 1 + if (any([ubound(a, 1), ubound(a, 2), ubound(a, 3), ubound(a, 4)] /= & + u_exp)) STOP 2 + + ! DIM is variable + do i = 1, 4 + if (kind(lbound(a, i)) /= default_kind .or. lbound(a, i) /= & + l_exp(i)) STOP 3 + if (kind(lbound(a, i, kind=1)) /= 1 .or. lbound(a, i, kind=1) /= & + l_exp(i)) STOP 4 + if (kind(lbound(a, i, kind=2)) /= 2 .or. lbound(a, i, kind=2) /= & + l_exp(i)) STOP 5 + if (kind(lbound(a, i, kind=4)) /= 4 .or. lbound(a, i, kind=4) /= & + l_exp(i)) STOP 6 + if (kind(lbound(a, i, kind=8)) /= 8 .or. lbound(a, i, kind=8) /= & + l_exp(i)) STOP 7 + + if (kind(ubound(a, i)) /= default_kind .or. ubound(a, i) /= & + u_exp(i)) STOP 9 + if (kind(ubound(a, i, kind=1)) /= 1 .or. ubound(a, i, kind=1) /= & + u_exp(i)) STOP 10 + if (kind(ubound(a, i, kind=2)) /= 2 .or. ubound(a, i, kind=2) /= & + u_exp(i)) STOP 11 + if (kind(ubound(a, i, kind=4)) /= 4 .or. ubound(a, i, kind=4) /= & + u_exp(i)) STOP 12 + if (kind(ubound(a, i, kind=8)) /= 8 .or. ubound(a, i, kind=8) /= & + u_exp(i)) STOP 13 + enddo + + ! DIM is missing + if (kind(lbound(a)) /= default_kind .or. size(lbound(a)) /= 4 .or. & + any(lbound(a) /= l_exp)) STOP 15 + if (kind(lbound(a, kind=1)) /= 1 .or. size(lbound(a, kind=1)) /= 4 .or. & + any(lbound(a, kind=1) /= l_exp)) STOP 16 + if (kind(lbound(a, kind=2)) /= 2 .or. size(lbound(a, kind=2)) /= 4 .or. & + any(lbound(a, kind=2) /= l_exp)) STOP 17 + if (kind(lbound(a, kind=4)) /= 4 .or. size(lbound(a, kind=4)) /= 4 .or. & + any(lbound(a, kind=4) /= l_exp)) STOP 18 + if (kind(lbound(a, kind=8)) /= 8 .or. size(lbound(a, kind=8)) /= 4 .or. & + any(lbound(a, kind=8) /= l_exp)) STOP 19 + + if (kind(ubound(a)) /= default_kind .or. size(ubound(a)) /= 4 .or. & + any(ubound(a) /= u_exp)) STOP 21 + if (kind(ubound(a, kind=1)) /= 1 .or. size(ubound(a, kind=1)) /= 4 .or. & + any(ubound(a, kind=1) /= u_exp)) STOP 22 + if (kind(ubound(a, kind=2)) /= 2 .or. size(ubound(a, kind=2)) /= 4 .or. & + any(ubound(a, kind=2) /= u_exp)) STOP 23 + if (kind(ubound(a, kind=4)) /= 4 .or. size(ubound(a, kind=4)) /= 4 .or. & + any(ubound(a, kind=4) /= u_exp)) STOP 24 + if (kind(ubound(a, kind=8)) /= 8 .or. size(ubound(a, kind=8)) /= 4 .or. & + any(ubound(a, kind=8) /= u_exp)) STOP 25 + end subroutine test_assumed_shape + + subroutine test_assumed_shape_with_lower_bound(l1, l2, l3, l4, a) + integer :: l1, l2, l3, l4 + integer :: a(l1:, l2:, l3:, l4:) + integer :: l_exp(4), u_exp(4), i + + l_exp = [l1, l2, l3, l4] + u_exp = [l1 + 1, l2 + 2, l3 + 3, l4 + 4] + ! DIM is constant + if (any([lbound(a, 1), lbound(a, 2), lbound(a, 3), lbound(a, 4)] /= & + l_exp)) STOP 27 + if (any([ubound(a, 1), ubound(a, 2), ubound(a, 3), ubound(a, 4)] /= & + u_exp)) STOP 28 + + ! DIM is variable + do i = 1, 4 + if (kind(lbound(a, i)) /= default_kind .or. lbound(a, i) /= & + l_exp(i)) STOP 29 + if (kind(lbound(a, i, kind=1)) /= 1 .or. lbound(a, i, kind=1) /= & + l_exp(i)) STOP 30 + if (kind(lbound(a, i, kind=2)) /= 2 .or. lbound(a, i, kind=2) /= & + l_exp(i)) STOP 31 + if (kind(lbound(a, i, kind=4)) /= 4 .or. lbound(a, i, kind=4) /= & + l_exp(i)) STOP 32 + if (kind(lbound(a, i, kind=8)) /= 8 .or. lbound(a, i, kind=8) /= & + l_exp(i)) STOP 33 + + if (kind(ubound(a, i)) /= default_kind .or. ubound(a, i) /= & + u_exp(i)) STOP 35 + if (kind(ubound(a, i, kind=1)) /= 1 .or. ubound(a, i, kind=1) /= & + u_exp(i)) STOP 36 + if (kind(ubound(a, i, kind=2)) /= 2 .or. ubound(a, i, kind=2) /= & + u_exp(i)) STOP 37 + if (kind(ubound(a, i, kind=4)) /= 4 .or. ubound(a, i, kind=4) /= & + u_exp(i)) STOP 38 + if (kind(ubound(a, i, kind=8)) /= 8 .or. ubound(a, i, kind=8) /= & + u_exp(i)) STOP 39 + enddo + + ! DIM is missing + if (kind(lbound(a)) /= default_kind .or. size(lbound(a)) /= 4 .or. & + any(lbound(a) /= l_exp)) STOP 41 + if (kind(lbound(a, kind=1)) /= 1 .or. size(lbound(a, kind=1)) /= 4 .or. & + any(lbound(a, kind=1) /= l_exp)) STOP 42 + if (kind(lbound(a, kind=2)) /= 2 .or. size(lbound(a, kind=2)) /= 4 .or. & + any(lbound(a, kind=2) /= l_exp)) STOP 43 + if (kind(lbound(a, kind=4)) /= 4 .or. size(lbound(a, kind=4)) /= 4 .or. & + any(lbound(a, kind=4) /= l_exp)) STOP 44 + if (kind(lbound(a, kind=8)) /= 8 .or. size(lbound(a, kind=8)) /= 4 .or. & + any(lbound(a, kind=8) /= l_exp)) STOP 45 + + if (kind(ubound(a)) /= default_kind .or. size(ubound(a)) /= 4 .or. & + any(ubound(a) /= u_exp)) STOP 47 + if (kind(ubound(a, kind=1)) /= 1 .or. size(ubound(a, kind=1)) /= 4 .or. & + any(ubound(a, kind=1) /= u_exp)) STOP 48 + if (kind(ubound(a, kind=2)) /= 2 .or. size(ubound(a, kind=2)) /= 4 .or. & + any(ubound(a, kind=2) /= u_exp)) STOP 49 + if (kind(ubound(a, kind=4)) /= 4 .or. size(ubound(a, kind=4)) /= 4 .or. & + any(ubound(a, kind=4) /= u_exp)) STOP 50 + if (kind(ubound(a, kind=8)) /= 8 .or. size(ubound(a, kind=8)) /= 4 .or. & + any(ubound(a, kind=8) /= u_exp)) STOP 51 + end subroutine test_assumed_shape_with_lower_bound +end program diff --git a/test/f90_correct/src/bound7.f90 b/test/f90_correct/src/bound7.f90 new file mode 100644 index 00000000000..4bb10fd0a43 --- /dev/null +++ b/test/f90_correct/src/bound7.f90 @@ -0,0 +1,141 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Test for LBOUND and UBOUND when the array is assumed-shape. +! The options -Hy,68,1 and -My,68,1 are required. + +program test + implicit none + integer, allocatable :: x(:, :, :, :) + integer, parameter :: default_kind = kind(x) + + allocate(x(1:2, 2:4, 3:6, 4:8)) + call test_assumed_shape(x) + call test_assumed_shape_with_lower_bound(1, 3, 2, 4, x) + print *, "PASS" +contains + subroutine test_assumed_shape(a) + integer :: a(:, :, :, :) + integer :: l_exp(4), u_exp(4), i + + l_exp = [1, 1, 1, 1] + u_exp = [2, 3, 4, 5] + ! DIM is constant + if (any([lbound(a, 1), lbound(a, 2), lbound(a, 3), lbound(a, 4)] /= & + l_exp)) STOP 1 + if (any([ubound(a, 1), ubound(a, 2), ubound(a, 3), ubound(a, 4)] /= & + u_exp)) STOP 2 + + ! DIM is variable + do i = 1, 4 + if (kind(lbound(a, i)) /= default_kind .or. lbound(a, i) /= & + l_exp(i)) STOP 3 + if (kind(lbound(a, i, kind=1)) /= 1 .or. lbound(a, i, kind=1) /= & + l_exp(i)) STOP 4 + if (kind(lbound(a, i, kind=2)) /= 2 .or. lbound(a, i, kind=2) /= & + l_exp(i)) STOP 5 + if (kind(lbound(a, i, kind=4)) /= 4 .or. lbound(a, i, kind=4) /= & + l_exp(i)) STOP 6 + if (kind(lbound(a, i, kind=8)) /= 8 .or. lbound(a, i, kind=8) /= & + l_exp(i)) STOP 7 + + if (kind(ubound(a, i)) /= default_kind .or. ubound(a, i) /= & + u_exp(i)) STOP 9 + if (kind(ubound(a, i, kind=1)) /= 1 .or. ubound(a, i, kind=1) /= & + u_exp(i)) STOP 10 + if (kind(ubound(a, i, kind=2)) /= 2 .or. ubound(a, i, kind=2) /= & + u_exp(i)) STOP 11 + if (kind(ubound(a, i, kind=4)) /= 4 .or. ubound(a, i, kind=4) /= & + u_exp(i)) STOP 12 + if (kind(ubound(a, i, kind=8)) /= 8 .or. ubound(a, i, kind=8) /= & + u_exp(i)) STOP 13 + enddo + + ! DIM is missing + if (kind(lbound(a)) /= default_kind .or. size(lbound(a)) /= 4 .or. & + any(lbound(a) /= l_exp)) STOP 15 + if (kind(lbound(a, kind=1)) /= 1 .or. size(lbound(a, kind=1)) /= 4 .or. & + any(lbound(a, kind=1) /= l_exp)) STOP 16 + if (kind(lbound(a, kind=2)) /= 2 .or. size(lbound(a, kind=2)) /= 4 .or. & + any(lbound(a, kind=2) /= l_exp)) STOP 17 + if (kind(lbound(a, kind=4)) /= 4 .or. size(lbound(a, kind=4)) /= 4 .or. & + any(lbound(a, kind=4) /= l_exp)) STOP 18 + if (kind(lbound(a, kind=8)) /= 8 .or. size(lbound(a, kind=8)) /= 4 .or. & + any(lbound(a, kind=8) /= l_exp)) STOP 19 + + if (kind(ubound(a)) /= default_kind .or. size(ubound(a)) /= 4 .or. & + any(ubound(a) /= u_exp)) STOP 21 + if (kind(ubound(a, kind=1)) /= 1 .or. size(ubound(a, kind=1)) /= 4 .or. & + any(ubound(a, kind=1) /= u_exp)) STOP 22 + if (kind(ubound(a, kind=2)) /= 2 .or. size(ubound(a, kind=2)) /= 4 .or. & + any(ubound(a, kind=2) /= u_exp)) STOP 23 + if (kind(ubound(a, kind=4)) /= 4 .or. size(ubound(a, kind=4)) /= 4 .or. & + any(ubound(a, kind=4) /= u_exp)) STOP 24 + if (kind(ubound(a, kind=8)) /= 8 .or. size(ubound(a, kind=8)) /= 4 .or. & + any(ubound(a, kind=8) /= u_exp)) STOP 25 + end subroutine test_assumed_shape + + subroutine test_assumed_shape_with_lower_bound(l1, l2, l3, l4, a) + integer :: l1, l2, l3, l4 + integer :: a(l1:, l2:, l3:, l4:) + integer :: l_exp(4), u_exp(4), i + + l_exp = [l1, l2, l3, l4] + u_exp = [l1 + 1, l2 + 2, l3 + 3, l4 + 4] + ! DIM is constant + if (any([lbound(a, 1), lbound(a, 2), lbound(a, 3), lbound(a, 4)] /= & + l_exp)) STOP 27 + if (any([ubound(a, 1), ubound(a, 2), ubound(a, 3), ubound(a, 4)] /= & + u_exp)) STOP 28 + + ! DIM is variable + do i = 1, 4 + if (kind(lbound(a, i)) /= default_kind .or. lbound(a, i) /= & + l_exp(i)) STOP 29 + if (kind(lbound(a, i, kind=1)) /= 1 .or. lbound(a, i, kind=1) /= & + l_exp(i)) STOP 30 + if (kind(lbound(a, i, kind=2)) /= 2 .or. lbound(a, i, kind=2) /= & + l_exp(i)) STOP 31 + if (kind(lbound(a, i, kind=4)) /= 4 .or. lbound(a, i, kind=4) /= & + l_exp(i)) STOP 32 + if (kind(lbound(a, i, kind=8)) /= 8 .or. lbound(a, i, kind=8) /= & + l_exp(i)) STOP 33 + + if (kind(ubound(a, i)) /= default_kind .or. ubound(a, i) /= & + u_exp(i)) STOP 35 + if (kind(ubound(a, i, kind=1)) /= 1 .or. ubound(a, i, kind=1) /= & + u_exp(i)) STOP 36 + if (kind(ubound(a, i, kind=2)) /= 2 .or. ubound(a, i, kind=2) /= & + u_exp(i)) STOP 37 + if (kind(ubound(a, i, kind=4)) /= 4 .or. ubound(a, i, kind=4) /= & + u_exp(i)) STOP 38 + if (kind(ubound(a, i, kind=8)) /= 8 .or. ubound(a, i, kind=8) /= & + u_exp(i)) STOP 39 + enddo + + ! DIM is missing + if (kind(lbound(a)) /= default_kind .or. size(lbound(a)) /= 4 .or. & + any(lbound(a) /= l_exp)) STOP 41 + if (kind(lbound(a, kind=1)) /= 1 .or. size(lbound(a, kind=1)) /= 4 .or. & + any(lbound(a, kind=1) /= l_exp)) STOP 42 + if (kind(lbound(a, kind=2)) /= 2 .or. size(lbound(a, kind=2)) /= 4 .or. & + any(lbound(a, kind=2) /= l_exp)) STOP 43 + if (kind(lbound(a, kind=4)) /= 4 .or. size(lbound(a, kind=4)) /= 4 .or. & + any(lbound(a, kind=4) /= l_exp)) STOP 44 + if (kind(lbound(a, kind=8)) /= 8 .or. size(lbound(a, kind=8)) /= 4 .or. & + any(lbound(a, kind=8) /= l_exp)) STOP 45 + + if (kind(ubound(a)) /= default_kind .or. size(ubound(a)) /= 4 .or. & + any(ubound(a) /= u_exp)) STOP 47 + if (kind(ubound(a, kind=1)) /= 1 .or. size(ubound(a, kind=1)) /= 4 .or. & + any(ubound(a, kind=1) /= u_exp)) STOP 48 + if (kind(ubound(a, kind=2)) /= 2 .or. size(ubound(a, kind=2)) /= 4 .or. & + any(ubound(a, kind=2) /= u_exp)) STOP 49 + if (kind(ubound(a, kind=4)) /= 4 .or. size(ubound(a, kind=4)) /= 4 .or. & + any(ubound(a, kind=4) /= u_exp)) STOP 50 + if (kind(ubound(a, kind=8)) /= 8 .or. size(ubound(a, kind=8)) /= 4 .or. & + any(ubound(a, kind=8) /= u_exp)) STOP 51 + end subroutine test_assumed_shape_with_lower_bound +end program diff --git a/test/f90_correct/src/bound8.f90 b/test/f90_correct/src/bound8.f90 new file mode 100644 index 00000000000..4adf1cd37ff --- /dev/null +++ b/test/f90_correct/src/bound8.f90 @@ -0,0 +1,57 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Test for LBOUND and UBOUND when the array is explicit-shape. + +program test + implicit none + integer :: x(2,3,4) + call test_explicit_shape(4, 3, 2, x) + call test_explicit_shape_with_lower_bound(3, 5, 9, 12, 1, 5, x) + call test_subobject() + call test_array_func() + print *, "PASS" +contains + subroutine test_explicit_shape(n1, n2, n3, a) + integer :: n1, n2, n3 + integer :: a(n1, n2, n3) + if (any(lbound(a) /= 1)) STOP 1 + if (any(ubound(a) /= [n1, n2, n3])) STOP 2 + end subroutine + + subroutine test_explicit_shape_with_lower_bound(l1, u1, l2, u2, l3, u3, a) + integer :: l1, u1, l2, u2, l3, u3 + integer :: a(l1:u1, l2:u2, l3:u3) + if (any(lbound(a) /= [l1, l2, l3])) STOP 3 + if (any(ubound(a) /= [u1, u2, u3])) STOP 4 + end subroutine + + subroutine test_subobject() + integer :: y(10, 10, 10) + type t + integer, allocatable :: y(:, :, :) + integer :: i + end type + type(t) :: z, zz(2, 3, 4) + if (any(lbound(y(3:4, 5:9, 1:5)) /= [1, 1, 1])) STOP 5 + if (any(ubound(y(3:4, 5:9, 1:5)) /= [2, 5, 5])) STOP 6 + + allocate(z%y(10:20, 20:30, 30:40)) + if (any(lbound(z%y(13:14, 25:29, 31:35)) /= [1, 1, 1])) STOP 7 + if (any(ubound(z%y(13:14, 25:29, 31:35)) /= [2, 5, 5])) STOP 8 + + if (any(lbound(zz%i) /= [1, 1, 1])) STOP 9 + if (any(ubound(zz%i) /= [2, 3, 4])) STOP 10 + end subroutine + + subroutine test_array_func() + integer, allocatable :: y(:, :, :) + allocate(y(-1:1, -2:2, -3:3)) + if (lbound(shape(y), 1) /= 1) STOP 11 + if (any(lbound(shape(y)) /= 1)) STOP 12 + if (ubound(shape(y), 1) /= 3) STOP 13 + if (any(ubound(shape(y)) /= 3)) STOP 14 + end subroutine +end program diff --git a/test/f90_correct/src/bound9.f90 b/test/f90_correct/src/bound9.f90 new file mode 100644 index 00000000000..5b70f822540 --- /dev/null +++ b/test/f90_correct/src/bound9.f90 @@ -0,0 +1,30 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Test for restrictions about LBOUND and UBOUND. + +program test + implicit none + integer :: x(2,3,4) + type t + integer :: y + end type + type(t) :: a = t(1) + !{error "PGF90-S-0423-Constant DIM= argument is out of range"} + print *, ubound(x, 4) + !{error "PGF90-S-0423-Constant DIM= argument is out of range"} + print *, lbound(x, 0) + !{error "PGF90-S-0074-Illegal number or type of arguments to ubound - keyword argument *dim"} + print *, ubound(x, a) + !{error "PGF90-S-0074-Illegal number or type of arguments to lbound - keyword argument *kind"} + print *, lbound(x, a%y, a) +contains + subroutine test_assumed_rank(a) + integer :: a(..) + !{error "PGF90-S-0423-Constant DIM= argument is out of range"} + print *, ubound(a, DIM=200) + end subroutine +end program + diff --git a/test/f90_correct/src/submod32.f90 b/test/f90_correct/src/submod32.f90 index 1553b8cb892..6b2018d1ab8 100644 --- a/test/f90_correct/src/submod32.f90 +++ b/test/f90_correct/src/submod32.f90 @@ -32,10 +32,11 @@ program prog print *, "kind: ", kind(x) print *, "maxval: ", maxval(x) call check_arr(x) - if ( a .EQ. lbound(x, DIM=1) .AND. b .EQ. size(x) .AND. maxval(x) .EQ. m) then + if ( a .EQ. 1 .AND. lbound(x, DIM=1) .EQ. 7 .AND. b .EQ. size(x) .AND. maxval(x) .EQ. m) then print *, " PASS " else - print *, "FAILED: lbound of arr in submod is ", a, " and lbound of x is ", lbound(x, DIM=1) + print *, "FAILED: lbound of arr in submod is ", a, " and the expection is 1" + print *, "FAILED: lbound of x is is ", lbound(x, DIM=1), "and the expection is 7" print *, "FAILED: size of arr in submod is ", b, " and size of x is ", size(x) print *, "FAILED: maxval of arr in submod is", m, " and maxval of x is", maxval(x) end if diff --git a/test/mp_correct/inc/bound1.mk b/test/mp_correct/inc/bound1.mk new file mode 100644 index 00000000000..10455e70454 --- /dev/null +++ b/test/mp_correct/inc/bound1.mk @@ -0,0 +1,17 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +$(TEST): run + +build: $(SRC)/$(TEST).f90 + -$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(FC) $(FFLAGS) $(SRC)/$(TEST).f90 + -$(FC) $(LDFLAGS) $(TEST).$(OBJX) $(LIBS) -o $(TEST).$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test $(TEST) + -$(RUN4) $(TEST).$(EXESUFFIX) diff --git a/test/mp_correct/lit/bound1.sh b/test/mp_correct/lit/bound1.sh new file mode 100644 index 00000000000..3880a96ea63 --- /dev/null +++ b/test/mp_correct/lit/bound1.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# 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/mp_correct/src/bound1.f90 b/test/mp_correct/src/bound1.f90 new file mode 100644 index 00000000000..c6d677680f7 --- /dev/null +++ b/test/mp_correct/src/bound1.f90 @@ -0,0 +1,25 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Test for the fix for LBOUND/UBOUND regression where the calling is in the +! parallel region. + +program test + implicit none + integer :: x(7) + call test_assumed_shp(10, 1, x) + print *, "PASS" +contains + subroutine test_assumed_shp(n, m, a) + integer :: n, m + integer :: a(n:) + !$omp parallel + if (lbound(a, 1) /= 10) STOP 1 + if (ubound(a, 1) /= 16) STOP 2 + if (lbound(a, m) /= 10) STOP 3 + if (ubound(a, m) /= 16) STOP 4 + !$omp end parallel + end subroutine +end program diff --git a/tools/flang1/flang1exe/ast.c b/tools/flang1/flang1exe/ast.c index 33598b00345..a245bca8c17 100644 --- a/tools/flang1/flang1exe/ast.c +++ b/tools/flang1/flang1exe/ast.c @@ -4470,7 +4470,6 @@ ast_rewrite(int ast) { int atype; int astnew; - int l; int parent, mem, left, right, lop, rop, l1, l2, l3, sub, lbd, upbd, stride, dest, src, ifexpr, ifstmt, dolab, dovar, m1, m2, m3, itriple, otriple, otriple1, dim, bvect, ddesc, sdesc, mdesc, vsub, chunk, npar, start, @@ -4691,26 +4690,6 @@ ast_rewrite(int ast) } } break; - case I_LBOUND: - /* is dim a constant ? */ - if ((i = A_ALIASG(ARGT_ARG(argtnew, 1)))) { - shape = A_SHAPEG(ARGT_ARG(argtnew, 0)); - i = CONVAL2G(A_SPTRG(i)) - 1; - l = lbound_of_shape(shape, i); - if (l) - astnew = l; - } - break; - case I_UBOUND: - /* is dim a constant ? */ - if ((i = A_ALIASG(ARGT_ARG(argtnew, 1)))) { - shape = A_SHAPEG(ARGT_ARG(argtnew, 0)); - i = CONVAL2G(A_SPTRG(i)) - 1; - l = ubound_of_shape(shape, i); - if (l) - astnew = l; - } - break; default: break; } @@ -10182,3 +10161,15 @@ add_shapely_subscripts(int to_ast, int from_ast, DTYPE arr_dtype, int rank = get_ast_extents(extent_asts, from_ast, arr_dtype); return add_extent_subscripts(to_ast, rank, extent_asts, elt_dtype); } + +/* If an array AST is a whole array, return the SPTR of the array or the + * structure component. */ +SPTR +get_whole_array_sym(int arr_ast) +{ + if (A_TYPEG(arr_ast) == A_ID) + return A_SPTRG(arr_ast); + if (A_TYPEG(arr_ast) == A_MEM && !A_SHAPEG(A_PARENTG(arr_ast))) + return A_SPTRG(A_MEMG(arr_ast)); + return SPTR_NULL; +} diff --git a/tools/flang1/flang1exe/dpm_out.c b/tools/flang1/flang1exe/dpm_out.c index 8beb7aff23d..c63fc608c33 100644 --- a/tools/flang1/flang1exe/dpm_out.c +++ b/tools/flang1/flang1exe/dpm_out.c @@ -1535,10 +1535,22 @@ transform_wrapup(void) finish_fl(); open_entry_guard(this_entry); if (ENTSTDG(this_entry) != EntryStd) { + int s; + /* Rewrite any assignments added at the entry point. */ + for (s = STD_NEXT(ENTSTDG(this_entry)); s != EntryStd; s = STD_NEXT(s)) { + int ast; + arg_gbl.std = s; + arg_gbl.lhs = 0; + arg_gbl.used = FALSE; + arg_gbl.inforall = FALSE; + gbl.lineno = STD_LINENO(s); + ast = STD_AST(s); + if (A_TYPEG(ast) == A_ASN) + rewrite_asn(ast, s, TRUE, 0); + } /* reset LINENO for any statements added at the entry point. * this allows the debugger to set its breakpoints at the proper * point, which is after the prologue code */ - int s; for (s = STD_NEXT(ENTSTDG(this_entry)); s != EntryStd; s = STD_NEXT(s)) { STD_LINENO(s) = 0; } diff --git a/tools/flang1/flang1exe/func.c b/tools/flang1/flang1exe/func.c index 2e599d73dc8..67f6396a2cc 100644 --- a/tools/flang1/flang1exe/func.c +++ b/tools/flang1/flang1exe/func.c @@ -2871,6 +2871,9 @@ rewrite_func_ast(int func_ast, int func_args, int lhs) ARGT_ARG(newargt, 5) = mk_cval(size_of(stb.user.dt_int), DT_INT4); is_icall = FALSE; goto ret_call; + case I_UBOUND: /* ubound(array[, dim, kind]) */ + case I_LBOUND: /* lbound(array[, dim, kind]) */ + return rewrite_lbound_ubound(func_ast, 0, arg_gbl.std); default: goto ret_norm; } @@ -3705,12 +3708,13 @@ rewrite_sub_ast(int ast, int lc) asd = A_ASDG(ast); numdim = ASD_NDIM(asd); assert(numdim > 0 && numdim <= 7, "rewrite_sub_ast: bad numdim", ast, 4); + lop = rewrite_sub_ast(A_LOPG(ast), lc); for (i = 0; i < numdim; ++i) { l = rewrite_sub_ast(ASD_SUBS(asd, i), lc); subs[i] = l; } /* return mk_subscr(A_LOPG(ast), subs, numdim, DTY(dtype+1)); */ - return mk_subscr(A_LOPG(ast), subs, numdim, dtype); + return mk_subscr(lop, subs, numdim, dtype); case A_TRIPLE: l = rewrite_sub_ast(A_LBDG(ast), lc); r = rewrite_sub_ast(A_UPBDG(ast), lc); @@ -7508,3 +7512,450 @@ _reshape(int func_args, DTYPE dtype, int lhs) return retval; } + +/** \brief Rewrite intrinsic LBOUND/UBOUND to runtime call. + * + * \param func_ast ast for the intrinsic call + * \param actual corresponding actual for a assumed-shape formal that is + * used as the array parameter in the intrinsic call + * \param nextstd insert the generated stmts before this stmt + */ +int +rewrite_lbound_ubound(int func_ast, int actual, int nextstd) +{ + DTYPE dtype, arrdtype; + int func_args, optype, array, dim, nargs, newargt, subscr[MAXDIMS], + result, ast; + SPTR sptr, actual_sptr, hpf_sym, temp_arr; + FtnRtlEnum rtlRtn; + + func_args = A_ARGSG(func_ast); + optype = A_OPTYPEG(func_ast); + dtype = A_DTYPEG(func_ast); + array = ARGT_ARG(func_args, 0); + arrdtype = A_DTYPEG(array); + /* The KIND parameter has been eliminated and is represented in dtype. */ + if (ARGT_CNT(func_args) == 2) + dim = ARGT_ARG(func_args, 1); + else + dim = 0; + sptr = get_whole_array_sym(array); + result = 0; + if (sptr && SDSCG(sptr) && + (POINTERG(sptr) || ALLOCG(sptr) || ASSUMRANKG(sptr))) { + /* Get bound info from section descriptor. */ + if (dim) { + if (optype == I_LBOUND) { + switch (dtype) { + case DT_BINT: + rtlRtn = RTE_lbound1Dsc; + break; + case DT_SINT: + rtlRtn = RTE_lbound2Dsc; + break; + case DT_INT4: + rtlRtn = RTE_lbound4Dsc; + break; + case DT_INT8: + rtlRtn = RTE_lbound8Dsc; + break; + default: + error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), + "invalid kind argument for lbound"); + rtlRtn = RTE_lboundDsc; + break; + } + } else { + switch (dtype) { + case DT_BINT: + rtlRtn = RTE_ubound1Dsc; + break; + case DT_SINT: + rtlRtn = RTE_ubound2Dsc; + break; + case DT_INT4: + rtlRtn = RTE_ubound4Dsc; + break; + case DT_INT8: + rtlRtn = RTE_ubound8Dsc; + break; + default: + error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), + "invalid kind argument for ubound"); + rtlRtn = RTE_uboundDsc; + break; + } + } + /* pghpf...bound(dim, static_desciptor) */ + hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), dtype); + nargs = 2; + newargt = mk_argt(nargs); + ARGT_ARG(newargt, 0) = dim; + ARGT_ARG(newargt, 1) = check_member(array, mk_id(SDSCG(sptr))); + DESCUSEDP(sptr, 1); + goto ret_func; + } else { + if (!XBIT(68, 0x1) || XBIT(68, 0x2)) { + if (optype == I_LBOUND) { + switch (DDTG(dtype)) { + case DT_BINT: + rtlRtn = RTE_lbounda1Dsc; + break; + case DT_SINT: + rtlRtn = RTE_lbounda2Dsc; + break; + case DT_INT4: + rtlRtn = RTE_lbounda4Dsc; + break; + case DT_INT8: + rtlRtn = RTE_lbounda8Dsc; + break; + default: + error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), + "invalid kind argument for lbound"); + rtlRtn = RTE_lboundaDsc; + break; + } + } else { + switch (DDTG(dtype)) { + case DT_BINT: + rtlRtn = RTE_ubounda1Dsc; + break; + case DT_SINT: + rtlRtn = RTE_ubounda2Dsc; + break; + case DT_INT4: + rtlRtn = RTE_ubounda4Dsc; + break; + case DT_INT8: + rtlRtn = RTE_ubounda8Dsc; + break; + default: + error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), + "invalid kind argument for ubound"); + rtlRtn = RTE_uboundaDsc; + break; + } + } + } else { + if (optype == I_LBOUND) { + switch (DDTG(dtype)) { + case DT_BINT: + rtlRtn = RTE_lboundaz1Dsc; + break; + case DT_SINT: + rtlRtn = RTE_lboundaz2Dsc; + break; + case DT_INT4: + rtlRtn = RTE_lboundaz4Dsc; + break; + case DT_INT8: + rtlRtn = RTE_lboundaz8Dsc; + break; + default: + error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), + "invalid kind argument for lbound"); + rtlRtn = RTE_lboundazDsc; + break; + } + } else { + switch (DDTG(dtype)) { + case DT_BINT: + rtlRtn = RTE_uboundaz1Dsc; + break; + case DT_SINT: + rtlRtn = RTE_uboundaz2Dsc; + break; + case DT_INT4: + rtlRtn = RTE_uboundaz4Dsc; + break; + case DT_INT8: + rtlRtn = RTE_uboundaz8Dsc; + break; + default: + error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), + "invalid kind argument for ubound"); + rtlRtn = RTE_uboundazDsc; + break; + } + } + } + /* pghpf...bounda(temp, sd) or + * pghpf...boundaz(temp, sd) for -Mlarge_arrays + */ + hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), DT_NONE); + nargs = 2; + newargt = mk_argt(nargs); + ARGT_ARG(newargt, 1) = check_member(array, mk_id(SDSCG(sptr))); + DESCUSEDP(sptr, 1); + goto ret_call; + } + } else { + /* Get bound info from dtype or shape. */ + int rank = rank_of_ast(array); + if (actual) + actual_sptr = get_whole_array_sym(actual); + else + actual_sptr = SPTR_NULL; + if (dim) { + if (A_ALIASG(dim)) { + int i = get_int_cval(A_SPTRG(A_ALIASG(dim))); + if (actual) { + int lb, extent, mask; + if (actual_sptr && SDSCG(actual_sptr) && + (POINTERG(actual_sptr) || ALLOCG(actual_sptr))) { + /* The whole array actual_sptr corresponding to an assumed-shape + * formal cannot be assumed-rank. */ + extent = get_extent(SDSCG(actual_sptr), i - 1); + } else { + extent = extent_of_shape(A_SHAPEG(actual), i - 1); + } + lb = ADD_LWBD(arrdtype, i - 1); + lb = ast_rewrite(lb); /* Replace formal in boundary */ + mask = mk_binop(OP_GT, extent, astb.bnd.zero, DT_LOG); + lb = mk_merge(lb, astb.bnd.one, mask, astb.bnd.dtype); + if (optype == I_LBOUND) { + result = lb; + } else { + /* The extent of formal parameter is equal to the extent of actual + * parameter. */ + result = mk_binop(OP_ADD, lb, extent, astb.bnd.dtype); + result = mk_binop(OP_SUB, result, astb.bnd.one, astb.bnd.dtype); + } + } else if (sptr) { + int lb, ub; + lb = ADD_LWAST(arrdtype, i - 1); + if (!lb) + lb = astb.bnd.one; + ub = ADD_UPAST(arrdtype, i - 1); + if (optype == I_LBOUND) { + if (ADD_ASSUMSZ(arrdtype) && i == rank) { + result = lb; + } else { + int mask = mk_binop(OP_LE, lb, ub, DT_LOG); + result = mk_merge(lb, astb.bnd.one, mask, astb.bnd.dtype); + } + } else { + int mask = mk_binop(OP_LE, lb, ub, DT_LOG); + result = mk_merge(ub, astb.bnd.zero, mask, astb.bnd.dtype); + } + } else { + if (optype == I_LBOUND) + result = astb.bnd.one; + else + result = extent_of_shape(A_SHAPEG(array), i - 1); + } + goto ret_val; + } else { + if (optype == I_LBOUND) { + switch (dtype) { + case DT_BINT: + rtlRtn = RTE_lb1; + break; + case DT_SINT: + rtlRtn = RTE_lb2; + break; + case DT_INT4: + rtlRtn = RTE_lb4; + break; + case DT_INT8: + rtlRtn = RTE_lb8; + break; + default: + error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), + "invalid kind argument for lbound"); + rtlRtn = RTE_lb; + break; + } + } else { + switch (dtype) { + case DT_BINT: + rtlRtn = RTE_ub1; + break; + case DT_SINT: + rtlRtn = RTE_ub2; + break; + case DT_INT4: + rtlRtn = RTE_ub4; + break; + case DT_INT8: + rtlRtn = RTE_ub8; + break; + default: + error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), + "invalid kind argument for ubound"); + rtlRtn = RTE_ub; + break; + } + } + /* f90...bound(rank, dim, l1, u1, l2, u2, ..., l, u) */ + hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), astb.bnd.dtype); + nargs = 2 + 2 * rank; + newargt = mk_argt(nargs); + ARGT_ARG(newargt, 0) = mk_isz_cval(rank, astb.bnd.dtype); + if (actual) + dim = ast_rewrite(dim); /* Replace formal in DIM */ + ARGT_ARG(newargt, 1) = dim; + } + } else { + if (!XBIT(68, 0x1) || XBIT(68, 0x2)) { + if (optype == I_LBOUND) { + switch (DDTG(dtype)) { + case DT_BINT: + rtlRtn = RTE_lba1; + break; + case DT_SINT: + rtlRtn = RTE_lba2; + break; + case DT_INT4: + rtlRtn = RTE_lba4; + break; + case DT_INT8: + rtlRtn = RTE_lba8; + break; + default: + error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), + "invalid kind argument for lbound"); + rtlRtn = RTE_lba; + break; + } + } else { + switch (DDTG(dtype)) { + case DT_BINT: + rtlRtn = RTE_uba1; + break; + case DT_SINT: + rtlRtn = RTE_uba2; + break; + case DT_INT4: + rtlRtn = RTE_uba4; + break; + case DT_INT8: + rtlRtn = RTE_uba8; + break; + default: + error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), + "invalid kind argument for ubound"); + rtlRtn = RTE_uba; + break; + } + } + } else { + /* -Mlarge_arrays, but the result is default integer */ + if (optype == I_LBOUND) { + switch (DDTG(dtype)) { + case DT_BINT: + rtlRtn = RTE_lbaz1; + break; + case DT_SINT: + rtlRtn = RTE_lbaz2; + break; + case DT_INT4: + rtlRtn = RTE_lbaz4; + break; + case DT_INT8: + rtlRtn = RTE_lbaz8; + break; + default: + error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), + "invalid kind argument for lbound"); + rtlRtn = RTE_lbaz; + break; + } + } else { + switch (DDTG(dtype)) { + case DT_BINT: + rtlRtn = RTE_ubaz1; + break; + case DT_SINT: + rtlRtn = RTE_ubaz2; + break; + case DT_INT4: + rtlRtn = RTE_ubaz4; + break; + case DT_INT8: + rtlRtn = RTE_ubaz8; + break; + default: + error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), + "invalid kind argument for ubound"); + rtlRtn = RTE_ubaz; + break; + } + } + } + /* f90...bounda(temp, rank, l1, u1, l2, u2, ..., l, u) or + * f90...boundaz(temp, rank, l1, u1, l2, u2, ..., l, u) for + * -Mlarge_arrays + */ + hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), DT_NONE); + nargs = 2 + 2 * rank; + newargt = mk_argt(nargs); + ARGT_ARG(newargt, 1) = mk_isz_cval(rank, astb.bnd.dtype); + } + /* l1, u1, l2, u2, ..., l, u */ + for (int i = 0; i < rank; i++) { + int lb, ub; + if (actual) { + int extent, mask; + if (actual_sptr && SDSCG(actual_sptr) && + (POINTERG(actual_sptr) || ALLOCG(actual_sptr))) { + /* The whole array actual_sptr corresponding to an assumed-shape + * formal cannot be assumed-rank. */ + extent = get_extent(SDSCG(actual_sptr), i); + } else { + extent = extent_of_shape(A_SHAPEG(actual), i); + } + lb = ADD_LWBD(arrdtype, i); + lb = ast_rewrite(lb); /* Replace formal in boundary */ + mask = mk_binop(OP_GT, extent, astb.bnd.zero, DT_LOG); + lb = mk_merge(lb, astb.bnd.one, mask, astb.bnd.dtype); + /* The extent of formal parameter is equal to the extent of actual + * parameter. */ + ub = mk_binop(OP_ADD, lb, extent, astb.bnd.dtype); + ub = mk_binop(OP_SUB, ub, astb.bnd.one, astb.bnd.dtype); + } else if (sptr) { + lb = ADD_LWAST(arrdtype, i); + if (!lb) + lb = astb.bnd.one; + if (ADD_ASSUMSZ(arrdtype) && i == rank - 1) + ub = astb.ptr0; + else + ub = ADD_UPAST(arrdtype, i); + } else { + lb = astb.bnd.one; + ub = extent_of_shape(A_SHAPEG(array), i); + } + ARGT_ARG(newargt, 2 + i * 2) = lb; + ARGT_ARG(newargt, 3 + i * 2) = ub; + } + if (dim) + goto ret_func; + else + goto ret_call; + } +ret_func: + ast = mk_func_node(A_FUNC, mk_id(hpf_sym), nargs, newargt); + A_DTYPEP(ast, A_DTYPEG(func_ast)); + A_SHAPEP(ast, A_SHAPEG(func_ast)); + A_OPTYPEP(ast, optype); + return ast; +ret_call: + if (ADD_ASSUMRANK(arrdtype)) { + temp_arr = mk_shape_sptr(A_SHAPEG(func_ast), subscr, DDTG(dtype)); + if (ALLOCG(temp_arr)) { + mk_mem_allocate(mk_id(temp_arr), subscr, nextstd, 0); + mk_mem_deallocate(mk_id(temp_arr), nextstd); + } + } else { + temp_arr = get_arr_temp(dtype, TRUE, FALSE, FALSE); + trans_mkdescr(temp_arr); + } + ARGT_ARG(newargt, 0) = mk_id(temp_arr); + ast = mk_func_node(A_CALL, mk_id(hpf_sym), nargs, newargt); + A_OPTYPEP(ast, optype); + add_stmt_before(ast, nextstd); + return mk_id(temp_arr); +ret_val: + return result; +} diff --git a/tools/flang1/flang1exe/outconv.c b/tools/flang1/flang1exe/outconv.c index 6d418389f8e..0b3dd68e141 100644 --- a/tools/flang1/flang1exe/outconv.c +++ b/tools/flang1/flang1exe/outconv.c @@ -99,7 +99,6 @@ convert_output(void) } convert_statements(); FREE(ftb.base); - comm_fini(); freearea(FORALL_AREA); if (flg.opt >= 2 && !XBIT(47, 0x10)) { collapse_allocates(TRUE); @@ -108,6 +107,7 @@ convert_output(void) eliminate_barrier(); free_brtbl(); transform_wrapup(); + comm_fini(); convert_simple(); if (XBIT(58, 0x10000000)) convert_template_instance(); @@ -1105,9 +1105,17 @@ _simple_replacements(int ast, int *pany) fname = SYMNAME(fsptr); newast = ast; in_device_code = 0; - if (strcmp(fname, mkRteRtnNm(RTE_lboundDsc)) == 0) { + if (strcmp(fname, mkRteRtnNm(RTE_lboundDsc)) == 0 || + strcmp(fname, mkRteRtnNm(RTE_lbound1Dsc)) == 0 || + strcmp(fname, mkRteRtnNm(RTE_lbound2Dsc)) == 0 || + strcmp(fname, mkRteRtnNm(RTE_lbound4Dsc)) == 0 || + strcmp(fname, mkRteRtnNm(RTE_lbound8Dsc)) == 0) { newast = _pghpf_bound(1, ast); - } else if (strcmp(fname, mkRteRtnNm(RTE_uboundDsc)) == 0) { + } else if (strcmp(fname, mkRteRtnNm(RTE_uboundDsc)) == 0 || + strcmp(fname, mkRteRtnNm(RTE_ubound1Dsc)) == 0 || + strcmp(fname, mkRteRtnNm(RTE_ubound2Dsc)) == 0 || + strcmp(fname, mkRteRtnNm(RTE_ubound4Dsc)) == 0 || + strcmp(fname, mkRteRtnNm(RTE_ubound8Dsc)) == 0) { newast = _pghpf_bound(0, ast); } else if (strcmp(fname, mkRteRtnNm(RTE_extent)) == 0) { newast = _pghpf_size(0, ast); @@ -1232,7 +1240,10 @@ convert_simple(void) beforestd = std; ast_traverse(ast, NULL, _simple_replacements, &any); if (any) { - ast = ast_rewrite(ast); + while (any > 0) { + ast = ast_rewrite(ast); + any--; + } STD_AST(std) = ast; A_STDP(ast, std); } diff --git a/tools/flang1/flang1exe/semfunc.c b/tools/flang1/flang1exe/semfunc.c index da359ae84df..59471e2cdc1 100644 --- a/tools/flang1/flang1exe/semfunc.c +++ b/tools/flang1/flang1exe/semfunc.c @@ -53,6 +53,7 @@ static void replace_arguments(int, int); static void rewrite_triples(int, int, int); static void rewrite_subscr(int, int, int); static void replace_formal_triples(int, int, int); +static void replace_formal_bounds(int, int, int, int); static int getMergeSym(int, int); static void ref_pd_subr(SST *, ITEM *); static void ref_intrin_subr(SST *, ITEM *); @@ -2429,11 +2430,13 @@ gen_array_result(int array_value, int dscptr, int nactuals, LOGICAL is_derived, sem.bounds[ii].lowtype = S_NULL; if (AD_LWBD(ad, ii)) { replace_formal_triples(AD_LWBD(ad, ii), dscptr, nactuals); + replace_formal_bounds(AD_LWBD(ad, ii), dscptr, nactuals, 0); sem.bounds[ii].lwast = ast_rewrite((int)AD_LWBD(ad, ii)); } else { sem.bounds[ii].lwast = astb.bnd.one; } replace_formal_triples(AD_UPBD(ad, ii), dscptr, nactuals); + replace_formal_bounds(AD_UPBD(ad, ii), dscptr, nactuals, 0); sem.bounds[ii].upast = ast_rewrite((int)AD_UPBD(ad, ii)); } ast_unvisit(); @@ -2460,6 +2463,7 @@ gen_char_result(int fval, int dscptr, int nactuals) edt = DTY(dt + 1); ast_visit(1, 1); replace_arguments(dscptr, nactuals); + replace_formal_bounds(DTY(edt + 1), dscptr, nactuals, 0); len = ast_rewrite(DTY(edt + 1)); ast_unvisit(); if (A_TYPEG(len) == A_INTR && A_OPTYPEG(len) == I_LEN) { @@ -2727,6 +2731,68 @@ replace_formal_triples(int ast, int dscptr, int nactuals) } } +/** \brief Replace the intrinsic call of LBOUND/UBOUND on assumed-shape formal. + * Model after replace_formal_triples which replaces triples in bounds. + * + * The upper bound of the assumed-shape formal should be determined by the + * lower bound of the formal and the extent of the actual. + * + * \param ast the ast to traverse + * \param dscptr dummy parameter descriptor + * \param nactuals count of actuals (or formals) + * \param nextstd insert the generated stmts before this stmt + */ +static void +replace_formal_bounds(int ast, int dscptr, int nactuals, int nextstd) { + int cnt, argt, i, asd; + switch (A_TYPEG(ast)) { + case A_BINOP: + replace_formal_bounds(A_LOPG(ast), dscptr, nactuals, nextstd); + replace_formal_bounds(A_ROPG(ast), dscptr, nactuals, nextstd); + break; + case A_UNOP: + case A_PAREN: + case A_CONV: + replace_formal_bounds(A_LOPG(ast), dscptr, nactuals, nextstd); + break; + case A_INTR: + cnt = A_ARGCNTG(ast); + argt = A_ARGSG(ast); + for (i = 0; i < cnt; i++) { + /* watch for optional args */ + if (ARGT_ARG(argt, i) != 0) + replace_formal_bounds(ARGT_ARG(argt, i), dscptr, nactuals, nextstd); + } + /* Do the replace */ + if ((A_OPTYPEG(ast) == I_LBOUND || A_OPTYPEG(ast) == I_UBOUND) && + A_TYPEG(ARGT_ARG(argt, 0)) == A_ID) { + SPTR array = A_SPTRG(ARGT_ARG(argt, 0)); + if (ASSUMSHPG(array)) { + for (i = 0; i < nactuals; i++) { + if (array == aux.dpdsc_base[dscptr + i]) { + int astnew = rewrite_lbound_ubound(ast, A_REPLG(ARGT_ARG(argt, 0)), + nextstd); + ast_replace(ast, astnew); + break; + } + } + } + } + break; + case A_SUBSCR: + replace_formal_bounds(A_LOPG(ast), dscptr, nactuals, nextstd); + asd = A_ASDG(ast); + for (i = 0; i < ASD_NDIM(asd); ++i) + replace_formal_bounds(ASD_SUBS(asd, i), dscptr, nactuals, nextstd); + break; + case A_MEM: + replace_formal_bounds(A_PARENTG(ast), dscptr, nactuals, nextstd); + break; + default: + ast_visit(ast, 1); + } +} + /* * Substitute the formal arguments with the actual arguments. * Also, the appearance of formal arguments in descriptors need to @@ -5663,7 +5729,7 @@ ref_pd(SST *stktop, ITEM *list) ISZ_T iszval; int dum; ITEM *ip1; - int ast, arg1; + int ast, arg1, rank; int argt; int argt_count, argt_extra; int i; @@ -5682,10 +5748,8 @@ ref_pd(SST *stktop, ITEM *list) int func_ast; ACL *shape_acl; int sptr = 0, fsptr, baseptr; - LOGICAL is_whole, is_constant; + LOGICAL is_constant; int asumsz; - int assumshp; - int adjarr; int pvar; int nelems, eltype; const char *sname = NULL; @@ -6311,626 +6375,84 @@ ref_pd(SST *stktop, ITEM *list) E74_CNT(pdsym, count, 1, 3); goto call_e74_cnt; } - if (get_kwd_args(list, 3, KWDARGSTR(pdsym))) + dont_issue_assumedsize_error = 1; + if (evl_kwd_args(list, 3, KWDARGSTR(pdsym))) goto exit_; + /* Check the dtype of DIM. */ + if ((stkp = ARG_STK(1))) { + dtype2 = SST_DTYPEG(stkp); + if (!DT_ISINT(dtype2)) { + E74_ARG(pdsym, 1, NULL); + goto call_e74_arg; + } + } if ((stkp = ARG_STK(2))) { /* KIND */ dtyper2 = set_kind_result(stkp, DT_INT, TY_INT); if (!dtyper2) { - E74_ARG(pdsym, 3, NULL); + E74_ARG(pdsym, 2, NULL); goto call_e74_arg; } } else { - dtyper2 = 0; + dtyper2 = stb.user.dt_int; } - (void)mkarg(ARG_STK(0), &dum); - XFR_ARGAST(0); - argt_count = 2; dtype1 = SST_DTYPEG(ARG_STK(0)); if (DTY(dtype1) != TY_ARRAY) { E74_ARG(pdsym, 0, NULL); goto call_e74_arg; } - if (sem.dinit_data) { - int rank; - int ubound[7]; - int lbound[7]; - ACL *argacl; - - stkp = ARG_STK(0); - ad = AD_DPTR(SST_DTYPEG(stkp)); - rank = AD_NUMDIM( - ad); /* rank of array arg, potential upper bound of result array */ - - for (i = 0; i < rank; i++) { - ubound[i] = AD_UPAST(ad, i); - lbound[i] = AD_LWAST(ad, i); - } - - sem.arrdim.ndim = 1; - sem.arrdim.ndefer = 0; - sem.bounds[0].lowtype = S_CONST; - sem.bounds[0].lowb = 1; - sem.bounds[0].lwast = 0; - sem.bounds[0].uptype = S_CONST; - sem.bounds[0].upb = rank; - sem.bounds[0].upast = mk_cval(rank, stb.user.dt_int); - dtyper = mk_arrdsc(); - DTY(dtyper + 1) = (!dtyper2) ? stb.user.dt_int : dtyper2; - - argacl = GET_ACL(15); - - if (count == 2) { - dtyper = stb.user.dt_int; - } - - gen_init_intrin_call(stktop, pdsym, count, dtyper, FALSE); - return 0; - } - - shape1 = A_SHAPEG(ARG_AST(0)); - count = SHD_NDIM(shape1); /* rank of array arg */ - argt_count = count * 2 + 2; - adjarr = 0; - asumsz = 0; - assumshp = 0; + /* get the rank of source array */ arg1 = ARG_AST(0); - switch (A_TYPEG(arg1)) { - case A_ID: - adjarr = assumshp = asumsz = A_SPTRG(arg1); - if (SCG(asumsz) != SC_DUMMY || !ASUMSZG(asumsz)) - asumsz = 0; - if (SCG(assumshp) != SC_DUMMY || !ASSUMSHPG(assumshp)) - assumshp = 0; - if (SCG(adjarr) != SC_DUMMY || !ADJARRG(adjarr)) - adjarr = 0; - is_whole = TRUE; - break; - case A_MEM: - if (A_SHAPEG(A_PARENTG(arg1))) { - is_whole = FALSE; - } else { - is_whole = TRUE; - } - break; - default: - is_whole = FALSE; - break; - } - sptr = find_pointer_variable(arg1); - if (sptr && (POINTERG(sptr) || (ALLOCG(sptr) && SDSCG(sptr)))) { - if ((stkp = ARG_STK(1))) { - /* pghpf...bound(dim, static_desciptor) */ - (void)mkexpr(stkp); - XFR_ARGAST(1); - dtype2 = SST_DTYPEG(stkp); - if (!DT_ISINT(dtype2)) { - E74_ARG(pdsym, 1, NULL); - goto call_e74_arg; - } - if (XBIT(68, 0x1) && XBIT(68, 0x2)) - dtyper = (!dtyper2) ? DT_INT8 : dtyper2; - else - dtyper = (!dtyper2) ? stb.user.dt_int : dtyper2; - shaper = 0; - ARG_AST(0) = mk_bnd_int(ARG_AST(1)); /* dim */ - ARG_AST(1) = check_member(arg1, mk_id(SDSCG(sptr))); - /* static descriptor */ - func_type = A_FUNC; - if (pdtype == PD_lbound) { - switch (dtyper2) { - case 0: - rtlRtn = RTE_lboundDsc; - break; - case DT_BINT: - rtlRtn = RTE_lbound1Dsc; - break; - case DT_SINT: - rtlRtn = RTE_lbound2Dsc; - break; - case DT_INT4: - rtlRtn = RTE_lbound4Dsc; - break; - case DT_INT8: - rtlRtn = RTE_lbound8Dsc; - break; - default: - error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), - "invalid kind argument for ubound"); - } - } else { - switch (dtyper2) { - case 0: - rtlRtn = RTE_uboundDsc; - break; - case DT_BINT: - rtlRtn = RTE_ubound1Dsc; - break; - case DT_SINT: - rtlRtn = RTE_ubound2Dsc; - break; - case DT_INT4: - rtlRtn = RTE_ubound4Dsc; - break; - case DT_INT8: - rtlRtn = RTE_ubound8Dsc; - break; - default: - error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), - "invalid kind argument for lbound"); - } - } - - /* FIXME: there is no [lu]bound[1234]*Dsc (ENTPGHPF)routines */ - if (XBIT(68, 0x1)) - hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), - (!dtyper2) ? dtyper : dtyper2); - else - hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), - (!dtyper2) ? dtyper : dtyper2); - - arrtmp_ast = 0; - argt_count = 2; - goto gen_call; - } - - /* pghpf...bounda(temp, sd) */ - - if (XBIT(68, 0x1) && XBIT(68, 0x2)) - dtyper = (!dtyper2) ? get_array_dtype(1, DT_INT8) - : get_array_dtype(1, dtyper2); - else - dtyper = (!dtyper2) ? get_array_dtype(1, stb.user.dt_int) - : get_array_dtype(1, dtyper2); - ad = AD_DPTR(dtyper); - AD_UPBD(ad, 0) = AD_UPAST(ad, 0) = - mk_isz_cval(rank_of_ast(ARG_AST(0)), astb.bnd.dtype); - tmp = get_arr_temp(dtyper, FALSE, FALSE, FALSE); - arrtmp_ast = mk_id(tmp); - shaper = A_SHAPEG(arrtmp_ast); - ARG_AST(0) = arrtmp_ast; /* first argument is temp */ - ARG_AST(1) = check_member(arg1, mk_id(SDSCG(sptr))); - /* static descriptor */ - func_type = A_CALL; - if (!XBIT(68, 0x1) || XBIT(68, 0x2)) { - if (pdtype == PD_lbound) { - switch (dtyper2) { - case 0: - rtlRtn = RTE_lboundaDsc; - break; - case DT_BINT: - rtlRtn = RTE_lbounda1Dsc; - break; - case DT_SINT: - rtlRtn = RTE_lbounda2Dsc; - break; - case DT_INT4: - rtlRtn = RTE_lbounda4Dsc; - break; - case DT_INT8: - rtlRtn = RTE_lbounda8Dsc; - break; - default: - error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), - "invalid kind argument for lbound"); - } - } else { - switch (dtyper2) { - case 0: - rtlRtn = RTE_uboundaDsc; - break; - case DT_BINT: - rtlRtn = RTE_ubounda1Dsc; - break; - case DT_SINT: - rtlRtn = RTE_ubounda2Dsc; - break; - case DT_INT4: - rtlRtn = RTE_ubounda4Dsc; - break; - case DT_INT8: - rtlRtn = RTE_ubounda8Dsc; - break; - default: - error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), - "invalid kind argument for ubound"); - } - } - } else { - /* -Mlarge_arrays, but the result is default integer */ - if (pdtype == PD_lbound) { - switch (dtyper2) { - case 0: - rtlRtn = RTE_lboundazDsc; - break; - case DT_BINT: - rtlRtn = RTE_lboundaz1Dsc; - break; - case DT_SINT: - rtlRtn = RTE_lboundaz2Dsc; - break; - case DT_INT4: - rtlRtn = RTE_lboundaz4Dsc; - break; - case DT_INT8: - rtlRtn = RTE_lboundaz8Dsc; - break; - default: - error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), - "invalid kind argument for lbound"); - } - } else { - switch (dtyper2) { - case 0: - rtlRtn = RTE_uboundazDsc; - break; - case DT_BINT: - rtlRtn = RTE_uboundaz1Dsc; - break; - case DT_SINT: - rtlRtn = RTE_uboundaz2Dsc; - break; - case DT_INT4: - rtlRtn = RTE_uboundaz4Dsc; - break; - case DT_INT8: - rtlRtn = RTE_uboundaz8Dsc; - break; - default: - error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), - "invalid kind argument for ubound"); - } - } - } - - hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), DT_NONE); - ast = begin_call(func_type, hpf_sym, 2); - add_arg(ARG_AST(0)); - add_arg(ARG_AST(1)); - /* call statement is generated, result is the temporary */ - (void)add_stmt(ast); - ast = arrtmp_ast; - goto expr_val; + sptr = get_whole_array_sym(arg1); + if (sptr && STYPEG(sptr) == ST_ARRAY && SCG(sptr) == SC_DUMMY && + ASSUMRANKG(sptr)) { + /* assumed-rank */ + if (!SDSCG(sptr)) + get_static_descriptor(sptr); + rank = get_desc_rank(SDSCG(sptr)); + } else { + rank = mk_isz_cval(rank_of_ast(ARG_AST(0)), astb.bnd.dtype); } - if ((stkp = ARG_STK(1))) { - /* f90...bound(rank, dim, l1, u1, l1, u2, ..., l, u) */ - (void)mkexpr(stkp); - XFR_ARGAST(1); - dtype2 = SST_DTYPEG(stkp); - if (!DT_ISINT(dtype2)) { - E74_ARG(pdsym, 1, NULL); - goto call_e74_arg; - } - if (XBIT(68, 0x1) && XBIT(68, 0x2)) - dtyper = (!dtyper2) ? DT_INT8 : dtyper2; - else - dtyper = (!dtyper2) ? stb.user.dt_int : dtyper2; - shaper = 0; - if ((ast = A_ALIASG(ARG_AST(1)))) { + if (ARG_AST(1)) { /* DIM */ + if (A_ALIASG(ARG_AST(1))) { /* dim is a constant */ - i = get_int_cval(A_SPTRG(ast)); - if (i < 1 || i > count) { - error(423, 3, gbl.lineno, NULL, NULL); - i = 1; - } - if (pdtype == PD_lbound) { - if (is_whole) { - if (asumsz != 0 && i == count) - ast = astb.bnd.one; - else { - ast = lbound_of_shape(shape1, i - 1); - if (ast == 0 && SHD_LWB(shape1, i - 1)) { - ast = SHD_LWB(shape1, i - 1); - } - } - } else - ast = astb.bnd.one; - } else { /* ubound/dubound */ - if (is_whole) { - if (asumsz != 0 && i == count) { - error(84, 3, gbl.lineno, SYMNAME(asumsz), - "- ubound of assumed size array is unknown"); - ast = astb.bnd.one; - } else { - ast = ubound_of_shape(shape1, i - 1); - if (ast == 0 && SHD_UPB(shape1, i - 1)) { - ast = SHD_UPB(shape1, i - 1); - } - } - } - /* - * Before computing the extent, ensure that an upper bound - * for this dimension exists. The upper bound may be zero - * if the array is an argument declared in an interface - * within a module. - */ - else if (SHD_UPB(shape1, i - 1)) { - ast = extent_of_shape(shape1, i - 1); - goto expr_val; - } else - ast = 0; - } - if (ast) { - if (A_ALIASG(ast)) { - ast = A_ALIASG(ast); - iszval = get_isz_cval(A_SPTRG(ast)); - goto const_isz_val; - } - if (A_DTYPEG(ast) != dtyper) - ast = mk_convert(ast, dtyper); - } - if (pdtype == PD_lbound) { - switch (dtyper2) { - case 0: - rtlRtn = RTE_lb; - break; - case DT_BINT: - rtlRtn = RTE_lb1; - break; - case DT_SINT: - rtlRtn = RTE_lb2; - break; - case DT_INT4: - rtlRtn = RTE_lb4; - break; - case DT_INT8: - rtlRtn = RTE_lb8; - break; - default: - error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), - "invalid kind argument for lbound"); - } - } else { - switch (dtyper2) { - case 0: - rtlRtn = RTE_ub; - break; - case DT_BINT: - rtlRtn = RTE_ub1; - break; - case DT_SINT: - rtlRtn = RTE_ub2; - break; - case DT_INT4: - rtlRtn = RTE_ub4; - break; - case DT_INT8: - rtlRtn = RTE_ub8; - break; - default: - error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), - "invalid kind argument for ubound"); - } - } - if (adjarr != 0) { - /* If this expression uses an adjustable dummy array, then - * generate the intrinsic lbound/ubound call instead of a rewritten - * bound function call. - * Otherwise, the call may be wrongfully placed in an early - * specification statement. This intrinsic call may be rewritten later - * but after we handle the early specification statements. - */ - argt_count = 2; - goto gen_call; - } - if (sem.interface || (assumshp != 0 && sem.which_pass == 0)) { - /* - * if this expression is rewritten (i.e., when this - * function specified by this interface is invoked), - * ast_rewrite() will select the bound based on the - * constant dim value. - */ - argt_count = 2; - - (void)sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), stb.user.dt_int); - goto gen_call; - } - /* ast is 0 => must determine the bound based on the lower and - * upper bound of the specified dimension; call the function - * with (rank = 1, dim = 1, lb, ub). - */ - if (assumshp != 0 && sem.which_pass != 0) { - if (pdtype == PD_lbound) { - ast = SHD_LWB(shape1, i - 1); - if (A_TYPEG(ast) == A_CNST && get_int_cval(A_SPTRG(ast)) != 1) { - /* assumed shape array with a constant lb != 1 - * dpm_out.c:set_assumed_bounds my reset the - * lb as per the F90 Standard section 13.13.52. - * The following insures that the correct lb - * is reported. - */ - ast = ADD_LWAST(dtype1, i - 1); - } - } else { - ast = SHD_UPB(shape1, i - 1); - } - if (ast) { - if (A_DTYPEG(ast) != dtyper) - ast = mk_convert(ast, dtyper); - goto lbound_ret; - } - } - - hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), dtyper); - ast = begin_call(A_FUNC, hpf_sym, 4); - add_arg(astb.bnd.one); - add_arg(astb.bnd.one); - add_arg(check_member(arg1, SHD_LWB(shape1, i - 1))); - add_arg(check_member(arg1, SHD_UPB(shape1, i - 1))); - A_DTYPEP(ast, dtyper); - goto lbound_ret; - } - ARG_AST(0) = mk_isz_cval((INT)count, astb.bnd.dtype); /* rank */ - /* ARG_AST(1) = ARG_AST(1); dim */ - func_type = A_FUNC; - if (pdtype == PD_lbound) - rtlRtn = RTE_lb; - else { - if (asumsz != 0 && count == 1) - error(84, 3, gbl.lineno, SYMNAME(asumsz), - "- ubound of assumed size array is unknown"); - rtlRtn = RTE_ub; - } - - hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), dtyper); - arrtmp_ast = 0; - } else { - /*f90...bounda(temp, rank, l1, u1, l1, u2, ..., l, u) */ - if (XBIT(68, 0x1) && XBIT(68, 0x2)) - dtyper = (!dtyper2) ? get_array_dtype(1, DT_INT8) - : get_array_dtype(1, dtyper2); - else - dtyper = (!dtyper2) ? get_array_dtype(1, stb.user.dt_int) - : get_array_dtype(1, dtyper2); - ad = AD_DPTR(dtyper); - AD_UPBD(ad, 0) = AD_UPAST(ad, 0) = - mk_isz_cval(rank_of_ast(ARG_AST(0)), astb.bnd.dtype); - tmp = get_arr_temp(dtyper, FALSE, FALSE, FALSE); - arrtmp_ast = mk_id(tmp); - shaper = A_SHAPEG(arrtmp_ast); - ARG_AST(0) = arrtmp_ast; /* first argument is temp */ - ARG_AST(1) = mk_isz_cval((INT)count, astb.bnd.dtype); /* rank */ - func_type = A_CALL; - if (!XBIT(68, 0x1) || XBIT(68, 0x2)) { - if (pdtype == PD_lbound) { - switch (dtyper2) { - case 0: - rtlRtn = RTE_lba; - break; - case DT_BINT: - rtlRtn = RTE_lba1; - break; - case DT_SINT: - rtlRtn = RTE_lba2; - break; - case DT_INT4: - rtlRtn = RTE_lba4; - break; - case DT_INT8: - rtlRtn = RTE_lba8; - break; - default: - error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), - "invalid kind argument for lbound"); - } - } else { - if (asumsz != 0) - error(84, 3, gbl.lineno, SYMNAME(asumsz), + int rank_val = MAXDIMS; + i = get_int_cval(A_SPTRG(A_ALIASG(ARG_AST(1)))); + if (A_ALIASG(rank)) { + rank_val = get_isz_cval(A_SPTRG(A_ALIASG(rank))); + if (pdtype == PD_ubound && sptr && ASUMSZG(sptr) && i == rank_val) { + error(84, 3, gbl.lineno, SYMNAME(sptr), "- ubound of assumed size array is unknown"); - switch (dtyper2) { - case 0: - rtlRtn = RTE_uba; - break; - case DT_BINT: - rtlRtn = RTE_uba1; - break; - case DT_SINT: - rtlRtn = RTE_uba2; - break; - case DT_INT4: - rtlRtn = RTE_uba4; - break; - case DT_INT8: - rtlRtn = RTE_uba8; - break; - default: - error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), - "invalid kind argument for ubound"); } } - } else { - /* -Mlarge_arrays, but the result is default integer */ - if (pdtype == PD_lbound) { - switch (dtyper2) { - case 0: - rtlRtn = RTE_lbaz; - break; - case DT_BINT: - rtlRtn = RTE_lbaz1; - break; - case DT_SINT: - rtlRtn = RTE_lbaz2; - break; - case DT_INT4: - rtlRtn = RTE_lbaz4; - break; - case DT_INT8: - rtlRtn = RTE_lbaz8; - break; - default: - error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), - "invalid kind argument for lbound"); - } - } else { - if (asumsz != 0) - error(84, 3, gbl.lineno, SYMNAME(asumsz), - "- ubound of assumed size array is unknown"); - switch (dtyper2) { - case 0: - rtlRtn = RTE_ubaz; - break; - case DT_BINT: - rtlRtn = RTE_ubaz1; - break; - case DT_SINT: - rtlRtn = RTE_ubaz2; - break; - case DT_INT4: - rtlRtn = RTE_ubaz4; - break; - case DT_INT8: - rtlRtn = RTE_ubaz8; - break; - default: - error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), - "invalid kind argument for ubound"); - } + if (i < 1 || i > rank_val) { + error(423, 3, gbl.lineno, NULL, NULL); + ARG_AST(1) = astb.bnd.one; } } - - hpf_sym = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), DT_NONE); + dtyper = dtyper2; + /* lbound/ubound (array, dim) */ + argt_count = 2; + } else { + if (pdtype == PD_ubound && sptr && ASUMSZG(sptr)) { + error(84, 3, gbl.lineno, SYMNAME(sptr), + "- ubound of assumed size array is unknown"); + } + dtyper = get_array_dtype(1, dtyper2); + ADD_LWBD(dtyper, 0) = ADD_LWAST(dtyper, 0) = astb.bnd.one; + ADD_UPBD(dtyper, 0) = ADD_UPAST(dtyper, 0) = rank; + ADD_NUMELM(dtyper) = ADD_EXTNTAST(dtyper, 0) = ADD_UPBD(dtyper, 0); + /* lbound/ubound (array) */ + argt_count = 1; } - ast = begin_call(func_type, hpf_sym, argt_count); - add_arg(ARG_AST(0)); - add_arg(ARG_AST(1)); - for (i = 0; i < count; i++) { - if (is_whole) { - if (assumshp != 0 && A_TYPEG(SHD_LWB(shape1, i)) == A_CNST && - get_int_cval(A_SPTRG(SHD_LWB(shape1, i))) != 1) { - /* assumed shape array with a constant lb != 1 - * dpm_out.c:set_assumed_bounds my reset the - * lb as per the F90 Standard section 13.13.52. - * The following insures that the correct lb - * is reported. - */ - add_arg(ADD_LWAST(dtype1, i)); - } else { - add_arg(SHD_LWB(shape1, i)); - } - } else { - add_arg(mk_cval((INT)1, astb.bnd.dtype)); - } - if (is_whole) { - if (i < count - 1) - add_arg(SHD_UPB(shape1, i)); - else if (asumsz != 0) - add_arg(astb.ptr0); - else - add_arg(SHD_UPB(shape1, i)); - } else - add_arg(extent_of_shape(shape1, i)); + if (sem.dinit_data) { + gen_init_intrin_call(stktop, pdsym, count, dtyper, FALSE); + return 0; } - if (arrtmp_ast) { - /* call statement is generated, result is the temporary */ - (void)add_stmt(ast); - ast = arrtmp_ast; - } else - A_DTYPEP(ast, dtyper); - lbound_ret: - goto expr_val; + break; case PD_cshift: if (XBIT(49, 0x40)) { /* if xbit set, CM fortran intrinsics allowed */ diff --git a/tools/flang1/flang1exe/semutil2.c b/tools/flang1/flang1exe/semutil2.c index 36115401b84..a58f6ef61a1 100644 --- a/tools/flang1/flang1exe/semutil2.c +++ b/tools/flang1/flang1exe/semutil2.c @@ -6800,10 +6800,11 @@ const_eval(int ast) return sz; } case I_LBOUND: { - int lwb; + int lwb, dim; val = A_ARGSG(ast); ast = ARGT_ARG(val, 0); - ast = ADD_LWAST(A_DTYPEG(ast), val - 1); + dim = get_const_from_ast(ARGT_ARG(val, 1)); + ast = ADD_LWAST(A_DTYPEG(ast), dim - 1); lwb = get_const_from_ast(ast); if (XBIT(68, 0x1) && A_ALIASG(ast) && !DT_ISWORD(A_DTYPEG(ast))) { lwb = get_int_cval(lwb); @@ -6811,10 +6812,11 @@ const_eval(int ast) return lwb; } case I_UBOUND: { - int upb; + int upb, dim; val = A_ARGSG(ast); ast = ARGT_ARG(val, 0); - ast = ADD_UPAST(A_DTYPEG(ast), val - 1); + dim = get_const_from_ast(ARGT_ARG(val, 1)); + ast = ADD_UPAST(A_DTYPEG(ast), dim - 1); upb = get_const_from_ast(ast); if (XBIT(68, 0x1) && A_ALIASG(ast) && !DT_ISWORD(A_DTYPEG(ast))) { upb = get_int_cval(upb); diff --git a/tools/flang1/flang1exe/symutl.h b/tools/flang1/flang1exe/symutl.h index 95a959d7c00..075a669a6b2 100644 --- a/tools/flang1/flang1exe/symutl.h +++ b/tools/flang1/flang1exe/symutl.h @@ -70,6 +70,7 @@ void fixup_srcalloc_bounds(int *, int *, int); void check_alloc_ptr_type(int, int, DTYPE, int, int, int, int); /* func.c */ LOGICAL contiguous_section(int arr_ast); /* func.c */ +int rewrite_lbound_ubound(int func_ast, int actual, int nextstd); /* func.c */ int gen_set_len_ast(int ast, SPTR ddesc, int sz); /* outconv.c */ LOGICAL inline_RTE_set_type(int, int, int, int, DTYPE, int); /* outconv.c */ diff --git a/tools/flang1/utils/ast/ast.in.h b/tools/flang1/utils/ast/ast.in.h index 8a30162fec6..78f2fda4c38 100644 --- a/tools/flang1/utils/ast/ast.in.h +++ b/tools/flang1/utils/ast/ast.in.h @@ -498,3 +498,4 @@ int add_bounds_subscripts(int to_ast, int rank, const int lower_bound_asts[], const int upper_bound_asts[], DTYPE elt_dtype); int add_shapely_subscripts(int to_ast, int from_ast, DTYPE arr_dtype, DTYPE elt_dtype); LOGICAL ast_is_sym(int ast); +SPTR get_whole_array_sym(int arr_ast);