From ebd5ab5ca2cfcb3889d451530a1452ecd8415070 Mon Sep 17 00:00:00 2001
From: Bob Dubner <rdubner@symas.com>
Date: Tue, 2 Jan 2024 14:47:56 -0500
Subject: [PATCH] Recursive user-defined functions with local-storage
---
gcc/cobol/UAT/testsuite.src/run_functions.at | 53 +++++
.../failures/multivariablepasser/Makefile | 1 -
.../failures/multivariablepasser/input.txt | 0
.../failures/multivariablepasser/playpen.cbl | 188 ------------------
.../failures/recursive_function/playpen.cbl | 9 +-
gcc/cobol/genapi.cc | 47 ++---
libgcobol/libgcobol.cc | 5 -
7 files changed, 83 insertions(+), 220 deletions(-)
delete mode 100644 gcc/cobol/failures/multivariablepasser/Makefile
delete mode 100644 gcc/cobol/failures/multivariablepasser/input.txt
delete mode 100644 gcc/cobol/failures/multivariablepasser/playpen.cbl
diff --git a/gcc/cobol/UAT/testsuite.src/run_functions.at b/gcc/cobol/UAT/testsuite.src/run_functions.at
index 5cafe47b235b..1545173ebbfe 100644
--- a/gcc/cobol/UAT/testsuite.src/run_functions.at
+++ b/gcc/cobol/UAT/testsuite.src/run_functions.at
@@ -3762,3 +3762,56 @@ AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [1
], [])
AT_CLEANUP
+AT_SETUP([Recursive FUNCTION with local-storage])
+AT_KEYWORDS([functions parameter])
+AT_DATA([prog.cob], [ IDENTIFICATION DIVISION.
+ FUNCTION-ID. callee.
+ DATA DIVISION.
+ LOCAL-STORAGE SECTION.
+ 01 LCL-X PIC 999 .
+ LINKAGE SECTION.
+ 01 parm PIC 999.
+ 01 retval PIC 999.
+ PROCEDURE DIVISION USING parm RETURNING retval.
+ display "On entry, parm is: " parm
+ move parm to lcl-x
+ move parm to retval
+ subtract 1 from parm
+ if parm > 0
+ display "A The function returns " function callee(parm).
+ if lcl-x not equal to retval
+ display "On exit, lcl-s and retval are: " lcl-x " and " retval
+ display "But they should be equal to each other"
+ end-if
+ goback.
+ end function callee.
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. caller.
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ REPOSITORY.
+ FUNCTION callee.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 val PIC 999 VALUE 5.
+ PROCEDURE DIVISION.
+ DISPLAY "Starting value is: " val
+ display "B The function returns " function callee(val).
+ STOP RUN.
+ end program caller.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [Starting value is: 005
+On entry, parm is: 005
+On entry, parm is: 004
+On entry, parm is: 003
+On entry, parm is: 002
+On entry, parm is: 001
+A The function returns 001
+A The function returns 002
+A The function returns 003
+A The function returns 004
+B The function returns 005
+], [])
+AT_CLEANUP
+
diff --git a/gcc/cobol/failures/multivariablepasser/Makefile b/gcc/cobol/failures/multivariablepasser/Makefile
deleted file mode 100644
index f77e46b3451a..000000000000
--- a/gcc/cobol/failures/multivariablepasser/Makefile
+++ /dev/null
@@ -1 +0,0 @@
-include ../Makefile.inc
diff --git a/gcc/cobol/failures/multivariablepasser/input.txt b/gcc/cobol/failures/multivariablepasser/input.txt
deleted file mode 100644
index e69de29bb2d1..000000000000
diff --git a/gcc/cobol/failures/multivariablepasser/playpen.cbl b/gcc/cobol/failures/multivariablepasser/playpen.cbl
deleted file mode 100644
index 004025a92375..000000000000
--- a/gcc/cobol/failures/multivariablepasser/playpen.cbl
+++ /dev/null
@@ -1,188 +0,0 @@
- IDENTIFICATION DIVISION.
- PROGRAM-ID. "A".
-
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 var1 pic 9 VALUE 1.
- 01 var2 BINARY-CHAR VALUE 22.
- 01 var3 pic s999 COMP-3 VALUE -333.
- 01 var4 pic 9999 BINARY VALUE 4444.
- 01 var5 pic 99.99 VALUE "12.34".
- 01 var6 pic s999V999 COMP-5 VALUE -123.456.
- 01 var7 float-short VALUE 1.23E10.
- 01 var8 float-long VALUE 1.23E20.
- 01 var9 float-extended VALUE 1.23E40.
- 01 var64 pic 9(30) VALUE 987654321098765.
- 01 var128 pic s9(30) VALUE -987654321098765432109876543210.
-
- 01 var1r pic 9 .
- 01 var2r BINARY-CHAR .
- 01 var3r pic s999 COMP-3 .
- 01 var4r pic 9999 BINARY .
- 01 var5r pic 99.99 .
- 01 var6r pic s999V999 COMP-5 .
- 01 var7r float-short .
- 01 var8r float-long .
- 01 var9r float-extended .
- 01 var64r pic 9(30) .
- 01 var128r pic s9(30) .
-
- PROCEDURE DIVISION.
- display var1
- call "rvar1" USING by value var1r RETURNING var1r
- display var1r
-
- display var2
- call "rvar2" USING by value var2r RETURNING var2r
- display var2r
-
- display var3
- call "rvar3" USING by value var3r RETURNING var3r
- display var3r
-
- display var4
- call "rvar4" USING by value var4r RETURNING var4r
- display var4r
-
- display var5
- call "rvar5" USING by value var5r RETURNING var5r
- display var5r
-
- display var6
- call "rvar6" USING by value var6r RETURNING var6r
- display var6r
-
- *> display var7
- *> call "rvar7" USING by value var7r RETURNING var7r
- *> display var7r
- *>
- *> display var8
- *> call "rvar8" USING by value var8r RETURNING var8r
- *> display var8r
- *>
- *> display var9
- *> call "rvar9" USING by value var9r RETURNING var9r
- *> display var9r
-
- display var64
- call "rvar64" USING by value var64r RETURNING var64r
- display var64r
-
- display var128
- call "rvar128" USING by value var128r RETURNING var128r
- display var128r
-
- MOVE ZERO TO RETURN-CODE
- GOBACK.
- END PROGRAM A.
-
-
- IDENTIFICATION DIVISION.
- PROGRAM-ID.rvar1.
- DATA DIVISION.
- LINKAGE SECTION.
- 01 var pic 9 .
- 01 varr pic 9 .
- PROCEDURE DIVISION USING by value varr RETURNING varr.
- MOVE var TO varr.
- END PROGRAM rvar1.
-
- IDENTIFICATION DIVISION.
- PROGRAM-ID.rvar2.
- DATA DIVISION.
- LINKAGE SECTION.
- 01 var BINARY-CHAR .
- 01 varr BINARY-CHAR .
- PROCEDURE DIVISION USING by value varr RETURNING varr.
- MOVE var TO varr.
- END PROGRAM rvar2.
-
- IDENTIFICATION DIVISION.
- PROGRAM-ID.rvar3.
- DATA DIVISION.
- LINKAGE SECTION.
- 01 var pic s999 COMP-3 .
- 01 varr pic s999 COMP-3 .
- PROCEDURE DIVISION USING by value varr RETURNING varr.
- MOVE var TO varr.
- END PROGRAM rvar3.
-
- IDENTIFICATION DIVISION.
- PROGRAM-ID.rvar4.
- DATA DIVISION.
- LINKAGE SECTION.
- 01 var pic 9999 BINARY .
- 01 varr pic 9999 BINARY .
- PROCEDURE DIVISION USING by value varr RETURNING varr.
- MOVE var TO varr.
- END PROGRAM rvar4.
-
- IDENTIFICATION DIVISION.
- PROGRAM-ID.rvar5.
- DATA DIVISION.
- LINKAGE SECTION.
- 01 var pic 99.99 .
- 01 varr pic 99.99 .
- PROCEDURE DIVISION USING by value varr RETURNING varr.
- MOVE var TO varr.
- END PROGRAM rvar5.
-
- IDENTIFICATION DIVISION.
- PROGRAM-ID.rvar6.
- DATA DIVISION.
- LINKAGE SECTION.
- 01 var pic s999V999 COMP-5 .
- 01 varr pic s999V999 COMP-5 .
- PROCEDURE DIVISION USING by value varr RETURNING varr.
- MOVE var TO varr.
- END PROGRAM rvar6.
-
- *> IDENTIFICATION DIVISION.
- *> PROGRAM-ID.rvar7.
- *> DATA DIVISION.
- *> LINKAGE SECTION.
- *> 01 var float-short .
- *> 01 varr float-short .
- *> PROCEDURE DIVISION USING by value varr RETURNING varr.
- *> MOVE var TO varr.
- *> END PROGRAM rvar7.
-
- *> IDENTIFICATION DIVISION.
- *> PROGRAM-ID.rvar8.
- *> DATA DIVISION.
- *> LINKAGE SECTION.
- *> 01 var float-long .
- *> 01 varr float-long .
- *> PROCEDURE DIVISION USING by value varr RETURNING varr.
- *> MOVE var TO varr.
- *> END PROGRAM rvar8.
-
- *> IDENTIFICATION DIVISION.
- *> PROGRAM-ID.rvar9.
- *> DATA DIVISION.
- *> LINKAGE SECTION.
- *> 01 var float-extended .
- *> 01 varr float-extended .
- *> PROCEDURE DIVISION USING by value varr RETURNING varr.
- *> MOVE var TO varr.
- *> END PROGRAM rvar9.
-
- IDENTIFICATION DIVISION.
- PROGRAM-ID.rvar64.
- DATA DIVISION.
- LINKAGE SECTION.
- 01 var pic 9(30) .
- 01 varr pic 9(30) .
- PROCEDURE DIVISION USING by value varr RETURNING varr.
- MOVE var TO varr.
- END PROGRAM rvar64.
-
- IDENTIFICATION DIVISION.
- PROGRAM-ID.rvar128.
- DATA DIVISION.
- LINKAGE SECTION.
- 01 var pic s9(30) .
- 01 varr pic s9(30) .
- PROCEDURE DIVISION USING by value varr RETURNING varr.
- MOVE var TO varr.
- END PROGRAM rvar128.
diff --git a/gcc/cobol/failures/recursive_function/playpen.cbl b/gcc/cobol/failures/recursive_function/playpen.cbl
index ab50a31eec04..80755fc361bd 100644
--- a/gcc/cobol/failures/recursive_function/playpen.cbl
+++ b/gcc/cobol/failures/recursive_function/playpen.cbl
@@ -7,13 +7,16 @@
01 parm PIC 999.
01 retval PIC 999.
PROCEDURE DIVISION USING parm RETURNING retval.
- display "On entry: " parm
+ display "On entry, parm is: " parm
move parm to lcl-x
move parm to retval
subtract 1 from parm
if parm > 0
display "A The function returns " function callee(parm).
- display "On exit: " lcl-x " and " retval
+ if lcl-x not equal to retval
+ display "On exit, lcl-s and retval are: " lcl-x " and " retval
+ display "But they should be equal to each other"
+ end-if
goback.
end function callee.
@@ -27,7 +30,7 @@
WORKING-STORAGE SECTION.
01 val PIC 999 VALUE 5.
PROCEDURE DIVISION.
- DISPLAY val
+ DISPLAY "Starting value is: " val
display "B The function returns " function callee(val).
STOP RUN.
end program caller.
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index 17206fd18842..4b2e3ad75a2d 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -4918,10 +4918,12 @@ parser_exit(void)
rdigits,
NULL,
current_function->returning);
+// gg_printf("KILROY returning %ld\n", gg_cast(LONG, value), NULL_TREE);
gg_memcpy(gg_get_address_of(retval),
gg_get_address_of(value),
build_int_cst_type(SIZE_T, nbytes));
}
+ restore_local_variables();
gg_return(retval);
}
else
@@ -5379,23 +5381,18 @@ parser_division(cbl_division_t division,
// RETURNING variables are supposed to be in the linkage section, which
// means that we didn't assign any storage to them during
// parser_symbol_add(). We do that here.
-
- // We actually create two variables. The first behaves like a LOCAL-STORAGE
- // variable, because we need to handle the possibility of the return value
- // having to survive recursive calls. The second one is static storage; the
- // LOCAL-STORAGE stack variable gets copied to the static one at return time
- // so that the caller isn't trying to copy from a stack variable that has
- // disappeared.
-
- // returning is the stack-based operative variable; returning is the space
- // in static mamory used to actually return the value
+ // returning also needs to behave like local storage, even though it is
+ // in linkage.
+
+ // This counter is used to help keep track of local variables
+ gg_increment(var_decl_unique_prog_id);
if( returning )
{
parser_local_add(returning);
current_function->returning = returning;
}
-
+
// Stash the returning variables for use during parser_return()
current_function->returning = returning;
@@ -5578,9 +5575,6 @@ parser_division(cbl_division_t division,
gg_assign(var_decl_call_parameter_count, build_int_cst_type(INT, A_ZILLION));
}
- // This counter is used to help keep track of local variables
- gg_increment(var_decl_unique_prog_id);
-
gg_call(VOID,
"__gg__pseudo_return_bookmark",
0);
@@ -13156,7 +13150,7 @@ move_helper(cbl_refer_t destref,
size_error);
}
- dont_be_clever:
+ //dont_be_clever:
if( !moved )
{
@@ -14063,7 +14057,7 @@ psa_new_var_decl(cbl_field_t *new_var, const char *external_record_base)
static size_t literal_count = 1;
sprintf(base_name, "%s_%zd", "literal", literal_count++);
}
- else if( new_var->attr & (temporary_e | intermediate_e) )// | linkage_e) )
+ else if( new_var->attr & (temporary_e | intermediate_e) )
{
static size_t temp_count = 1;
sprintf(base_name, "%s_%zd", "_temporary", temp_count++);
@@ -14082,7 +14076,7 @@ psa_new_var_decl(cbl_field_t *new_var, const char *external_record_base)
base_name,
vs_external);
}
- else if( new_var->attr & (temporary_e | intermediate_e) )// | linkage_e) )
+ else if( new_var->attr & (temporary_e | intermediate_e) )
{
new_var_decl = gg_define_variable( cblc_field_type_node,
base_name,
@@ -14108,10 +14102,17 @@ parser_local_add(struct cbl_field_t *new_var )
SHOW_PARSE_END
}
- gg_call(VOID,
- "__gg__push_local_variable",
- 1,
- gg_get_address_of(new_var->var_decl_node));
+ IF( member(new_var->var_decl_node, "data"),
+ ne_op,
+ gg_cast(UCHAR_P, null_pointer_node) )
+ {
+ gg_call(VOID,
+ "__gg__push_local_variable",
+ 1,
+ gg_get_address_of(new_var->var_decl_node));
+ }
+ ELSE
+ ENDIF
if( new_var->level == LEVEL01 || new_var->level == LEVEL77 )
{
@@ -14141,7 +14142,7 @@ parser_symbol_add(struct cbl_field_t *new_var )
// fprintf(stderr, " %s\n", dch);
const char *new_initial = NULL;
-
+
if( !(new_var->attr & initialized_e) )
{
if( is_register_field(new_var) )
@@ -14743,7 +14744,7 @@ parser_symbol_add(struct cbl_field_t *new_var )
free(level_88_string);
}
- if( !(new_var->attr & (linkage_e | based_e)) )
+ if( !(new_var->attr & ( linkage_e | based_e)) )
{
IF( gg_attribute_bit_get(new_var, initialized_e), eq_op, size_t_zero_node )
{
diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc
index 9c335bbee32f..860e460c7215 100644
--- a/libgcobol/libgcobol.cc
+++ b/libgcobol/libgcobol.cc
@@ -6601,11 +6601,6 @@ __gg__display( cblc_refer_t *var,
static size_t display_string_size = MINIMUM_ALLOCATION_SIZE;
static char *display_string = (char *)MALLOC(display_string_size);
- if(strcmp(var->field->name, "arg") == 0 )
- {
- fprintf(stderr, "__gg__display of arg %p\n", var->qual_data);
- }
-
// if( var->qual_data )
// {
format_for_display_internal(&display_string,
--
GitLab