Skip to content

Commit e6a9276

Browse files
sscalponesscalpone
authored
Merge pull request #819 from ThePortlandGroup/nv_stage
Implement the Fortran 2008 BLOCK construct
2 parents 249b986 + d2d64f0 commit e6a9276

File tree

32 files changed

+1400
-1137
lines changed

32 files changed

+1400
-1137
lines changed

‎include/flang/Error/errmsg-in.n‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -397,7 +397,7 @@ left (e.g. '1234567890abcdef1'x will be '234567890abcdef1'x).
397397
.MS S 116 "Illegal use of pointer-based variable $ $"
398398
.MS S 117 "Statement not allowed within a $ definition"
399399
The statement may not appear in a STRUCTURE or derived type definition.
400-
.MS S 118 "Statement not allowed in DO, IF, or WHERE block"
400+
.MS S 118 "Statement not allowed in BLOCK, DO, IF, WHERE, or other executable construct"
401401
.MS I 119 "Redundant specification for $"
402402
Data type of indicated symbol specified more than once.
403403
.MS I 120 "Label $ is defined but never referenced"
@@ -1531,3 +1531,5 @@ Starting from 1100, Reserved for OpenMP GPU
15311531
.MS S 1215 "OpenACC data clause expected after $."
15321532
.MS S 1216 "Expression in assignment statement contains type bound procedure name $. This may be a function call that's missing parentheses."
15331533
.MS S 1217 "Left hand side of polymorphic assignment must be allocatable - $"
1534+
.MS S 1218 "$ statement may not appear in a BLOCK construct."
1535+
.MS S 1219 "Unimplemented feature: $."

‎test/f90_correct/src/oop773.f90‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -29,15 +29,15 @@ subroutine foo()
2929
subroutine bar(this)
3030
class(obj) :: this
3131

32-
!block
32+
block
3333
type t
3434
contains
3535
procedure, nopass :: foo
3636
end type
3737
type(t) :: o
3838

3939
call o%foo()
40-
!end block
40+
end block
4141
end subroutine
4242

4343
end module

‎test/f90_correct/src/oop774.f90‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -31,7 +31,7 @@ subroutine foo2(i)
3131

3232
subroutine bar()
3333
use mod
34-
!block
34+
block
3535
type t
3636
contains
3737
procedure, nopass :: foo
@@ -41,7 +41,7 @@ subroutine bar()
4141
type(t) :: o
4242

4343
call o%func(-99)
44-
!end block
44+
end block
4545
end subroutine
4646

4747
use mod

‎test/f90_correct/src/oop775.f90‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -33,7 +33,7 @@ subroutine foo2(i)
3333

3434
subroutine bar(this)
3535
class(obj) :: this
36-
!block
36+
block
3737
type t
3838
contains
3939
procedure, nopass :: foo
@@ -43,7 +43,7 @@ subroutine bar(this)
4343
type(t) :: o
4444

4545
call o%func(-99)
46-
!end block
46+
end block
4747
end subroutine
4848

4949
end module

‎tools/flang1/flang1exe/astout.c‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2322,6 +2322,7 @@ print_ast(int ast)
23222322
print_ast(A_ENDLABG(ast));
23232323
}
23242324
A_TYPEP(ast, A_DO);
2325+
put_string(" ");
23252326
print_ast(ast);
23262327
A_TYPEP(ast, A_MP_PDO);
23272328
break;

‎tools/flang1/flang1exe/bblock.c‎

Lines changed: 77 additions & 55 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
/*
2-
* Copyright (c) 1994-2018, NVIDIA CORPORATION. All rights reserved.
2+
* Copyright (c) 1994-2019, NVIDIA CORPORATION. All rights reserved.
33
*
44
* Licensed under the Apache License, Version 2.0 (the "License");
55
* you may not use this file except in compliance with the License.
@@ -35,7 +35,6 @@
3535
#include "pd.h"
3636
#include "rtlRtns.h"
3737

38-
static int exit_point;
3938
static int entry_point;
4039
static int par; /* in OpenMp parallel region */
4140
static int cs; /* in OpenMp critical section */
@@ -88,6 +87,7 @@ bblock()
8887
INT ent_cnt;
8988
int ent_select_id;
9089
int has_kernel = 0;
90+
ITEM *itemp;
9191

9292
if (STD_NEXT(0) == STD_PREV(0)) { /* end only ? */
9393
/* add something for entry -- lfm */
@@ -102,7 +102,7 @@ bblock()
102102

103103
sem.temps_reset = TRUE;
104104
entry_point = 0;
105-
last_std = STD_PREV(0);
105+
last_std = STD_LAST;
106106

107107
if (gbl.arets) {
108108
/* for alternate returns, will use a compiler-created local symbol
@@ -369,35 +369,35 @@ bblock()
369369
ENTSTDP(ent, entry_point);
370370
}
371371

372-
/*
373-
* gen_auto_dealloc();
374-
*/
375-
{
376-
ITEM *itemp;
372+
if (sem.type_initialize) {
377373
int std2;
378-
for (itemp = sem.auto_dealloc; itemp; itemp = itemp->next) {
379-
gen_conditional_dealloc_for_sym(itemp->t.sptr, gbl.exitstd);
374+
for (std2 = ENTSTDG(gbl.currsub); STD_LINENO(std2) == 0;
375+
std2 = STD_NEXT(std2))
376+
;
377+
std2 = STD_PREV(std2);
378+
for (itemp = sem.type_initialize; itemp; itemp = itemp->next) {
379+
int stdx = CONSTRUCTSYMG(itemp->t.sptr) ?
380+
BLOCK_ENTRY_STD(itemp->t.sptr) : std2;
381+
gen_type_initialize_for_sym(itemp->t.sptr, stdx, 0, 0);
380382
}
383+
}
381384

382-
std2 = gbl.exitstd;
383-
for (itemp = sem.auto_finalize; itemp; itemp = itemp->next) {
384-
std2 = gen_finalization_for_sym(itemp->t.sptr, gbl.exitstd, 0);
385-
}
386-
gbl.exitstd = std2;
387-
388-
if (sem.type_initialize) {
389-
int std;
390-
for (std = ENTSTDG(gbl.currsub); STD_LINENO(std) == 0;
391-
std = STD_NEXT(std))
392-
;
393-
std = STD_PREV(std);
394-
for (itemp = sem.type_initialize; itemp; itemp = itemp->next) {
395-
gen_type_initialize_for_sym(itemp->t.sptr, std, 0, 0);
396-
}
397-
}
398-
for (itemp = sem.alloc_mem_initialize; itemp; itemp = itemp->next) {
399-
gen_alloc_mem_initialize_for_sym(itemp->t.sptr, ENTSTDG(gbl.currsub));
400-
}
385+
for (itemp = sem.alloc_mem_initialize; itemp; itemp = itemp->next) {
386+
int stdx = CONSTRUCTSYMG(itemp->t.sptr) ?
387+
BLOCK_ENTRY_STD(itemp->t.sptr) : ENTSTDG(gbl.currsub);
388+
gen_alloc_mem_initialize_for_sym(itemp->t.sptr, stdx);
389+
}
390+
391+
for (itemp = sem.auto_dealloc; itemp; itemp = itemp->next) {
392+
int stdx = CONSTRUCTSYMG(itemp->t.sptr) ?
393+
STD_PREV(BLOCK_EXIT_STD(itemp->t.sptr)) : gbl.exitstd;
394+
gen_conditional_dealloc_for_sym(itemp->t.sptr, stdx);
395+
}
396+
397+
for (itemp = sem.auto_finalize; itemp; itemp = itemp->next) {
398+
int stdx = CONSTRUCTSYMG(itemp->t.sptr) ?
399+
STD_PREV(BLOCK_EXIT_STD(itemp->t.sptr)) : gbl.exitstd;
400+
gen_finalization_for_sym(itemp->t.sptr, stdx, 0);
401401
}
402402

403403
#if DEBUG
@@ -676,41 +676,41 @@ gen_early_bnd_dependencies(int ast)
676676
if (!ast)
677677
return;
678678

679-
std = ENTSTDG(
680-
gbl.currsub); /* insert dependencies before dependent bnds exprs */
681679
switch (A_TYPEG(ast)) {
682680
case A_ID:
683681
sptr = A_SPTRG(ast);
684-
if (STYPEG(sptr) == ST_ARRAY && ADJARRG(sptr) && !ERLYSPECG(sptr)) {
682+
/* insert dependencies before dependent bnds exprs */
683+
std = CONSTRUCTSYMG(sptr) ? BLOCK_ENTRY_STD(sptr) : ENTSTDG(gbl.currsub);
684+
if (STYPEG(sptr) == ST_ARRAY && ADJARRG(sptr) && !EARLYSPECG(sptr)) {
685685
ad = AD_DPTR(DTYPEG(sptr));
686686
ndims = AD_NUMDIM(ad);
687687
for (i = 0; i < ndims; i++) {
688688
if (A_TYPEG(AD_LWAST(ad, i)) != A_CNST) {
689689
bndsptr = A_SPTRG(AD_LWAST(ad, i));
690-
if (!ERLYSPECG(bndsptr)) {
690+
if (!EARLYSPECG(bndsptr)) {
691691
std = add_stmt_after(
692692
mk_assn_stmt(AD_LWAST(ad, i), AD_LWBD(ad, i), astb.bnd.dtype),
693693
std);
694-
ERLYSPECP(bndsptr, 1);
694+
EARLYSPECP(bndsptr, 1);
695695
gen_early_bnd_dependencies(AD_LWBD(ad, i));
696696
}
697697
early_spec_gend = TRUE;
698698
}
699699
if (A_TYPEG(AD_UPAST(ad, i)) != A_CNST) {
700700
bndsptr = A_SPTRG(AD_UPAST(ad, i));
701-
if (!ERLYSPECG(bndsptr)) {
701+
if (!EARLYSPECG(bndsptr)) {
702702
std = add_stmt_after(
703703
mk_assn_stmt(AD_UPAST(ad, i), AD_UPBD(ad, i), astb.bnd.dtype),
704704
std);
705-
ERLYSPECP(bndsptr, 1);
705+
EARLYSPECP(bndsptr, 1);
706706
gen_early_bnd_dependencies(AD_UPBD(ad, i));
707707
}
708708
early_spec_gend = TRUE;
709709
}
710710
}
711711
}
712712
if (ADJLENG(sptr)) {
713-
if (!ERLYSPECG(sptr)) {
713+
if (!EARLYSPECG(sptr)) {
714714
int rhs, cvlen;
715715
dtype = DDTG(DTYPEG(sptr));
716716
if (!CVLENG(sptr)) {
@@ -723,12 +723,12 @@ gen_early_bnd_dependencies(int ast)
723723
std = add_stmt_after(
724724
mk_assn_stmt(mk_id(CVLENG(sptr)), rhs, DTYPEG(cvlen)), std);
725725
add_to_early_bnd_list(rhs);
726-
ERLYSPECP(CVLENG(sptr), 1);
726+
EARLYSPECP(CVLENG(sptr), 1);
727727
}
728728
early_spec_gend = TRUE;
729729
}
730730
if (early_spec_gend) {
731-
ERLYSPECP(sptr, 1);
731+
EARLYSPECP(sptr, 1);
732732
}
733733
break;
734734
case A_FUNC:
@@ -754,7 +754,7 @@ gen_early_bnd_dependencies(int ast)
754754
static void
755755
gen_early_str_len()
756756
{
757-
int sptr;
757+
SPTR sptr;
758758
int ast;
759759
int std;
760760
int dtype;
@@ -778,11 +778,16 @@ gen_early_str_len()
778778
rhs = DTY(dtype + 1);
779779
rhs = mk_convert(rhs, DTYPEG(cvlen));
780780
rhs = ast_intr(I_MAX, DTYPEG(cvlen), 2, rhs, mk_cval(0, DTYPEG(cvlen)));
781-
entry_point = add_stmt_after(
782-
mk_assn_stmt(mk_id(CVLENG(sptr)), rhs, DTYPEG(cvlen)), entry_point);
781+
if (CONSTRUCTSYMG(sptr))
782+
(void)add_stmt_before(
783+
mk_assn_stmt(mk_id(CVLENG(sptr)), rhs, DTYPEG(cvlen)),
784+
BLOCK_ENDPROLOG_STD(sptr));
785+
else
786+
entry_point = add_stmt_after(
787+
mk_assn_stmt(mk_id(CVLENG(sptr)), rhs, DTYPEG(cvlen)), entry_point);
783788
add_to_early_bnd_list(rhs);
784-
ERLYSPECP(sptr, 1);
785-
ERLYSPECP(CVLENG(sptr), 1);
789+
EARLYSPECP(sptr, 1);
790+
EARLYSPECP(CVLENG(sptr), 1);
786791
}
787792
}
788793
for (i = erly_bnds_depd.avl; i; --i) {
@@ -805,31 +810,41 @@ gen_early_array_bnds(int sptr)
805810
int bndsptr;
806811
bndsptr = A_SPTRG(AD_LWAST(ad, i));
807812
if (early_specification_stmt_needed(AD_LWBD(ad, i))) {
808-
if (!ERLYSPECG(bndsptr)) {
809-
entry_point = add_stmt_after(
810-
mk_assn_stmt(AD_LWAST(ad, i), AD_LWBD(ad, i), astb.bnd.dtype),
811-
entry_point);
813+
if (!EARLYSPECG(bndsptr)) {
814+
if (CONSTRUCTSYMG(sptr))
815+
(void)add_stmt_before(
816+
mk_assn_stmt(AD_LWAST(ad, i), AD_LWBD(ad, i), astb.bnd.dtype),
817+
BLOCK_ENDPROLOG_STD(sptr));
818+
else
819+
entry_point = add_stmt_after(
820+
mk_assn_stmt(AD_LWAST(ad, i), AD_LWBD(ad, i), astb.bnd.dtype),
821+
entry_point);
812822
add_to_early_bnd_list(AD_LWBD(ad, i));
813-
ERLYSPECP(bndsptr, 1);
823+
EARLYSPECP(bndsptr, 1);
814824
}
815825
AD_LWBD(ad, i) = AD_LWAST(ad, i);
816826
early_bnd_emitted = TRUE;
817827
}
818828
bndsptr = A_SPTRG(AD_UPAST(ad, i));
819829
if (early_specification_stmt_needed(AD_UPBD(ad, i))) {
820-
if (!ERLYSPECG(bndsptr)) {
821-
entry_point = add_stmt_after(
822-
mk_assn_stmt(AD_UPAST(ad, i), AD_UPBD(ad, i), astb.bnd.dtype),
823-
entry_point);
830+
if (!EARLYSPECG(bndsptr)) {
831+
if (CONSTRUCTSYMG(sptr))
832+
(void)add_stmt_before(
833+
mk_assn_stmt(AD_UPAST(ad, i), AD_UPBD(ad, i), astb.bnd.dtype),
834+
BLOCK_ENDPROLOG_STD(sptr));
835+
else
836+
entry_point = add_stmt_after(
837+
mk_assn_stmt(AD_UPAST(ad, i), AD_UPBD(ad, i), astb.bnd.dtype),
838+
entry_point);
824839
add_to_early_bnd_list(AD_UPBD(ad, i));
825-
ERLYSPECP(bndsptr, 1);
840+
EARLYSPECP(bndsptr, 1);
826841
}
827842
AD_UPBD(ad, i) = AD_UPAST(ad, i);
828843
early_bnd_emitted = TRUE;
829844
}
830845
}
831846
if (early_bnd_emitted) {
832-
ERLYSPECP(sptr, 1);
847+
EARLYSPECP(sptr, 1);
833848
}
834849
for (i = erly_bnds_depd.avl; i; --i) {
835850
gen_early_bnd_dependencies(erly_bnds_depd.base[i - 1]);
@@ -871,6 +886,10 @@ add_bound_assignments(int sym)
871886
int tmp;
872887
int zbaseast;
873888
int insertstd = 0;
889+
int save_entry_point = entry_point;
890+
891+
if (CONSTRUCTSYMG(sym))
892+
entry_point = STD_PREV(BLOCK_ENDPROLOG_STD(sym));
874893

875894
dtype = DTYPEG(sym);
876895
ad = AD_DPTR(dtype);
@@ -932,6 +951,9 @@ add_bound_assignments(int sym)
932951
ast_visit(tmp, tmp); /* mark id ast as visited */
933952
}
934953
}
954+
955+
if (CONSTRUCTSYMG(sym))
956+
entry_point = save_entry_point;
935957
}
936958

937959
static void

0 commit comments

Comments
 (0)