From cd93d0eb6929f52df34dffd69666d1a6d130d873 Mon Sep 17 00:00:00 2001
From: "James K. Lowden" <jklowden@symas.com>
Date: Sat, 20 Apr 2024 19:29:53 -0400
Subject: [PATCH] introduce named constants in PICTURE
---
gcc/cobol/UAT/testsuite.src/run_regression.at | 8 ++---
gcc/cobol/UAT/testsuite.src/syn_definition.at | 11 +++---
gcc/cobol/cdfval.h | 4 +++
gcc/cobol/parse.y | 34 +++++++++++++++++++
gcc/cobol/scan.l | 13 ++++---
gcc/cobol/scan_ante.h | 6 ++--
gcc/cobol/util.cc | 9 +++--
7 files changed, 65 insertions(+), 20 deletions(-)
diff --git a/gcc/cobol/UAT/testsuite.src/run_regression.at b/gcc/cobol/UAT/testsuite.src/run_regression.at
index d7e99431f18c..09a4ffef889c 100644
--- a/gcc/cobol/UAT/testsuite.src/run_regression.at
+++ b/gcc/cobol/UAT/testsuite.src/run_regression.at
@@ -333,10 +333,10 @@ AT_DATA([prog.cob], [ IDENTIFICATION DIVISION.
DISPLAY VAR1 SPACE VAR2 SPACE VAR3
GOBACK.
])
-AT_CHECK([$COMPILE prog.cob], [1], [], [prog.cob:5: error: '(0)' invalid in PICTURE (ISO 2023 13.18.40.3) at '9(7)V9(0)'
-prog.cob:6: error: '(0)' invalid in PICTURE (ISO 2023 13.18.40.3) at '9(7)V9(0)'
-prog.cob:7: error: '(0)' invalid in PICTURE (ISO 2023 13.18.40.3) at '9(7)V9(0)'
-prog.cob:8: error: '(0)' invalid in PICTURE (ISO 2023 13.18.40.3) at '9(7)V9(0)'
+AT_CHECK([$COMPILE prog.cob], [1], [], [prog.cob:5: error: '(0)' invalid in PICTURE (ISO 2023 13.18.40.3) at '9(0)'
+prog.cob:6: error: '(0)' invalid in PICTURE (ISO 2023 13.18.40.3) at '9(0)'
+prog.cob:7: error: '(0)' invalid in PICTURE (ISO 2023 13.18.40.3) at '9(0)'
+prog.cob:8: error: '(0)' invalid in PICTURE (ISO 2023 13.18.40.3) at '9(0)'
prog.cob:9: 4 errors in DATA DIVISION, compilation ceases at 'PROCEDURE DIVISION'
cobol1: error: failed compiling prog.cob
])
diff --git a/gcc/cobol/UAT/testsuite.src/syn_definition.at b/gcc/cobol/UAT/testsuite.src/syn_definition.at
index 26706ea59d05..3000c2a64850 100644
--- a/gcc/cobol/UAT/testsuite.src/syn_definition.at
+++ b/gcc/cobol/UAT/testsuite.src/syn_definition.at
@@ -465,10 +465,11 @@ prog.cob:40: invalid picture for Alphanumeric-edited at 'NX'
prog.cob:41: invalid picture for Alphanumeric-edited at 'AN'
prog.cob:42: invalid picture for Alphanumeric-edited at 'AZ(3)'
prog.cob:44: invalid picture for Alphanumeric-edited at 'SA'
-prog.cob:67: invalid picture for Alphanumeric-edited at 'X(str-constant)'
-prog.cob:68: invalid picture for Alphanumeric-edited at 'X(float-constant)'
-prog.cob:69: invalid picture for Alphanumeric-edited at 'X(signed-constant)'
-prog.cob:70: invalid picture for Alphanumeric-edited at 'X(unseen-constant)'
+prog.cob:67: error: PICTURE '(str-constant)' requires a CONSTANT value at ')'
+prog.cob:69: error: invalid PICTURE count '(-1.00000000000000000000000000000000E+00)' at ')'
+prog.cob:69: error: invalid PICTURE count '(signed-constant)' at ')'
+prog.cob:69: error: PICTURE count '(-1)' is negative at ')'
+prog.cob:70: error: PICTURE '(unseen-constant)' requires a CONSTANT value at ')'
prog.cob:80: invalid picture for Alphanumeric-edited at '$(integer-constant)'
prog.cob:81: invalid picture for Alphanumeric-edited at '$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$(integer-constant)'
prog.cob:86: error: unimplemented USAGE type: BIT at 'BIT'
@@ -489,7 +490,7 @@ prog.cob:93: error: unimplemented USAGE type: BIT at 'BIT'
prog.cob:93: syntax error at 'BIT'
prog.cob:96: error: unimplemented USAGE type: BIT at 'BIT'
prog.cob:96: syntax error at 'BIT'
-.:97: 43 errors in DATA DIVISION, compilation ceases detected at end of file
+.:97: 44 errors in DATA DIVISION, compilation ceases detected at end of file
cobol1: error: failed compiling prog.cob
])
AT_CLEANUP
diff --git a/gcc/cobol/cdfval.h b/gcc/cobol/cdfval.h
index b99847801eab..aa98e1bd53b4 100644
--- a/gcc/cobol/cdfval.h
+++ b/gcc/cobol/cdfval.h
@@ -32,6 +32,7 @@
#ifndef _CDF_VAL_H_
#define _CDF_VAL_H_
+#include <assert.h>
#include <stdint.h>
#include <stdlib.h>
@@ -78,6 +79,9 @@ struct cdfval_t : public cdfval_base_t {
cdfval_base_t *self(this);
*self = value;
}
+
+ bool is_numeric() const { return ! (off || string); }
+ int64_t as_number() const { assert(is_numeric()); return number; }
};
bool
diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y
index 5be51cf8ee42..ee779e10b88d 100644
--- a/gcc/cobol/parse.y
+++ b/gcc/cobol/parse.y
@@ -3517,6 +3517,10 @@ alphanum_part: ALNUM[picture] count
--$count;
$$.nbyte += $count; // AX9(3) has count 5
}
+ if( $count < 0 ) {
+ yyerrorv("error: PICTURE count '(%d)' is negative", $count );
+ YYERROR;
+ }
}
;
@@ -3530,12 +3534,42 @@ nps: %empty { $$ = 0; }
nine: %empty { $$ = 0; }
| NINES
+ {
+ $$ = $1;
+ if( $$ == 0 ) {
+ yyerror("error: '(0)' invalid in PICTURE (ISO 2023 13.18.40.3)");
+ }
+ }
;
count: %empty { $$ = 0; }
| '(' NUMSTR ')'
{
$$ = numstr2i( $NUMSTR.string, $NUMSTR.radix );
+ if( $$ == 0 ) {
+ yyerror("error: '(0)' invalid in PICTURE (ISO 2023 13.18.40.3)");
+ }
+ }
+ | '(' NAME ')'
+ {
+ auto value = cdf_value($NAME);
+ if( ! (value && value->is_numeric()) ) {
+ yyerrorv("error: PICTURE '(%s)' requires a CONSTANT value", $NAME );
+ YYERROR;
+ }
+ auto e = symbol_field(PROGRAM, 0, $NAME);
+ if( e ) { // verify not floating point with nonzero fraction
+ auto field = cbl_field_of(e);
+ assert(is_literal(field));
+ if( field->data.value != size_t(field->data.value) ) {
+ yyerrorv("error: invalid PICTURE count '(%s)'",
+ field->data.initial );
+ }
+ }
+ $$ = value->as_number();
+ if( $$ <= 0 ) {
+ yyerrorv("error: invalid PICTURE count '(%s)'", $NAME );
+ }
}
;
diff --git a/gcc/cobol/scan.l b/gcc/cobol/scan.l
index 10cb2654caa4..2eb037340894 100644
--- a/gcc/cobol/scan.l
+++ b/gcc/cobol/scan.l
@@ -76,7 +76,7 @@ DOTEOL [[:blank:]]*[.]{BLANK_EOL}
SKIP [[:blank:]]*SKIP[123][[:blank:]]*[.]?{BLANK_EOL}
TITLE [[:blank:]]*TITLE($|[.]|[^\n]*)
-COUNT [(]0*[1-9][0-9]*[)]
+COUNT [(][[:digit:]]+[)]
N9 9+|(9{COUNT})
NP P+|(P{COUNT})
@@ -1149,6 +1149,8 @@ USE({SPC}FOR)? { return USE; }
{ALNUM}/{COUNT} { yy_push_state(picture_count);
yylval.string = strdup(yytext); return picset(ALNUM); }
+ {ALNUM}/[(]{NAME}[)] { yy_push_state(picture_count);
+ yylval.string = strdup(yytext); return picset(ALNUM); }
{ALNUM} { yylval.string = strdup(yytext); return picset(ALNUM); }
{ALPHED} { yylval.string = strdup(yytext); return picset(ALPHED); }
@@ -1166,10 +1168,11 @@ USE({SPC}FOR)? { return USE; }
}
<picture_count>{
- [[:blank:]]+ { /* skip */ }
- [(]/[[:blank:]]*[[:digit:]] { return picset(*yytext); }
- {INTEGER}/[[:blank:]]*[)] { return picset(numstr_of(yytext)); }
- [)] { pop_return picset(*yytext); }
+ [(] { return picset(*yytext); }
+ [)] { pop_return picset(*yytext); }
+ {INTEGER} { return picset(numstr_of(yytext)); }
+ {NAME} { yylval.string = strdup(yytext);
+ return picset(NAME); }
}
<integer_count>{
diff --git a/gcc/cobol/scan_ante.h b/gcc/cobol/scan_ante.h
index 694fef8e3d3c..f114293716bc 100644
--- a/gcc/cobol/scan_ante.h
+++ b/gcc/cobol/scan_ante.h
@@ -376,11 +376,11 @@ static inline int
ndigit(int len) {
char *input = toupper(yytext[0]) == 'V'? yytext + 1 : yytext;
int n = repeat_count(input);
- return n? n : len;
+ return n == -1? len : n;
}
static int
-picset( int ret ) {
+picset( int token ) {
static const char * const eop = orig_picture + sizeof(orig_picture);
char *p = orig_picture + strlen(orig_picture);
@@ -388,7 +388,7 @@ picset( int ret ) {
yyerrorv("PICTURE exceeds maximum size of %zu bytes", sizeof(orig_picture) - 1);
}
snprintf( p, eop - p, "%s", yytext );
- return ret;
+ return token;
}
static inline bool
diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc
index 7c2e63b3e375..f47a43e6d303 100644
--- a/gcc/cobol/util.cc
+++ b/gcc/cobol/util.cc
@@ -201,10 +201,13 @@ int
repeat_count( const char picture[] )
{
char ch;
- int n = 0;
+ int n, count = -1;
- sscanf( picture, "%c(%d)", &ch, &n );
- return n;
+ n = sscanf( picture, "%c(%d)", &ch, &count );
+ if( count <= 0 && 4 < n ) { // parsed count is negative
+ count = 0; // zero is invalid; -1 means no repetition
+ }
+ return count;
}
const char *numed_message;
--
GitLab