Fix decimal constant bug occuring when several programs in a COBOL file

cobc/ChangeLog

@@ -1,4 +1,11 @@
 
+2023-10-17  David Declerck <[email protected]>
+
+	* codegen.c (codegen_internal, codegen_finalize): move declaration
+	  of decimal constants from global storage to local storage to
+	  fix bug #917 (segfault on decimal constant after CANCEL on
+	  subprogram)
+
 2023-07-26  Simon Sobisch <[email protected]>
 
 	* typeck.c (search_set_keys): improving SEARCH ALL syntax checks

cobc/codegen.c

@@ -13926,6 +13926,29 @@ codegen_internal (struct cb_program *prog, const int subsequent_call)
 		/* Switch to main storage file */
 		output_target = cb_storage_file;
 	}
+
+	/* Decimal constants */
+	{
+		struct literal_list* m = literal_cache;
+		int comment_gen = 0;
+		for (; m; m = m->next) {
+			if (CB_TREE_CLASS (m->x) == CB_CLASS_NUMERIC
+			 && m->make_decimal) {
+				if (!comment_gen) {
+					comment_gen = 1;
+					output_local ("\n/* Decimal constants */\n");
+				}
+				output_local ("static\tcob_decimal\t%s%d;\n",
+						CB_PREFIX_DEC_FIELD, m->id);
+				output_local ("static\tcob_decimal\t*%s%d = NULL;\n",
+						CB_PREFIX_DEC_CONST, m->id);
+			}
+		}
+		if (comment_gen) {
+			output_local ("\n");
+		}
+	}
+
 }
 
 void
@@ -13965,28 +13988,6 @@ codegen_finalize (void)
 		}
 	}
 
-	/* Decimal constants */
-	{
-		struct literal_list* m;
-		int comment_gen = 0;
-		for (m = literal_cache; m; m = m->next) {
-			if (CB_TREE_CLASS (m->x) == CB_CLASS_NUMERIC
-			 && m->make_decimal) {
-				if (!comment_gen) {
-					comment_gen = 1;
-					output_storage ("\n/* Decimal constants */\n");
-				}
-				output_storage ("static\tcob_decimal\t%s%d;\n",
-						CB_PREFIX_DEC_FIELD, m->id);
-				output_storage ("static\tcob_decimal\t*%s%d = NULL;\n",
-						CB_PREFIX_DEC_CONST, m->id);
-			}
-		}
-		if (comment_gen) {
-			output_storage ("\n");
-		}
-	}
-
 	/* Clean up by clearing these */
 	attr_cache = NULL;
 	literal_cache = NULL;

tests/testsuite.src/run_misc.at

@@ -14570,3 +14570,63 @@ TST-DECIMAL IS < ZERO-DECIMAL
 
 
 AT_CLEANUP
+
+
+AT_SETUP([Decimal constants and programs in same source])
+AT_KEYWORDS([runmisc INITIAL CANCEL CALL])
+
+# this used to cause a SIGSEGV, see bug #917
+
+AT_DATA([prog.cpy], [
+       IDENTIFICATION DIVISION.
+       PROGRAM-ID. :PROG-NAME: :PROG-KIND:.
+       DATA DIVISION.
+       WORKING-STORAGE SECTION.
+       01  X  PIC 9(2) VALUE 42.
+       01  Y  PIC 9v9  VALUE 0.1.
+       PROCEDURE DIVISION.
+       MAIN.
+      * ensure that cobc cannot optimize the expression away
+           IF FUNCTION CURRENT-DATE = 0
+               ADD 1 TO Y.
+           IF (X + Y) / 42.1 = 1
+               DISPLAY "OK" WITH NO ADVANCING.
+           EXIT PROGRAM.
+       END PROGRAM :PROG-NAME:.
+])
+
+AT_DATA([prog.cob], [
+       IDENTIFICATION DIVISION.
+       PROGRAM-ID. prog.
+       DATA DIVISION.
+       WORKING-STORAGE SECTION.
+       01  X  PIC 9(2) VALUE 0.
+       01  Y  PIC 9v9  VALUE 0.1.
+       PROCEDURE DIVISION.
+       MAIN.
+      * ensure that cobc cannot optimize the expression away
+           IF FUNCTION CURRENT-DATE = 0
+               ADD 1 TO Y.
+           CALL "nested_init"
+           CALL "nonnested_init"
+           CALL "nested_noninit"
+           CANCEL "nested_noninit"
+           CALL "nonnested_noninit"
+           CANCEL "nonnested_noninit"
+           IF X + Y + 42.1 <> 0
+               DISPLAY "OK" WITH NO ADVANCING.
+           STOP RUN.
+       COPY prog REPLACING ==:PROG-NAME:== BY ==nested_init==
+                           ==:PROG-KIND:== BY ==INITIAL==.
+       COPY prog REPLACING ==:PROG-NAME:== BY ==nested_noninit==
+                           ==:PROG-KIND:== BY ====.
+       END PROGRAM prog.
+       COPY prog REPLACING ==:PROG-NAME:== BY ==nonnested_init==
+                           ==:PROG-KIND:== BY ==INITIAL==.
+       COPY prog REPLACING ==:PROG-NAME:== BY ==nonnested_noninit==
+                           ==:PROG-KIND:== BY ====.
+])
+
+AT_CHECK([$COMPILE_MODULE prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN prog], [0], [OKOKOKOKOK], [])
+AT_CLEANUP