diff --git a/gcc/cobol/UAT/bugsuite.src/bugs.at b/gcc/cobol/UAT/bugsuite.src/bugs.at
index 5709380d3b20e3894bd75e58e540be67b6b4122f..c9c13ef337b75bb12daff79cfbe14681c7b7c96a 100644
--- a/gcc/cobol/UAT/bugsuite.src/bugs.at
+++ b/gcc/cobol/UAT/bugsuite.src/bugs.at
@@ -32,3 +32,39 @@ AT_CHECK([$COMPILE prog.cob], [0], [], [])
AT_CHECK([./a.out], [1], [], [])
AT_CLEANUP
+AT_SETUP([Repeated program-id causes a crash])
+AT_KEYWORDS([bugs])
+AT_DATA([prog.cob], [])
+AT_CHECK([$COMPILE prog.cob], [0], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ PROCEDURE DIVISION.
+ DISPLAY "Hi."
+ END PROGRAM prog.
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ PROCEDURE DIVISION.
+ DISPLAY "Hi."
+ END PROGRAM prog.
+], [])
+AT_CHECK([./a.out], [1], [], [])
+AT_CLEANUP
+
+AT_SETUP([Repeated variable name should be an error])
+AT_KEYWORDS([bugs])
+AT_DATA([prog.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 redundant PIC 9.
+ 01 redundant PIC 9.
+ PROCEDURE DIVISION.
+ DISPLAY redundant
+ DISPLAY "Hi".
+ END PROGRAM prog.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([./a.out], [1], [], [])
+AT_CLEANUP
diff --git a/gcc/cobol/UAT/failsuite.src/run_functions.at b/gcc/cobol/UAT/failsuite.src/run_functions.at
index b2489a37159033abc59505271507d6b69de96e03..6cd43f4ae8b692cae9e4eccc369654786022cca2 100644
--- a/gcc/cobol/UAT/failsuite.src/run_functions.at
+++ b/gcc/cobol/UAT/failsuite.src/run_functions.at
@@ -416,7 +416,6 @@ AT_DATA([prog.cob], [
CALL "subprog" USING BY CONTENT
FUNCTION CONCAT("Abc" "D")
STOP RUN.
- END PROGRAM prog. *> bzzt
*> *****************************
IDENTIFICATION DIVISION.
@@ -431,6 +430,7 @@ AT_DATA([prog.cob], [
DISPLAY TESTING
GOBACK.
END PROGRAM subprog.
+ END PROGRAM prog. *> bzzt
])
AT_CHECK([$COMPILE prog.cob], [0], [], [])
@@ -1522,29 +1522,19 @@ AT_CLEANUP
AT_SETUP([FUNCTION LENGTH])
AT_KEYWORDS([functions])
-AT_XFAIL_IF([test "$national" != "ready"])
-
AT_DATA([prog.cob], [
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 X PIC S9(4)V9(4) VALUE -1.5.
- 01 N PIC N(9).
01 TEST-FLD PIC S9(04)V9(02).
PROCEDURE DIVISION.
- MOVE FUNCTION LENGTH ( X )
- TO TEST-FLD
+ MOVE FUNCTION LENGTH ( X ) TO TEST-FLD
IF TEST-FLD NOT = 8
DISPLAY 'LENGTH "00128" wrong: ' TEST-FLD
END-DISPLAY
END-IF
- MOVE FUNCTION LENGTH ( N )
- TO TEST-FLD
- IF TEST-FLD NOT = 9
- DISPLAY 'LENGTH N(9) wrong: ' TEST-FLD
- END-DISPLAY
- END-IF
MOVE FUNCTION LENGTH ( '00128' )
TO TEST-FLD
@@ -1552,40 +1542,25 @@ AT_DATA([prog.cob], [
DISPLAY 'LENGTH "00128" wrong: ' TEST-FLD
END-DISPLAY
END-IF
- * note: we currently do not support items of category boolean...
- *> MOVE FUNCTION LENGTH ( b'100' )
- *> TO TEST-FLD
- *> IF TEST-FLD NOT = 3
- *> DISPLAY 'LENGTH b"100" wrong: ' TEST-FLD
- *> END-DISPLAY
- *> END-IF
+
MOVE FUNCTION LENGTH ( x'a0' )
TO TEST-FLD
IF TEST-FLD NOT = 1
DISPLAY 'LENGTH x"a0" wrong: ' TEST-FLD
END-DISPLAY
END-IF
+
MOVE FUNCTION LENGTH ( z'a0' )
TO TEST-FLD
IF TEST-FLD NOT = 3
DISPLAY 'LENGTH z"a0" wrong: ' TEST-FLD
END-DISPLAY
END-IF
- MOVE FUNCTION LENGTH ( n'a0' )
- TO TEST-FLD
- IF TEST-FLD NOT = 2
- DISPLAY 'LENGTH n"a0" wrong: ' TEST-FLD
- END-DISPLAY
- END-IF
- STOP RUN.
-])
-AT_CHECK([$COMPILE prog.cob], [0], [],
-[prog.cob:7: warning: handling of USAGE NATIONAL is unfinished; implementation is likely to be changed
-prog.cob:48: warning: handling of national literal is unfinished; implementation is likely to be changed
+ STOP RUN.
])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
AT_CLEANUP
@@ -2951,8 +2926,6 @@ AT_CLEANUP
AT_SETUP([FUNCTION SUBSTITUTE-CASE])
AT_KEYWORDS([functions])
-AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
-
AT_DATA([prog.cob], [
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
@@ -2962,7 +2935,8 @@ AT_DATA([prog.cob], [
01 Z PIC X(20).
PROCEDURE DIVISION.
MOVE "ABC111444555defxxabc" TO Y.
- MOVE FUNCTION SUBSTITUTE-CASE (Y "abc" "zz" "55" "666")
+ MOVE FUNCTION SUBSTITUTE (Y anycase "abc" "zz"
+ anycase "55" "666")
TO Z.
IF Z NOT = "zz1114446665defxxzz"
DISPLAY Z
@@ -2977,8 +2951,6 @@ AT_CLEANUP
AT_SETUP([FUNCTION SUBSTITUTE-CASE with reference mod])
AT_KEYWORDS([functions])
-AT_XFAIL_IF([test "$COB_DIALECT" != "gnu"])
-
AT_DATA([prog.cob], [
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
@@ -2988,8 +2960,9 @@ AT_DATA([prog.cob], [
01 Z PIC X(20).
PROCEDURE DIVISION.
MOVE "abc111444555defxxabc" TO Y.
- MOVE FUNCTION SUBSTITUTE-CASE
- ( Y "ABC" "zz" "55" "666" ) (2 : 9)
+ MOVE FUNCTION SUBSTITUTE
+ ( Y anycase "ABC" "zz"
+ anycase "55" "666" ) (2 : 9)
TO Z.
IF Z NOT = "z11144466"
DISPLAY Z
@@ -3577,13 +3550,10 @@ AT_DATA([prog.cob], [
AT_CHECK([$COMPILE prog.cob], [0], [], [])
AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
AT_CLEANUP
-
AT_SETUP([FUNCTION TEST-NUMVAL-F])
AT_KEYWORDS([functions])
-
AT_DATA([prog.cob], [
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
@@ -3610,19 +3580,19 @@ AT_DATA([prog.cob], [
DISPLAY "Test 5 fail"
END-DISPLAY
END-IF.
- IF FUNCTION TEST-NUMVAL-F ("1 +") NOT = 0
+ IF FUNCTION TEST-NUMVAL-F ("1 +") NOT = 3
DISPLAY "Test 6 fail"
END-DISPLAY
END-IF.
- IF FUNCTION TEST-NUMVAL-F ("1 -") NOT = 0
+ IF FUNCTION TEST-NUMVAL-F ("1 -") NOT = 3
DISPLAY "Test 7 fail"
END-DISPLAY
END-IF.
- IF FUNCTION TEST-NUMVAL-F ("1 +-") NOT = 4
+ IF FUNCTION TEST-NUMVAL-F ("1 +-") NOT = 3
DISPLAY "Test 8 fail"
END-DISPLAY
END-IF.
- IF FUNCTION TEST-NUMVAL-F ("1 -+") NOT = 4
+ IF FUNCTION TEST-NUMVAL-F ("1 -+") NOT = 3
DISPLAY "Test 9 fail"
END-DISPLAY
END-IF.
@@ -3634,11 +3604,11 @@ AT_DATA([prog.cob], [
DISPLAY "Test 11 fail"
END-DISPLAY
END-IF.
- IF FUNCTION TEST-NUMVAL-F ("1.1 +") NOT = 0
+ IF FUNCTION TEST-NUMVAL-F ("1.1 +") NOT = 5
DISPLAY "Test 12 fail"
END-DISPLAY
END-IF.
- IF FUNCTION TEST-NUMVAL-F ("1.1 -") NOT = 0
+ IF FUNCTION TEST-NUMVAL-F ("1.1 -") NOT = 5
DISPLAY "Test 13 fail"
END-DISPLAY
END-IF.
@@ -3650,7 +3620,7 @@ AT_DATA([prog.cob], [
DISPLAY "Test 15 fail"
END-DISPLAY
END-IF.
- IF FUNCTION TEST-NUMVAL-F ("1.1 -CR") NOT = 6
+ IF FUNCTION TEST-NUMVAL-F ("1.1 -CR") NOT = 5
DISPLAY "Test 16 fail"
END-DISPLAY
END-IF.
@@ -3666,22 +3636,19 @@ AT_DATA([prog.cob], [
DISPLAY "Test 19 fail"
END-DISPLAY
END-IF.
- IF FUNCTION TEST-NUMVAL-F ("+1.1 E001") NOT = 7
+ IF FUNCTION TEST-NUMVAL-F ("+1.1 E+01") NOT = 0
DISPLAY "Test 20 fail"
END-DISPLAY
END-IF.
STOP RUN.
])
-
AT_CHECK([$COMPILE prog.cob], [0], [], [])
AT_CHECK([$COBCRUN_DIRECT ./a.out], [0], [], [])
-
AT_CLEANUP
AT_SETUP([FUNCTION TRIM])
AT_KEYWORDS([functions])
-
AT_DATA([prog.cob], [
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
@@ -3695,13 +3662,11 @@ AT_DATA([prog.cob], [
END-DISPLAY.
STOP RUN.
])
-
AT_CHECK([$COMPILE prog.cob], [0], [], [])
AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
[a#b.c%d+e$
a#b.c%d+e$
])
-
AT_CLEANUP
diff --git a/gcc/cobol/UAT/testsuite.src/syn_misc.at b/gcc/cobol/UAT/testsuite.src/syn_misc.at
index 564e459cbcbaa2d5cc9222b20984e703a00bc852..791cb5f9dc07c541b80d056d3c79583a7680d748 100644
--- a/gcc/cobol/UAT/testsuite.src/syn_misc.at
+++ b/gcc/cobol/UAT/testsuite.src/syn_misc.at
@@ -477,12 +477,12 @@ AT_DATA([prog2.cob], [
.
])
AT_CHECK([$COMPILE_ONLY prog.cob], [1], [],
-[prog.cob:7: ANY LENGTH valid only for 01 in LIKAGE SECTION of a contained program at 'LENGTH'
+[prog.cob:7: ANY LENGTH valid only for 01 in LINKAGE SECTION of a contained program at 'LENGTH'
prog.cob:9: 1 errors in DATA DIVISION, compilation ceases at 'PROCEDURE DIVISION'
cobol1: error: failed compiling prog.cob
])
AT_CHECK([$COMPILE_ONLY prog2.cob], [1], [],
-[prog2.cob:7: ANY LENGTH valid only for 01 in LIKAGE SECTION of a contained program at 'LENGTH'
+[prog2.cob:7: ANY LENGTH valid only for 01 in LINKAGE SECTION of a contained program at 'LENGTH'
prog2.cob:9: 1 errors in DATA DIVISION, compilation ceases at 'PROCEDURE DIVISION'
cobol1: error: failed compiling prog2.cob
])
@@ -505,7 +505,7 @@ AT_DATA([prog.cob], [
])
AT_CHECK([$COMPILE_ONLY prog.cob], [1], [],
-[prog.cob:7: ANY LENGTH valid only for 01 in LIKAGE SECTION of a contained program at 'LENGTH'
+[prog.cob:7: ANY LENGTH valid only for 01 in LINKAGE SECTION of a contained program at 'LENGTH'
prog.cob:9: 1 errors in DATA DIVISION, compilation ceases at 'PROCEDURE DIVISION'
cobol1: error: failed compiling prog.cob
])
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index db96951322f8edce3166ff822fbcfa105fc04864..7967f894c290712791a3fb16ed7f46688238dbbc 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -3233,7 +3233,8 @@ enter_program_common(const char *funcname, const char *funcname_)
}
void
-parser_enter_program(const char *funcname_)
+parser_enter_program( const char *funcname_,
+ bool is_function) // True for user-defined-function
{
// The first thing we have to do is mangle this name. This is safe even
// though the end result will be mangled again, because the mangler doesn't
@@ -3262,18 +3263,21 @@ parser_enter_program(const char *funcname_)
SHOW_PARSE_END
}
- if( next_program_is_main )
+ if( !is_function )
{
- next_program_is_main = false;
- if(main_entry_point)
+ if( next_program_is_main )
{
- build_main_that_calls_something(main_entry_point);
- free(main_entry_point);
- main_entry_point = NULL;
- }
- else
- {
- build_main_that_calls_something(funcname);
+ next_program_is_main = false;
+ if(main_entry_point)
+ {
+ build_main_that_calls_something(main_entry_point);
+ free(main_entry_point);
+ main_entry_point = NULL;
+ }
+ else
+ {
+ build_main_that_calls_something(funcname);
+ }
}
}
@@ -5448,10 +5452,24 @@ parser_division(cbl_division_t division,
if( args[i].crv == by_value_e )
{
// 'parameter' is the 64-bit value that was placed on the stack
+ cbl_field_t *new_var = args[i].refer.field;
+
+ // We need to allocate memory for it.
+ char achDataName[256];
+ sprintf(achDataName, "..vardata_%lu", sv_data_name_counter++);
+
+ tree array_type = build_array_type_nelts(UCHAR, new_var->data.capacity);
+ tree data_decl_node = gg_define_variable( array_type,
+ achDataName,
+ vs_stack);
+ gg_assign( member(new_var->var_decl_node, "data"),
+ gg_get_address_of(data_decl_node) );
+
+ // And then move it into place
gg_call(VOID,
"__gg__assign_value_from_stack",
2,
- gg_get_address_of(args[i].refer.field->var_decl_node),
+ gg_get_address_of(new_var->var_decl_node),
parameter);
}
else
@@ -8622,7 +8640,42 @@ parser_intrinsic_numval_c( cbl_field_t *f,
cbl_refer_t& currency,
bool anycase,
bool test_numval_c ) // true for TEST-NUMVAL-C
-{}
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+ refer_fill_source(input);
+ refer_fill_source(currency);
+ if( locale || anycase )
+ {
+ gcc_assert(false);
+ }
+ if( test_numval_c )
+ {
+ gg_call(INT,
+ "__gg__test_numval_c",
+ 3,
+ gg_get_address_of(f->var_decl_node),
+ gg_get_address_of(input .refer_decl_node),
+ gg_get_address_of(currency.refer_decl_node));
+ }
+ else
+ {
+ gg_call(INT,
+ "__gg__numval_c",
+ 3,
+ gg_get_address_of(f->var_decl_node),
+ gg_get_address_of(input .refer_decl_node),
+ gg_get_address_of(currency.refer_decl_node));
+ }
+ }
void
parser_intrinsic_subst( cbl_field_t *f,
@@ -10736,9 +10789,9 @@ parser_call( cbl_refer_t name,
arguments[i] = location;
//gg_printf(">>>>>Calling %ld location is %p\n", build_int_cst_type(SIZE_T, i), arguments[i], NULL_TREE);
- // BY REFERENCE variables might -- might! -- be going into an ANY LENGTH
+ // BY REFERENCE variables might be going into an ANY LENGTH
// linkage variable in the called program. So, just in case, we need
- // to provide a length through the global table.
+ // to provide a length through the global table.
gg_assign(gg_array_value(var_decl_call_parameter_lengths, i), length);
break;
}
@@ -10756,6 +10809,11 @@ parser_call( cbl_refer_t name,
gg_memcpy(arguments[i], location, length);
//gg_printf(">>>>>Calling %ld location is %p\n", build_int_cst_type(SIZE_T, i), arguments[i], NULL_TREE);
+
+ // BY CONTENT variables might be going into an ANY LENGTH
+ // linkage variable in the called program. So, just in case, we need
+ // to provide a length through the global table.
+ gg_assign(gg_array_value(var_decl_call_parameter_lengths, i), length);
break;
}
@@ -14187,7 +14245,6 @@ parser_local_add(struct cbl_field_t *new_var )
vs_stack);
gg_assign( member(new_var->var_decl_node, "data"),
gg_get_address_of(data_decl_node) );
-
}
cbl_refer_t wrapper;
wrapper.field = new_var;
diff --git a/gcc/cobol/genapi.h b/gcc/cobol/genapi.h
index ea37e6bf0200f6470879716d6c7fc858b30539d1..cac09aa5ab3f7c57d893747735901e4b9a317634 100644
--- a/gcc/cobol/genapi.h
+++ b/gcc/cobol/genapi.h
@@ -52,7 +52,7 @@ void parser_next_is_main(bool is_main);
void parser_internal_is_ebcdic(bool is_ebcdic);
void parser_division( cbl_division_t division,
cbl_field_t *ret, size_t narg, cbl_ffi_arg_t args[] );
-void parser_enter_program(const char *funcname);
+void parser_enter_program(const char *funcname, bool is_function);
void parser_leave_program();
void parser_accept( struct cbl_refer_t refer, enum special_name_t special_e);
diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y
index 9823bcad38a23a61651c29502ef9ed9a0e3b8c1a..5927ea8c5ca3510c7a0e7286d72cb02c5eac5ac9 100644
--- a/gcc/cobol/parse.y
+++ b/gcc/cobol/parse.y
@@ -946,7 +946,7 @@ program_id: PROGRAM_ID dot namestr[name] program_as program_attrs[attr] dot
current_division = identification_div_e;
parser_division( identification_div_e, NULL, 0, NULL );
location_set(@1);
- parser_enter_program( name );
+ parser_enter_program( name, false );
if( symbols_begin() == symbols_end() ) {
symbol_table_init();
}
@@ -969,7 +969,7 @@ function_id: FUNCTION '.' NAME program_as program_attrs[attr] '.'
current_division = identification_div_e;
parser_division( identification_div_e, NULL, 0, NULL );
statement_begin(@1, FUNCTION);
- parser_enter_program( $NAME );
+ parser_enter_program( $NAME, true );
if( symbols_begin() == symbols_end() ) {
symbol_table_init();
}
@@ -3016,10 +3016,13 @@ data_descr1: level_name
if( ! ($field->data.capacity + 1 == strlen($field->data.initial) &&
p[-1] == '!') ) {
char *msg;
- asprintf(&msg, "warning: VALUE of %s "
+ if(asprintf(&msg, "warning: VALUE of %s "
"has length %zu, exceeding its size (%u)",
$field->name, strlen($field->data.initial),
- $field->data.capacity);
+ $field->data.capacity) == -1) {
+ warnx("Some kind of error in asprintf() %s %d", __func__, __LINE__);
+ }
+
yywarn(msg);
}
}
@@ -3632,7 +3635,7 @@ any_length: ANY LENGTH
current_data_section == linkage_datasect_e &&
1 < current.program_level()) ) {
yyerror("ANY LENGTH valid only "
- "for 01 in LIKAGE SECTION of a contained program");
+ "for 01 in LINKAGE SECTION of a contained program");
YYERROR;
}
field->attr |= any_length_e;
@@ -8557,7 +8560,7 @@ intrinsic: function_udf
;
| NUMVAL_C '(' varg[r1] numval_locale[r2] anycase ')' {
location_set(@1);
- $$ = new_tempnumeric_float();
+ $$ = new_tempnumeric();
parser_intrinsic_numval_c( $$, *$r1, $r2.is_locale,
*$r2.arg2, $anycase );
}
@@ -8599,7 +8602,7 @@ intrinsic: function_udf
| TEST_NUMVAL_C '(' varg[r1] numval_locale[r2] anycase ')' {
location_set(@1);
- $$ = new_alphanumeric(64);
+ $$ = new_tempnumeric();
parser_intrinsic_numval_c( $$, *$r1, $r2.is_locale,
*$r2.arg2, $anycase, true );
}
@@ -8848,7 +8851,11 @@ intrinsic: function_udf
| intrinsic_locale
;
-numval_locale: %empty { $$.is_locale = false; $$.arg2 = NULL; }
+numval_locale: %empty {
+ static cbl_refer_t empty;
+ $$.is_locale = false;
+ $$.arg2 = ∅
+ }
| LOCALE NAME { $$.is_locale = true; $$.arg2 = NULL;
yyerror("unimplemented: NUMVAL_C LOCALE"); YYERROR;
}
diff --git a/gcc/cobol/parse_util.h b/gcc/cobol/parse_util.h
index 3022e8d9deaa4f1398508e2f5fabf2c771c89237..59093ed807a1e4890af8a07e44d30886968b86c2 100644
--- a/gcc/cobol/parse_util.h
+++ b/gcc/cobol/parse_util.h
@@ -208,9 +208,9 @@ static const intrinsic_args_t intrinsic_args[] = {
{ TEST_DAY_YYYYDDD, "TEST-DAY-YYYYDDD",
"__gg__test_day_yyyyddd", "I", FldNumericBin5 },
{ TEST_FORMATTED_DATETIME, "TEST-FORMATTED-DATETIME",
- "__gg__test_formatted_datetime", "XX", FldAlphanumeric },
+ "__gg__test_formatted_datetime", "XX", FldNumericBin5 },
{ TEST_NUMVAL, "TEST-NUMVAL",
- "__gg__test_numval", "X", FldAlphanumeric },
+ "__gg__test_numval", "X", FldNumericBin5 },
{ TEST_NUMVAL_C, "TEST-NUMVAL-C",
"__gg__test_numval_c", "XXU", FldNumericBin5 },
{ TEST_NUMVAL_F, "TEST-NUMVAL-F",
@@ -245,6 +245,7 @@ static const
intrinsic_args_t *eoargs = intrinsic_args + COUNT_OF(intrinsic_args);
static const char intrinsic_unimplemented[][40] = {
+ "argle-bargle", // gives ::find something to chew on
// "__gg__bit_of",
// "__gg__bit_to_char",
// "__gg__display_of",
diff --git a/libgcobol/intrinsic.cc b/libgcobol/intrinsic.cc
index df98b3433bfb461cbc3d0f3c9ca2dff95d9bffc2..d8ca2eed95ccf03a7ed4e26d8dc87e0a35fea94a 100644
--- a/libgcobol/intrinsic.cc
+++ b/libgcobol/intrinsic.cc
@@ -2030,192 +2030,291 @@ __gg__mod(cblc_field_t *dest, cblc_refer_t *source1, cblc_refer_t *source2)
NULL);
}
-static
-int
+static int
numval(cblc_field_t *dest, cblc_refer_t *input)
{
- size_t errcode = 0;
+ // Returns the one-based character position of a bad character
+ // returns zero if it is okay
+
+ char *p = (char *)input->qual_data;
+ char *pend = p + input->qual_size;
- char *p = (char *)input->qual_data;
- char *pstart = p;
- char *pend = p + input->qual_size;
+ int errpos = 0;
+ __int128 retval = 0;
+ int retval_rdigits = 0;
- _Float128 retval = 0;
- int sign = 0;
- int rdigits = 0;
- int rdigit_bump = 0;
+ bool saw_digit= false;
char decimal_point = __gg__get_decimal_point();
-
- // We will do this as a state machine:
-
- enum
+ bool in_fraction = false;
+ bool leading_sign = false;
+ bool is_negative = false;
+ enum
{
- first_space,
- first_sign,
- before_digits,
- in_digits,
- after_digits,
- second_sign,
- final_space,
- } state = first_space;
+ SPACE1,
+ SPACE2,
+ DIGITS,
+ SPACE3,
+ SPACE4,
+ } state = SPACE1;
+ if( input->qual_size == 0 )
+ {
+ errpos = 1;
+ goto done;
+ }
while( p < pend )
{
char ch = *p++;
+ errpos += 1;
switch( state )
{
- case first_space :
- if( ch != internal_space )
+ case SPACE1:
+ // We tolerate spaces, and expect to end with a sign, digit,
+ // or decimal point:
+ if( ch == internal_space )
{
- state = first_sign;
- p -= 1;
+ continue;
}
- break;
-
- case first_sign :
if( ch == internal_plus )
{
- sign = 1;
- state = before_digits;
+ leading_sign = true;
+ state = SPACE2;
+ break;
}
- else if( ch == internal_minus )
+ if( ch == internal_minus )
{
- sign = -1;
- state = before_digits;
+ leading_sign = true;
+ is_negative = true;
+ state = SPACE2;
+ break;
}
- else if( (ch >= internal_0 && ch <= internal_9)
- || ch == decimal_point )
+ if( ch >= internal_0 && ch <= internal_9 )
{
- state = in_digits;
- p -= 1;
+ saw_digit = true;
+ retval = ch & 0xF;
+ state = DIGITS;
+ break;
}
- else
+ if( ch == decimal_point )
{
- // We have a bad character:
- errcode = p - pstart;
- state = final_space;
- p = pend;
+ in_fraction = true;
+ state = DIGITS;
+ break;
}
+ // This is a bad character; errpos is correct
+ goto done;
break;
- case before_digits :
- if( ch != internal_space )
+ case SPACE2:
+ // We tolerate spaces, and expect to end with a digit or decimal point:
+ if( ch == internal_space )
{
- state = in_digits;
- p -= 1;
+ break;
+ }
+ if( ch >= internal_0 && ch <= internal_9 )
+ {
+ saw_digit = true;
+ retval = ch & 0xF;
+ state = DIGITS;
+ break;
}
+ if( ch == decimal_point )
+ {
+ in_fraction = true;
+ state = DIGITS;
+ break;
+ }
+ // This is a bad character; errpos is correct
+ goto done;
break;
- case in_digits :
- // The only thing allowed here are digits and the decimal separator:
+ case DIGITS:
+ // We tolerate digits. We tolerate one decimal point. We expect to
+ // end with a space, a sign, "DB" or "CR", or the the end of the string
+ // It's a bit complicated
+
if( ch >= internal_0 && ch <= internal_9 )
{
- // We have a digit.
- rdigits += rdigit_bump;
+ saw_digit = true;
retval *= 10;
- retval += ch & 0x0F;
+ retval += ch & 0xF;
+ if( in_fraction )
+ {
+ retval_rdigits += 1;
+ }
+ break;
}
- else if( ch == decimal_point && rdigit_bump)
+ if( ch == decimal_point && in_fraction )
{
- // We have a decimal_point, which is against the rules:
- errcode = p - pstart;
- state = final_space;
- p = pend;
+ // Only one decimal is allowed
+ goto done;
}
- else if( ch == decimal_point )
+ if( ch == decimal_point )
{
- rdigit_bump = 1;
+ in_fraction = true;
+ break;
}
- else
+ if( ch == internal_space )
{
- // We something that isn't a digit or decimal separator:
- state = after_digits;
- p -= 1;
+ state = SPACE3;
+ break;
}
- break;
-
- case after_digits :
- if( ch == internal_space )
+ if( ch == internal_plus && leading_sign)
{
- continue;
+ // We are allowed leading or trailing signs, but not both
+ goto done;
}
- if( sign )
+ if( ch == internal_minus && leading_sign)
{
- // We already saw a sign character
- state = final_space;
+ // We are allowed leading or trailing signs, but not both
+ goto done;
}
- else
+ if( ch == internal_plus )
{
- state = second_sign;
+ state = SPACE4;
+ break;
}
- p -= 1;
+ if( ch == internal_minus )
+ {
+ is_negative = true;
+ state = SPACE4;
+ break;
+ }
+ if( tolower(ch) == 'd' )
+ {
+ if( leading_sign )
+ {
+ goto done;
+ }
+ ch = *p++;
+ errpos += 1;
+ if( p > pend || tolower(ch) != 'b' )
+ {
+ goto done;
+ }
+ is_negative = true;
+ state = SPACE4;
+ break;
+ }
+ if( tolower(ch) == 'c' )
+ {
+ if( leading_sign )
+ {
+ goto done;
+ }
+ ch = *p++;
+ errpos += 1;
+ if( p > pend || tolower(ch) != 'r' )
+ {
+ goto done;
+ }
+ is_negative = true;
+ state = SPACE4;
+ break;
+ }
+ // This is a bad character; errpos is correct
+ goto done;
break;
- case second_sign :
- if( ch == internal_plus )
+ case SPACE3:
+ // We tolerate spaces, or we end with a sign:
+ if( ch == internal_space )
{
- sign = 1;
+ break;
}
- else if( ch == internal_minus )
+ if( ch == internal_plus && leading_sign)
{
- sign = -1;
+ // We are allowed leading or trailing signs, but not both
+ goto done;
}
- else if( (ch == internal_D || ch == internal_d)
- && p < pend
- && (*p == internal_B || *p == internal_b) )
+ if( ch == internal_minus && leading_sign)
{
- sign = -1;
- p += 1;
+ // We are allowed leading or trailing signs, but not both
+ goto done;
}
- else if( (ch == internal_C || ch == internal_c)
- && p < pend
- && (*p == internal_R || *p == internal_r) )
+ if( ch == internal_plus )
{
- sign = -1;
- p += 1;
+ state = SPACE4;
+ break;
}
- else
+ if( ch == internal_minus )
{
- // We have an invalid character
- errcode = p - pstart;
- state = final_space;
- p = pend;
+ is_negative = true;
+ state = SPACE4;
+ break;
}
- state = final_space;
+ if( tolower(ch) == 'd' )
+ {
+ if( leading_sign )
+ {
+ goto done;
+ }
+ ch = *p++;
+ errpos += 1;
+ if( p > pend || tolower(ch) != 'b' )
+ {
+ goto done;
+ }
+ is_negative = true;
+ state = SPACE4;
+ break;
+ }
+ if( tolower(ch) == 'c' )
+ {
+ if( leading_sign )
+ {
+ goto done;
+ }
+ ch = *p++;
+ errpos += 1;
+ if( p > pend || tolower(ch) != 'r' )
+ {
+ goto done;
+ }
+ is_negative = true;
+ state = SPACE4;
+ break;
+ }
+ goto done;
break;
-
- case final_space :
+ case SPACE4:
if( ch == internal_space )
{
- continue;
+ break;
}
- // We have a non-space where there should be only space
- errcode = p - pstart;
- p = pend;
+ goto done;
break;
}
}
- if( sign == 0 )
+ if( saw_digit )
{
- sign = 1;
+ errpos = 0;
}
- retval *= sign;
-
- if( state != after_digits && state != final_space && state != in_digits )
+ else if( p == pend )
{
- errcode = pend - pstart + 1;
+ // If we got to the end without seeing adigit, we need to bump the
+ // error pointer:
+ errpos += 1;
}
- if( dest )
+ done:
+ if(errpos)
{
- retval /= __gg__power_of_ten(rdigits);
-
- __gg__float128_to_field(dest,
- retval,
- truncation_e,
- NULL);
+ retval = 0;
}
- return (int)errcode;
+ if( is_negative )
+ {
+ retval = -retval;
+ }
+ if(dest)
+ {
+ __gg__int128_to_field(dest,
+ retval,
+ retval_rdigits,
+ truncation_e,
+ NULL);
+ }
+ return errpos;
}
static
@@ -2524,7 +2623,23 @@ extern "C"
void
__gg__numval(cblc_field_t *dest, cblc_refer_t *source)
{
- numval(dest, source);
+ int errpos = numval(dest, source);
+ if( errpos )
+ {
+ exception_raise(ec_argument_function_e);
+ }
+ }
+
+extern "C"
+void
+__gg__test_numval(cblc_field_t *dest, cblc_refer_t *source)
+ {
+ int retval = numval(NULL, source);
+ __gg__int128_to_field(dest,
+ retval,
+ NO_RDIGITS,
+ truncation_e,
+ NULL);
}
extern "C"
@@ -2534,6 +2649,18 @@ __gg__numval_c(cblc_field_t *dest, cblc_refer_t *source, cblc_refer_t *currency)
numval_c(dest, source, currency);
}
+extern "C"
+void
+__gg__test_numval_c(cblc_field_t *dest, cblc_refer_t *source, cblc_refer_t *currency)
+ {
+ int retval = numval_c(NULL, source, currency);
+ __gg__int128_to_field(dest,
+ retval,
+ NO_RDIGITS,
+ truncation_e,
+ NULL);
+ }
+
extern "C"
void
__gg__ord(cblc_field_t *dest, cblc_refer_t *input )
@@ -3236,30 +3363,6 @@ __gg__test_day_yyyyddd( cblc_field_t *dest, cblc_refer_t *source)
NULL);
}
-extern "C"
-void
-__gg__test_numval(cblc_field_t *dest, cblc_refer_t *source)
- {
- int retval = numval(NULL, source);
- __gg__int128_to_field(dest,
- retval,
- NO_RDIGITS,
- truncation_e,
- NULL);
- }
-
-extern "C"
-void
-__gg__test_numval_c(cblc_field_t *dest, cblc_refer_t *source, cblc_refer_t *currency)
- {
- int retval = numval_c(NULL, source, currency);
- __gg__int128_to_field(dest,
- retval,
- NO_RDIGITS,
- truncation_e,
- NULL);
- }
-
extern "C"
void
__gg__upper_case(cblc_field_t *dest, cblc_refer_t *input )
@@ -4354,7 +4457,7 @@ floating_format_tester(char const * const f, char * const f_end)
state = DIGITS1;
break;
}
- if( decimal_point )
+ if( ch == decimal_point )
{
state = DIGITS2;
break;
@@ -4493,7 +4596,6 @@ __gg__numval_f( cblc_field_t *dest,
if( error || var->qual_size >= 256 )
{
- fprintf(stderr, " - bad char at %d - ", error);
exception_raise(ec_argument_function_e);
}
else
@@ -4518,6 +4620,23 @@ __gg__numval_f( cblc_field_t *dest,
NULL);
}
+extern "C"
+void
+__gg__test_numval_f(cblc_field_t *dest,
+ cblc_refer_t *var)
+ {
+ char *data = (char * )var->qual_data;
+ char *data_end = data + var->qual_size;
+
+ int error = floating_format_tester(data, data_end);
+
+ __gg__int128_to_field(dest,
+ error,
+ NO_RDIGITS,
+ truncation_e,
+ NULL);
+ }
+
static bool
ismatch(char *a1, char *a2, char *b1, char *b2)
{
diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc
index 98f466625f9507ada3579a831fa5f529f18eb6d3..c4098e8b426c725c707cc35673f21a889fbaa236 100644
--- a/libgcobol/libgcobol.cc
+++ b/libgcobol/libgcobol.cc
@@ -8174,8 +8174,11 @@ __gg__assign_value_from_stack(cblc_field_t *dest, size_t parameter)
case FldGroup:
case FldAlphanumeric:
case FldAlphaEdited:
+ case FldNumericEdited:
if( dest->capacity >= 1)
{
+ warnx("%s is not valid for BY VALUE", dest->name);
+ exit(1);
memset(dest->data, internal_space, dest->capacity);
// A single 8-bit character was placed in the 64-bit entry on the
// stack.
@@ -8206,7 +8209,6 @@ __gg__assign_value_from_stack(cblc_field_t *dest, size_t parameter)
case FldPacked:
case FldNumericBin5:
case FldNumericDisplay:
- case FldNumericEdited:
case FldLiteralN:
case FldIndex:
case FldPointer: