aboutsummaryrefslogtreecommitdiff
path: root/gcc/cobol/parse.y
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/cobol/parse.y')
-rw-r--r--gcc/cobol/parse.y1188
1 files changed, 734 insertions, 454 deletions
diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y
index c6b40fa..74637c9 100644
--- a/gcc/cobol/parse.y
+++ b/gcc/cobol/parse.y
@@ -188,14 +188,14 @@
data_category_t category;
category_map_t replacement;
- init_statement_t( category_map_t replacement )
+ explicit init_statement_t( const category_map_t& replacement )
: to_value(false)
, category(data_category_none)
, replacement(replacement)
{}
- init_statement_t( bool to_value = false )
+ explicit init_statement_t( bool to_value = false )
: to_value(to_value)
, category(data_category_none)
, replacement(category_map_t())
@@ -242,7 +242,7 @@
struct Elem_list_t {
std::list<E> elems;
Elem_list_t() {}
- Elem_list_t( E elem ) {
+ explicit Elem_list_t( E elem ) {
elems.push_back(elem);
}
Elem_list_t * push_back( E elem ) {
@@ -332,7 +332,7 @@
NUMED "NUMERIC-EDITED picture"
NUMED_CR "NUMERIC-EDITED CR picture"
NUMED_DB "NUMERIC-EDITED DB picture"
-%token <number> NINEDOT NINES NINEV PIC_P
+%token <number> NINEDOT NINES NINEV PIC_P ONES
%token <string> SPACES
%token <literal> LITERAL
%token <number> END EOP
@@ -341,7 +341,7 @@
%token <number> NUMBER NEGATIVE
%token <numstr> NUMSTR "numeric literal"
%token <number> OVERFLOW_kw "OVERFLOW"
-%token <computational> COMPUTATIONAL
+%token <computational> BINARY_INTEGER COMPUTATIONAL
%token <boolean> PERFORM BACKWARD
%token <number> POSITIVE
@@ -375,7 +375,7 @@
LSUB "("
PARAMETER_kw "PARAMETER"
OVERRIDE READY RESET
- RSUB ")"
+ RSUB")"
SERVICE_RELOAD "SERVICE RELOAD" STAR_CBL "*CBL"
SUBSCRIPT SUPPRESS TITLE TRACE USE
@@ -573,12 +573,12 @@
THAN TIME TIMES
TO TOP
TOP_LEVEL
- TRACKS TRACK_AREA TRAILING TRANSFORM TRIM TRUE_kw "True" TRY
- TURN TYPE TYPEDEF
+ TRACKS TRACK_AREA TRAILING TRANSFORM TRIM TRUE_kw "True"
+ TRY TURN TYPE TYPEDEF
- ULENGTH UNBOUNDED UNIT UNITS UNIT_RECORD UNTIL UP UPON
- UPOS UPPER_CASE USAGE USING USUBSTR USUPPLEMENTARY
- UTILITY UUID4 UVALID UWIDTH
+ ULENGTH UNBOUNDED UNIT UNITS UNIT_RECORD UNTIL
+ UP UPON UPOS UPPER_CASE USAGE USING
+ USUBSTR USUPPLEMENTARY UTILITY UUID4 UVALID UWIDTH
VALUE VARIANCE VARYING VOLATILE
@@ -659,10 +659,10 @@
%type <number> star_cbl_opt close_how
%type <number> test_before usage_clause1 might_be
-%type <boolean> all optional sign_leading on_off initialized strong
+%type <boolean> all optional sign_leading on_off initialized strong is_signed
%type <number> count data_clauses data_clause
%type <number> nine nines nps relop spaces_etc reserved_value signed
-%type <number> variable_type
+%type <number> variable_type binary_type
%type <number> true_false posneg eval_posneg
%type <number> open_io alphabet_etc
%type <special_type> device_name
@@ -692,7 +692,7 @@
%type <string> fd_name picture_sym name66 paragraph_name
%type <literal> literalism
%type <number> bound advance_when org_clause1 read_next
-%type <number> access_mode multiple lock_how lock_mode
+%type <number> access_mode multiple lock_how lock_mode org_is
%type <select_clauses> select_clauses
%type <select_clause> select_clause access_clause alt_key_clause
assign_clause collate_clause status_clause
@@ -732,7 +732,7 @@
%type <refer> inspected
%type <insp_qual> insp_qual
-%type <insp_match> insp_quals insp_mtquals tally_match
+%type <insp_match> insp_quals insp_mtqual tally_match
%type <insp_replace> x_by_y
%type <insp_oper> replace_oper x_by_ys
%type <insp_oper> tally_forth tally_matches
@@ -801,7 +801,7 @@
%type <switches> upsi_entry
-%type <special> acceptable disp_target
+%type <special> acceptable disp_upon
%type <display> disp_body
%type <false_domain> domains domain
@@ -831,6 +831,9 @@
%type <opt_arith> opt_arith_type
%type <module_type> module_type
+%type <nameloc> repo_func_name
+%type <namelocs> repo_func_names
+
%union {
bool boolean;
int number;
@@ -840,6 +843,8 @@
cbl_field_attr_t field_attr;
ec_type_t ec_type;
ec_list_t* ec_list;
+ cbl_nameloc_t *nameloc;
+ cbl_namelocs_t *namelocs;
declarative_list_t* dcl_list_t;
isym_list_t* isym_list;
struct { radix_t radix; char *string; } numstr;
@@ -880,9 +885,9 @@
struct arith_t *arith;
struct { size_t ntgt; cbl_num_result_t *tgts;
cbl_refer_t *expr; } compute_body_t;
- struct ast_inspect_t *insp_one;
- struct ast_inspect_list_t *insp_all;
- struct ast_inspect_oper_t *insp_oper;
+ struct cbl_inspect_t *insp_one;
+ cbl_inspect_opers_t *insp_all;
+ struct cbl_inspect_oper_t *insp_oper;
struct { bool before; cbl_inspect_qual_t *qual; } insp_qual;
cbl_inspect_t *inspect;
cbl_inspect_match_t *insp_match;
@@ -951,7 +956,7 @@
%printer { fprintf(yyo, "%s'%.*s'{" HOST_SIZE_T_PRINT_UNSIGNED "} %s",
$$.prefix, int($$.len), $$.data, (fmt_size_t)$$.len,
$$.symbol_name()); } <literal>
-%printer { fprintf(yyo, "%s (1st of " HOST_SIZE_T_PRINT_UNSIGNED ")",
+%printer { fprintf(yyo,"%s (1st of" HOST_SIZE_T_PRINT_UNSIGNED")",
$$->targets.empty()? "" : $$->targets.front().refer.field->name,
(fmt_size_t)$$->targets.size() ); } <targets>
%printer { fprintf(yyo, "#" HOST_SIZE_T_PRINT_UNSIGNED ": %s",
@@ -1320,7 +1325,7 @@
return ok;
}
- static void initialize_allocated( cbl_refer_t input );
+ static void initialize_allocated( const cbl_refer_t& input );
static void
initialize_statement( std::list<cbl_num_result_t>& tgts,
bool with_filler,
@@ -1346,8 +1351,16 @@
// more integer friendly. Any integer value that can be expressed in 1
// to MAX_FIXED_POINT_DIGITS digits is converted to a string without a
// decimal point and no exponent.
+
char *pdot = strchr(psz, '.');
+ gcc_assert(pdot);
char *pe = strchr(psz, 'e');
+ if( !pe )
+ {
+ // The most likely cause of this is a "0.0" result.
+ strcpy(psz, "0");
+ return;
+ }
char *pnz = pe-1;
while(*pnz == '0')
{
@@ -1445,6 +1458,7 @@ id_div: cdf_words IDENTIFICATION_DIV '.' program_id
cdf_words: %empty
| cobol_words
+ /* | error { error_msg(@1, "not a COBOL-WORD"); } */
;
cobol_words: cobol_words1
| cobol_words cobol_words1
@@ -1473,7 +1487,7 @@ program_id: PROGRAM_ID dot namestr[name] program_as program_attrs[attr] dot
const char *name = string_of($name);
parser_enter_program( name, false, &main_error );
if( main_error ) {
- error_msg(@name, "PROGRAM-ID 'main' is invalid with -main option");
+ error_msg(@name, "PROGRAM-ID 'main' is invalid with %<-main%> option");
YYERROR;
}
@@ -1509,7 +1523,8 @@ function_id: FUNCTION '.' NAME program_as program_attrs[attr] '.'
int main_error = 0;
parser_enter_program( $NAME, true, &main_error );
if( main_error ) {
- error_msg(@NAME, "FUNCTION-ID 'main' is invalid with -main option");
+ error_msg(@NAME, "FUNCTION-ID %<main%> is invalid "
+ "with %<-main%> option");
YYERROR;
}
if( symbols_begin() == symbols_end() ) {
@@ -1551,7 +1566,7 @@ opt_clause: opt_arith
| opt_entry
| opt_binary
| opt_decimal {
- cbl_unimplementedw("type FLOAT-DECIMAL was ignored");
+ cbl_unimplemented("type FLOAT-DECIMAL");
}
| opt_intermediate
| opt_init
@@ -1580,7 +1595,7 @@ opt_binary: FLOAT_BINARY default_kw is HIGH_ORDER_LEFT
{
cbl_unimplementedw("HIGH-ORDER-LEFT was ignored");
if( ! current.option_binary(cbl_options_t::high_order_left_e) ) {
- error_msg(@3, "unable to set HIGH_ORDER_LEFT");
+ error_msg(@3, "unable to set %<HIGH_ORDER_LEFT%>");
}
}
| FLOAT_BINARY default_kw is HIGH_ORDER_RIGHT[opt]
@@ -1940,7 +1955,7 @@ select_clauses: select_clause { $$.clauses = $1.clause; $$.file = $1.file; }
if( $$.file->nkey++ == 0 ) {
// If no key yet exists, create room for it and the
// present alternate.
- assert($$.file->keys == &cbl_file_t::no_key);
+ assert($$.file->keys == nullptr);
$$.file->keys = new cbl_file_key_t[++$$.file->nkey];
}
{
@@ -1952,8 +1967,7 @@ select_clauses: select_clause { $$.clauses = $1.clause; $$.file = $1.file; }
// Assign the alternate key to the last element,
// and update the pointer.
*alt = $part.file->keys[0];
- delete[] $$.file->keys;
- $$.file->keys = keys;
+ $$.file->keys_update(keys);
}
break;
case assign_clause_e:
@@ -2022,11 +2036,11 @@ select_clauses: select_clause { $$.clauses = $1.clause; $$.file = $1.file; }
YYERROR;
}
if( $$.file->nkey == 0 ) {
+ assert( 1 == $part.file->nkey );
$$.file->nkey = $part.file->nkey;
- $$.file->keys = $part.file->keys;
- } else {
- $$.file->keys[0] = $part.file->keys[0];
- }
+ $$.file->keys = new cbl_file_key_t[1];
+ }
+ $$.file->keys[0] = $part.file->keys[0];
break;
/* case password_clause_e: */
case file_status_clause_e:
@@ -2184,14 +2198,28 @@ org_clause: org_clause1[org]
$$.file->org = static_cast<cbl_file_org_t>($org);
}
;
-org_is: %empty
- | ORGANIZATION is
+org_is: %empty { $$ = 0; }
+ | ORGANIZATION is { $$ = 0; }
+ | ORGANIZATION is RECORD { $$ = RECORD; }
+ | RECORD { $$ = RECORD; }
;
// file_sequential is the proper default
-org_clause1: org_is SEQUENTIAL { $$ = file_sequential_e; }
- | org_is LINE SEQUENTIAL { $$ = file_line_sequential_e; }
- | org_is RELATIVE { $$ = file_relative_e; }
- | org_is INDEXED { $$ = file_indexed_e; }
+org_clause1: org_is SEQUENTIAL {
+ $$ = $1 == RECORD? file_line_sequential_e : file_sequential_e;
+ }
+ | org_is LINE SEQUENTIAL
+ {
+ if( $1 ) error_msg(@2, "syntax error: invalid %<RECORD%>");
+ $$ = file_line_sequential_e;
+ }
+ | org_is RELATIVE {
+ if( $1 ) error_msg(@2, "syntax error: invalid %<RECORD%>");
+ $$ = file_relative_e;
+ }
+ | org_is INDEXED {
+ if( $1 ) error_msg(@2, "syntax error: invalid %<RECORD%>");
+ $$ = file_indexed_e;
+ }
;
/*
@@ -2277,7 +2305,9 @@ config_paragraphs: config_paragraph
config_paragraph:
SPECIAL_NAMES '.'
| SPECIAL_NAMES '.' specials '.'
+ | SOURCE_COMPUTER '.'
| SOURCE_COMPUTER '.' NAME with_debug '.'
+ | OBJECT_COMPUTER '.'
| OBJECT_COMPUTER '.' NAME collating_sequence[name] '.'
{
if( $name ) {
@@ -2288,8 +2318,8 @@ config_paragraph:
}
}
}
- | REPOSITORY '.'
- | REPOSITORY '.' repo_members '.'
+ | REPOSITORY dot
+ | REPOSITORY dot repo_members '.'
;
repo_members: repo_member
@@ -2317,38 +2347,61 @@ repo_expands: %empty
repo_interface: INTERFACE NAME repo_as repo_expands
;
-repo_func: FUNCTION repo_func_names INTRINSIC
- {
- auto namelocs( name_queue.pop() );
- for( const auto& nameloc : namelocs ) {
- current.repository_add(nameloc.name);
+repo_func: FUNCTION repo_func_names[namelocs] INTRINSIC {
+ for( const auto& nameloc : *$namelocs ) {
+ if( 0 == intrinsic_token_of(nameloc.name) ) {
+ error_msg(nameloc.loc,
+ "no such intrinsic function: %qs",
+ nameloc.name);
+ continue;
+ }
+ current.repository_add(nameloc.name);
}
}
| FUNCTION ALL INTRINSIC
{
current.repository_add_all();
}
- | FUNCTION repo_func_names
- ;
-repo_func_names:
- repo_func_name
- | repo_func_names repo_func_name
- ;
-repo_func_name: NAME {
- if( ! current.repository_add($NAME) ) { // add intrinsic by name
- auto token = current.udf_in($NAME);
+ | FUNCTION repo_func_names[namelocs] {
+ // We allow multiple names because GnuCOBOL does. ISO says 1.
+ for( const auto& nameloc : *$namelocs ) {
+ if( 0 != intrinsic_token_of(nameloc.name) ) {
+ error_msg(nameloc.loc,
+ "intrinsic function %qs requires INTRINSIC",
+ nameloc.name);
+ continue;
+ }
+ auto token = current.udf_in(nameloc.name);
if( !token ) {
- error_msg(@NAME, "%s is not defined here as a user-defined function",
- $NAME);
- current.udf_dump();
- YYERROR;
+ error_msg(nameloc.loc,
+ "%s is not defined here as a user-defined function",
+ nameloc.name);
+ continue;
}
- auto e = symbol_function(0, $NAME);
+ auto e = symbol_function(0, nameloc.name);
assert(e);
current.repository_add(symbol_index(e)); // add UDF to repository
}
}
;
+repo_func_names:
+ repo_func_name[name] {
+ $$ = new cbl_namelocs_t(1, *$name);
+ delete $name;
+ }
+ | repo_func_names repo_func_name[name] {
+ $$ = $1;
+ $$->push_back(*$name);
+ delete $name;
+ }
+ ;
+repo_func_name: NAME repo_as {
+ if( ! $repo_as.empty() ) {
+ cbl_unimplemented_at(@repo_as, "%qs", $repo_as.data);
+ }
+ $$ = new cbl_nameloc_t(@NAME, $NAME);
+ }
+ ;
repo_program: PROGRAM_kw NAME repo_as
{
@@ -2380,7 +2433,7 @@ repo_program: PROGRAM_kw NAME repo_as
assert(program);
prog.data.initial = program->name;
}
- auto e = symbol_field_add(PROGRAM, &prog);
+ const auto e = symbol_field_add(PROGRAM, &prog);
symbol_field_location(symbol_index(e), @NAME);
}
;
@@ -2508,23 +2561,14 @@ dev_mnemonic: device_name is NAME
}
| NAME[device] is NAME[name]
{
- static const std::map< std::string, special_name_t > fujitsus
- { // Fujitsu calls these "function names", not device names
- { "ARGUMENT-NUMBER", ARG_NUM_e },
- { "ARGUMENT-VALUE", ARG_VALUE_e } ,
- { "ENVIRONMENT-NAME", ENV_NAME_e },
- { "ENVIRONMENT-VALUE", ENV_VALUE_e },
- };
- std::string device($device);
- std::transform($device, $device + strlen($device),
- device.begin(), toupper);
- auto p = fujitsus.find(device.c_str());
- if( p == fujitsus.end() ) {
- error_msg(@device, "%s is not a device name");
+ auto p = cmd_or_env_special_of($device);
+ if( !p ) {
+ error_msg(@device, "%s is not a device name", $device);
+ YYERROR;
}
- cbl_special_name_t special = { 0, p->second };
- if( !namcpy(@name, special.name, $name) ) YYERROR;
+ cbl_special_name_t special = { 0, *p };
+ namcpy(@name, special.name, $name);
symbol_special_add(PROGRAM, &special);
}
@@ -2591,7 +2635,8 @@ alphabet_seqs: alphabet_seq[seq]
YYERROR;
}
$$->add_sequence(@seq, $seq.low);
- size_t len = $seq.low == nul_string()? 1 : strlen((const char*)$seq.low);
+ size_t len = $seq.low == nul_string()?
+ 1 : strlen((const char*)$seq.low);
assert(len > 0);
$$->add_interval(@seq, $seq.low[--len], $seq.high[0]);
$$->add_sequence(@seq, $seq.high);
@@ -2644,17 +2689,19 @@ alphabet_seq: alphabet_lit[low]
alphabet_etc: alphabet_lit
{
if( $1.len > 1 ) {
- error_msg(@1, "'%c' can be only a single letter", $1.data);
+ error_msg(@1, "%qs can be only a single letter", $1.data);
YYERROR;
}
$$ = (unsigned char)$1.data[0];
}
| spaces_etc {
- // For figurative constants, pass the synmbol table index,
+ // For figurative constants, pass the symbol table index,
// marked with the high bit.
static const auto bits = sizeof($$) * 8 - 1;
- $$ = 1;
- $$ = $$ << bits;
+ unsigned int high_bit = 1L << bits;
+ static_assert(sizeof($$) == sizeof(high_bit),
+ "adjust high_bit to match size of nonterminal target");
+ memcpy(&$$, &high_bit, sizeof($$));
$$ |= constant_index($1);
}
;
@@ -2828,7 +2875,7 @@ domain: all LITERAL[a]
if( ! string_of($value) ) {
yywarn("'%s' has embedded NUL", $value.data);
}
- char *dom = $value.data;
+ const char *dom = $value.data;
$$ = new cbl_domain_t(@value, false, $value.len, dom);
}
| when_set_to FALSE_kw is reserved_value
@@ -2908,7 +2955,7 @@ fd_clause: record_desc
f->varying_size.explicitly = f->varies();
if( f->varying_size.max != 0 ) {
if( !(f->varying_size.min <= f->varying_size.max) ) {
- error_msg(@1, "%zu must be <= %zu",
+ error_msg(@1, "%zu must be less than or equal to %zu",
f->varying_size.min, f->varying_size.max);
YYERROR;
}
@@ -2947,9 +2994,9 @@ fd_clause: record_desc
{
auto f = cbl_file_of(symbol_at(file_section_fd));
f->attr |= external_e;
- cbl_unimplemented("AS LITERAL ");
+ cbl_unimplemented("AS LITERAL");
}
- | fd_linage
+ | fd_linage { cbl_unimplemented("LINAGE"); }
| fd_report {
cbl_unimplemented("REPORT WRITER");
YYERROR;
@@ -2984,7 +3031,7 @@ rec_contains: NUMSTR[min] {
}
$$.max = n;
if( !($$.min < $$.max) ) {
- error_msg(@max, "FROM (%xz) must be less than TO (%zu)",
+ error_msg(@max, "FROM (%zu) must be less than TO (%zu)",
$$.min, $$.max);
YYERROR;
}
@@ -3180,7 +3227,7 @@ field: cdf
}
initial = string_of(field.data.value_of());
if( !initial ) {
- error_msg(@1, xstrerror(errno));
+ error_msg(@1, "could not convert value to string");
YYERROR;
}
char decimal = symbol_decimal_point();
@@ -3286,11 +3333,11 @@ index_field1: ctx_name[name]
field.data = data;
if( !namcpy(@name, field.name, $name) ) YYERROR;
- auto symbol = symbol_field(PROGRAM, 0, $name);
+ auto symbol = symbol_field(PROGRAM, field.parent, $name);
if( symbol ) {
- auto field( cbl_field_of(symbol) );
+ auto f( cbl_field_of(symbol) );
error_msg(@name, "'%s' already defined on line %d",
- field->name, field->line );
+ f->name, f->line );
YYERROR;
}
@@ -3361,9 +3408,11 @@ data_descr: data_descr1
;
const_value: cce_expr
- | BYTE_LENGTH of name { $name->data.set_real_from_capacity(&$$); }
- | LENGTH of name { $name->data.set_real_from_capacity(&$$); }
- | LENGTH_OF of name { $name->data.set_real_from_capacity(&$$); }
+ | BYTE_LENGTH of name { set_real_from_capacity(@name, $name, &$$); }
+ | LENGTH of name { set_real_from_capacity(@name, $name, &$$); }
+ | LENGTH_OF of name { set_real_from_capacity(@name, $name, &$$); }
+ | LENGTH_OF of binary_type[type] {
+ real_from_integer(&$$, VOIDmode, $type, SIGNED); }
;
value78: literalism
@@ -3379,6 +3428,12 @@ value78: literalism
data = build_real (float128_type_node, $1);
$$ = new cbl_field_data_t(data);
}
+ | reserved_value[value]
+ {
+ const auto field = constant_of(constant_index($value));
+ $$ = new cbl_field_data_t(field->data);
+ }
+
| true_false
{
cbl_unimplemented("Boolean constant");
@@ -3412,6 +3467,21 @@ data_descr1: level_name
error_msg(@1, "%s was defined by CDF", field.name);
}
}
+
+ | level_name CONSTANT is_global as reserved_value[value]
+ {
+ cbl_field_t& field = *$1;
+ if( field.level != 1 ) {
+ error_msg(@1, "%s must be an 01-level data item", field.name);
+ YYERROR;
+ }
+ field.attr |= constant_e;
+ if( $is_global ) field.attr |= global_e;
+ field.type = FldLiteralA;
+ auto fig = constant_of(constant_index($value));
+ field.data = fig->data;
+ }
+
| level_name CONSTANT is_global as literalism[lit]
{
cbl_field_t& field = *$1;
@@ -3451,8 +3521,8 @@ data_descr1: level_name
| LEVEL78 NAME[name] VALUE is value78[data]
{
- if( ! dialect_mf() ) {
- dialect_error(@1, "level 78", "mf");
+ if( ! (dialect_mf() || dialect_gnu()) ) {
+ dialect_error(@1, "level 78", "mf or gnu");
YYERROR;
}
struct cbl_field_t field = { 0, FldLiteralA, FldInvalid,
@@ -3611,7 +3681,7 @@ data_descr1: level_name
}
if( field_index($thru) <= field_index($orig) ) {
error_msg(@orig, "cannot RENAME %s %s THRU %s %s "
- "because they're in the wrong order",
+ "because they are in the wrong order",
$orig->level_str(), name_of($orig),
$thru->level_str(), name_of($thru));
YYERROR;
@@ -3653,7 +3723,7 @@ data_descr1: level_name
case FldNumericEdited:
if( $field->has_attr(signable_e) ) {
error_msg(@2, "%s has 'S' in PICTURE, cannot be BLANK WHEN ZERO",
- $field->name, cbl_field_type_str($field->type) );
+ $field->name );
}
break;
default:
@@ -3731,7 +3801,7 @@ data_descr1: level_name
$field->report_invalid_initial_value(@data_clauses);
// verify REDEFINES
- auto parent = parent_of($field);
+ const auto parent = parent_of($field);
if( parent && $field->level == parent->level ) {
valid_redefine(@field, $field, parent); // calls yyerror
}
@@ -3864,10 +3934,10 @@ data_clauses: data_clause
auto redefined = symbol_redefines(field);
if( redefined && redefined->type == FldPointer ) {
if( yydebug ) {
- yywarn("expanding %s size from %u bytes to %zu "
- "because it redefines %s with USAGE POINTER",
+ yywarn("expanding %s size from %u bytes to %wd "
+ "because it redefines %s with %<USAGE POINTER%>",
field->name, field->size(),
- (size_t)int_size_in_bytes(ptr_type_node),
+ int_size_in_bytes(ptr_type_node),
redefined->name);
}
field->embiggen();
@@ -3958,7 +4028,7 @@ picture_clause: PIC signed nps[fore] nines nps[aft]
field->data.capacity = type_capacity(field->type, $4);
field->data.digits = $4;
if( long(field->data.digits) != $4 ) {
- error_msg(@2, "indicated size would be %ld bytes, "
+ error_msg(@2, "indicated size would be %d bytes, "
"maximum data item size is %u",
$4, UINT32_MAX);
}
@@ -4024,15 +4094,16 @@ picture_clause: PIC signed nps[fore] nines nps[aft]
cbl_field_t *field = current_field();
if( field->type == FldNumericBin5 &&
- field->data.capacity == 0 &&
- dialect_mf() )
+ field->data.capacity == 0xFF &&
+ (dialect_gnu() || dialect_mf()) )
{ // PIC X COMP-X or COMP-9
if( ! field->has_attr(all_x_e) ) {
- error_msg(@2, "COMP PICTURE requires all X's or all 9's");
+ error_msg(@2, "COMP PICTURE requires all X%'s or all 9%'s");
YYERROR;
}
} else {
if( !field_type_update(field, FldAlphanumeric, @$) ) {
+ dbgmsg("alnum_pic: %s", field_str(field));
YYERROR;
}
}
@@ -4062,7 +4133,7 @@ picture_clause: PIC signed nps[fore] nines nps[aft]
}
ERROR_IF_CAPACITY(@PIC, field);
if( !is_numeric_edited($picture) ) {
- error_msg(@picture, numed_message);
+ error_msg(@picture, "%s", numed_message);
YYERROR;
}
field->data.picture = $picture;
@@ -4104,7 +4175,13 @@ picture_clause: PIC signed nps[fore] nines nps[aft]
gcc_unreachable();
}
}
+ | PIC ones
;
+ones: ONES
+ {
+ cbl_unimplemented("Boolean type not implemented");
+ }
+ ;
alphanum_pic: alphanum_part {
current_field()->set_attr($1.attr);
@@ -4135,7 +4212,7 @@ alphanum_part: ALNUM[picture] count
$$.nbyte += count; // AX9(3) has count 5
}
if( count < 0 ) {
- error_msg(@2, "PICTURE count '(%d)' is negative", count );
+ error_msg(@2, "PICTURE count %<(%d)%> is negative", count );
YYERROR;
}
}
@@ -4154,7 +4231,7 @@ nine: %empty { $$ = 0; }
{
$$ = $1;
if( $$ == 0 ) {
- error_msg(@1, "'(0)' invalid in PICTURE (ISO 2023 13.18.40.3)");
+ error_msg(@1, "%<(0)%> invalid in PICTURE (ISO 2023 13.18.40.3)");
}
}
;
@@ -4168,14 +4245,14 @@ count: %empty { $$ = 0; }
REAL_VALUE_TYPE rn = numstr2i($NUMSTR.string, $NUMSTR.radix);
$$ = real_to_integer (&rn);
if( $$ == 0 ) {
- error_msg(@2, "'(0)' invalid in PICTURE (ISO 2023 13.18.40.3)");
+ error_msg(@2, "%<0%> invalid in PICTURE (ISO 2023 13.18.40.3)");
}
}
| '(' NAME ')'
{
auto value = cdf_value($NAME);
if( ! (value && value->is_numeric()) ) {
- error_msg(@NAME, "PICTURE '(%s)' requires a CONSTANT value", $NAME );
+ error_msg(@NAME, "PICTURE %qs requires a CONSTANT value", $NAME );
YYERROR;
}
int nmsg = 0;
@@ -4188,13 +4265,13 @@ count: %empty { $$ = 0; }
if( !real_identical (TREE_REAL_CST_PTR (field->data.value_of()),
&vi) ) {
nmsg++;
- error_msg(@NAME, "invalid PICTURE count '(%s)'",
+ error_msg(@NAME, "invalid PICTURE count %<(%s)%>",
field->data.initial );
}
}
$$ = value->as_number();
if( $$ <= 0 && !nmsg) {
- error_msg(@NAME, "invalid PICTURE count '(%s)'", $NAME );
+ error_msg(@NAME, "invalid PICTURE count %<(%s)%>", $NAME );
}
}
;
@@ -4213,8 +4290,99 @@ usage_clause: usage_clause1[type]
}
}
;
-usage_clause1: usage COMPUTATIONAL[comp] native
+usage_clause1: usage BIT
+ {
+ cbl_unimplemented("Boolean type not implemented");
+ }
+| usage BINARY_INTEGER [comp] is_signed
{
+ // action for BINARY_INTEGER is repeated for COMPUTATIONAL, below.
+ // If it changes, consolidate in a function.
+ bool infer = true;
+ cbl_field_t *field = current_field();
+
+ if( ! $is_signed ) {
+ $comp.signable = false;
+ }
+
+ // Some binary types have defined capacity;
+ switch($comp.type) {
+ // COMPUTATIONAL and COMP-5 rely on PICTURE.
+ case FldNumericBinary:
+ field->attr |= big_endian_e;
+ __attribute__((fallthrough));
+ case FldNumericBin5:
+ // If no capacity yet, then no picture, infer $comp.capacity.
+ // If field has capacity, ensure USAGE is compatible.
+ if( field->data.capacity > 0 ) { // PICTURE before USAGE
+ infer = false;
+ switch( field->type ) {
+ case FldAlphanumeric: // PIC X COMP-5 or COMP-X
+ assert( field->data.digits == 0 );
+ assert( field->data.rdigits == 0 );
+ if( (dialect_mf() || dialect_gnu()) ) {
+ field->type = $comp.type;
+ field->clear_attr(signable_e);
+ } else {
+ error_msg(@comp, "numeric USAGE invalid "
+ "with Alpnanumeric PICTURE");
+ dialect_error(@1, "Alpnanumeric COMP-5 or COMP-X", "mf or gnu");
+ YYERROR;
+ }
+ break;
+ case FldNumericDisplay: // PIC 9 COMP-5 or COMP-X
+ if( $comp.capacity == 0xFF ) { // comp-x is a bit like comp-5
+ assert( field->data.digits == field->data.capacity );
+ if( ! (dialect_mf() || dialect_gnu()) ) {
+ dialect_error(@1, "COMP-X", "mf or gnu");
+ }
+ }
+ field->type = $comp.type;
+ field->data.capacity = type_capacity(field->type,
+ field->data.digits);
+ break;
+ default: break;
+ }
+ }
+ break;
+ case FldPacked: // comp-6 is unsigned comp-3
+ assert(! $comp.signable); // else PACKED_DECIMAL from scanner
+ field->attr |= separate_e;
+ if( ! dialect_mf() ) {
+ dialect_error(@1, "COMP-6", "mf");
+ }
+ if( field->type == FldNumericDisplay ) {// PICTURE before USAGE
+ infer = false;
+ assert(field->data.capacity > 0);
+ field->type = $comp.type;
+ field->data.capacity = type_capacity(field->type,
+ field->data.digits);
+ }
+ break;
+ default:
+ break;
+ }
+
+ if( infer ) {
+ if( $comp.capacity > 0 ) {
+ if( field->data.capacity > 0 ) {
+ error_msg(@comp, "%s is BINARY type, incompatible with PICTURE",
+ field->name);
+ YYERROR;
+ }
+ field->data.capacity = $comp.capacity;
+ field->type = $comp.type;
+ if( $comp.signable ) {
+ field->attr = (field->attr | signable_e);
+ }
+ }
+ }
+ $$ = $comp.type;
+ }
+ | usage COMPUTATIONAL[comp] native
+ {
+ // logic below duplicates BINARY_INTEGER, above.
+ // If it changes, consolidate in a function.
bool infer = true;
cbl_field_t *field = current_field();
@@ -4233,20 +4401,21 @@ usage_clause1: usage COMPUTATIONAL[comp] native
case FldAlphanumeric: // PIC X COMP-5 or COMP-X
assert( field->data.digits == 0 );
assert( field->data.rdigits == 0 );
- if( dialect_mf() ) {
+ if( (dialect_mf() || dialect_gnu()) ) {
field->type = $comp.type;
field->clear_attr(signable_e);
} else {
error_msg(@comp, "numeric USAGE invalid "
- "with Alpnanumeric PICTURE");
+ "with Alpnanumeric PICTURE");
+ dialect_error(@1, "Alpnanumeric COMP-5 or COMP-X", "mf or gnu");
YYERROR;
}
break;
case FldNumericDisplay: // PIC 9 COMP-5 or COMP-X
if( $comp.capacity == 0xFF ) { // comp-x is a bit like comp-5
assert( field->data.digits == field->data.capacity );
- if( ! dialect_mf() ) {
- dialect_error(@1, "COMP-X", "mf");
+ if( ! (dialect_mf() || dialect_gnu()) ) {
+ dialect_error(@1, "COMP-X", "mf or gnu");
}
}
field->type = $comp.type;
@@ -4573,7 +4742,7 @@ same_clause: SAME AS name
YYERROR;
}
- auto e = symbol_field_same_as( field, other );
+ const auto e = symbol_field_same_as( field, other );
symbol_field_location( symbol_index(e), @name );
}
;
@@ -4622,7 +4791,7 @@ type_clause: TYPE to typename
{
cbl_field_t *field = current_field();
if( $typename ) {
- auto e = symbol_field_same_as(field, $typename);
+ const auto e = symbol_field_same_as(field, $typename);
symbol_field_location( symbol_index(e), @typename );
}
}
@@ -4634,7 +4803,7 @@ type_clause: TYPE to typename
}
cbl_field_t *field = current_field();
if( $typename ) {
- auto e = symbol_field_same_as(field, $typename);
+ const auto e = symbol_field_same_as(field, $typename);
symbol_field_location( symbol_index(e), @typename );
}
}
@@ -4847,12 +5016,11 @@ statements: statement { $$ = $1; }
statement: error {
if( current.declarative_section_name() ) {
- error_msg(@1, "missing END DECLARATIVES or SECTION name",
- nparse_error);
+ error_msg(@1, "missing END DECLARATIVES or SECTION name");
YYABORT;
}
if( max_errors_exceeded(nparse_error) ) {
- error_msg(@1, "max errors %d reached", nparse_error);
+ error_msg(@1, "max errors %zu reached", nparse_error);
YYABORT;
}
}
@@ -4938,7 +5106,7 @@ accept: accept_body end_accept {
switch( $accept_body.func ) {
case accept_done_e:
error_msg(@ec, "ON EXCEPTION valid only "
- "with ENVIRONMENT or COMAMND-LINE(n)");
+ "with ENVIRONMENT or COMMAND-LINE(n)");
break;
case accept_command_line_e:
if( $1.from->field == NULL ) { // take next command-line arg
@@ -4950,7 +5118,7 @@ accept: accept_body end_accept {
parser_move(*$1.into, *$1.from);
if( $ec.on_error || $ec.not_error ) {
error_msg(@ec, "ON EXCEPTION valid only "
- "with ENVIRONMENT or COMAMND-LINE(n)");
+ "with ENVIRONMENT or COMMAND-LINE(n)");
}
} else {
parser_accept_command_line(*$1.into, *$1.from,
@@ -5147,9 +5315,19 @@ acceptable: device_name
{
$$ = special_of($1);
if( !$$ ) {
- error_msg(@NAME, "no such environment mnemonic name: %s", $NAME);
- YYERROR;
- }
+ const special_name_t *special_type = cmd_or_env_special_of($NAME);
+ if( !special_type ) {
+ error_msg(@NAME, "no such special name '%s'", $NAME);
+ YYERROR;
+ }
+ // Add the name now, as a convenience.
+ cbl_special_name_t special = { 0, *special_type };
+ namcpy(@NAME, special.name, $NAME);
+
+ symbol_elem_t *e = symbol_special_add(PROGRAM, &special);
+ $$ = cbl_special_name_of(e);
+ }
+ assert($$);
}
;
@@ -5266,16 +5444,13 @@ name88: NAME88 {
scalar88: name88 subscripts[subs] refmod[ref]
{
- size_t n = $subs->size();
- auto subscripts = new cbl_refer_t[n];
- $subs->use_list(subscripts);
if( $ref.from->is_reference() || $ref.len->is_reference() ) {
error_msg(@subs, "subscripts on start:len refmod "
"parameters are unsupported");
YYERROR;
}
cbl_span_t span( $ref.from, $ref.len );
- $$ = new cbl_refer_t($1, n, subscripts, span);
+ $$ = new cbl_refer_t($1, $subs->vectorize(), span);
}
| name88 refmod[ref]
{
@@ -5304,7 +5479,7 @@ allocate: ALLOCATE expr[size] CHARACTERS initialized RETURNING scalar[retu
{
statement_begin(@1, ALLOCATE);
if( $size->field->type == FldLiteralN ) {
- auto size = TREE_REAL_CST_PTR ($size->field->data.value_of());
+ const auto size = TREE_REAL_CST_PTR ($size->field->data.value_of());
if( real_isneg(size) || real_iszero(size) ) {
error_msg(@size, "size must be greater than 0");
YYERROR;
@@ -5391,7 +5566,7 @@ display: disp_body end_display
if( $1.vargs->args.size() != 1 ) {
error_msg(@1, "ARGUMENT-NUMBER can be set to only one value");
}
- cbl_refer_t& src( $1.vargs->args.front() );
+ const cbl_refer_t& src( $1.vargs->args.front() );
cbl_field_t *dst = register_find("_ARGI");
parser_move( dst, src );
} else {
@@ -5410,7 +5585,7 @@ display: disp_body end_display
if( $1.vargs->args.size() != 1 ) {
error_msg(@1, "ARGUMENT-NUMBER can be set to only one value");
}
- cbl_refer_t& src( $1.vargs->args.front() );
+ const cbl_refer_t& src( $1.vargs->args.front() );
cbl_field_t *dst = register_find("_ARGI");
parser_move( dst, src );
} else {
@@ -5429,7 +5604,7 @@ disp_body: disp_vargs[vargs]
$$.special = NULL;
$$.vargs = $vargs;
}
- | disp_vargs[vargs] UPON disp_target[special]
+ | disp_vargs[vargs] UPON disp_upon[special]
{
$$.special = $special;
$$.vargs = $vargs;
@@ -5441,17 +5616,25 @@ disp_vargs: DISPLAY vargs {
}
;
-disp_target: device_name {
+disp_upon: device_name {
$$ = symbol_special($1.id);
}
| NAME
{
- symbol_elem_t *e = symbol_special(PROGRAM, $1);
+ symbol_elem_t *e = symbol_special(PROGRAM, $NAME);
if( !e ) {
- error_msg(@NAME, "no such special name '%s'", $NAME);
- YYERROR;
- }
- $$ = cbl_special_name_of(e);
+ const special_name_t *special_type = cmd_or_env_special_of($NAME);
+ if( !special_type ) {
+ error_msg(@NAME, "no such special name '%s'", $NAME);
+ YYERROR;
+ }
+ // Add the name now, as a convenience.
+ cbl_special_name_t special = { 0, *special_type };
+ namcpy(@NAME, special.name, $NAME);
+
+ e = symbol_special_add(PROGRAM, &special);
+ }
+ $$ = cbl_special_name_of(e);
}
;
@@ -5550,7 +5733,8 @@ end_program: end_program1[end] '.'
gcc_unreachable();
}
if( !matches ) {
- error_msg(@end, "END %s %s' does not match IDENTIFICATION DIVISION '%s'",
+ error_msg(@end, "END %s %s does not match "
+ "%<IDENTIFICATION DIVISION %s%>",
token_name, name, prog->name);
YYERROR;
}
@@ -5562,7 +5746,7 @@ end_program: end_program1[end] '.'
}
std::set<std::string> externals = current.end_program();
if( !externals.empty() ) {
- for( auto name : externals ) {
+ for( const auto& name : externals ) {
yywarn("%s calls external symbol '%s'", prog->name, name.c_str());
}
YYERROR;
@@ -5581,9 +5765,9 @@ end_program: end_program1[end] '.'
token_name = "FUNCTION";
break;
default:
- cbl_internal_error( "END token invalid");
+ cbl_internal_error( "%<END%> token invalid");
}
- error_msg(@end, "END %s requires NAME before '.'", token_name);
+ error_msg(@end, "%<END%> %s requires %<NAME%> before %<.%>", token_name);
YYERROR;
}
;
@@ -5657,7 +5841,7 @@ exit_with: %empty
static cbl_refer_t status(rt);
$$ = &status;
}
- auto prog = cbl_label_of(symbol_at(current_program_index()));
+ const auto prog = cbl_label_of(symbol_at(current_program_index()));
if( prog->returning ) {
$$ = new cbl_refer_t( cbl_field_of(symbol_at(prog->returning)) );
}
@@ -6241,17 +6425,17 @@ eval_abbrs: rel_term[a] {
auto& ev( eval_stack.current() );
auto subj( ev.subject() );
if( !subj ) {
- error_msg(@1, "WHEN %s phrase exceeds "
+ error_msg(@1, "WHEN %qs phrase exceeds "
"subject set count of %zu",
- $a.term->name(), ev.subject_count());
+ nice_name_of($a.term->field), ev.subject_count());
YYERROR;
}
if( ! ev.compatible($a.term->field) ) {
auto obj($a.term->field);
error_msg(@1, "subject %s, type %s, "
- "cannot be compared %s, type %s",
- subj->name, 3 + cbl_field_type_str(subj->type),
- obj->name, 3 + cbl_field_type_str(obj->type) );
+ "cannot be compared %s, type %s",
+ subj->name, 3 + cbl_field_type_str(subj->type),
+ obj->name, 3 + cbl_field_type_str(obj->type) );
}
auto result = ev.compare(*$a.term);
if( ! result ) YYERROR;
@@ -6346,7 +6530,7 @@ true_false: TRUE_kw { $$ = TRUE_kw; }
scalar: tableref {
// Check for missing subscript; others already checked.
- if( $1->nsubscript == 0 && 0 < dimensions($1->field) ) {
+ if( $1->nsubscript() == 0 && 0 < dimensions($1->field) ) {
subscript_dimension_error(@1, 0, $$);
}
}
@@ -6357,8 +6541,8 @@ tableref: tableish {
$$ = $1;
$$->loc = @1;
if( $$->is_table_reference() ) {
- if( $$->nsubscript != dimensions($$->field) ) {
- subscript_dimension_error(@1, $$->nsubscript, $$);
+ if( $$->nsubscript() != dimensions($$->field) ) {
+ subscript_dimension_error(@1, $$->nsubscript(), $$);
YYERROR;
}
}
@@ -6634,7 +6818,7 @@ move: MOVE scalar TO move_tgts[tgts]
{
statement_begin(@1, MOVE);
if( $scalar->field->type == FldIndex ) {
- error_msg(@1, "'%s' cannot be MOVEd because it's an INDEX",
+ error_msg(@1, "%qs cannot be MOVEd because it is an %<INDEX%>",
name_of($scalar->field) );
YYERROR;
}
@@ -6907,6 +7091,15 @@ num_value: scalar // might actually be a string
| num_literal { $$ = new_reference($1); }
| ADDRESS OF scalar {$$ = $scalar; $$->addr_of = true; }
| DETAIL OF scalar {$$ = $scalar; }
+ | LENGTH_OF binary_type[size] {
+ location_set(@1);
+ $$ = new cbl_refer_t( new_tempnumeric() );
+ $$->field->clear_attr(signable_e);
+ if( dialect_gcc() ) {
+ dialect_error(@1, "LENGTH OF", "ibm");
+ }
+ parser_set_numeric($$->field, $size);
+ }
| LENGTH_OF name[val] {
location_set(@1);
$$ = new cbl_refer_t( new_tempnumeric() );
@@ -7017,9 +7210,21 @@ section_kw: SECTION
{
if( $1 ) {
if( *$1 == '-' ) {
- error_msg(@1, "SECTION segment %s is negative", $1);
+ error_msg(@1, "SECTION segment %qs is negative", $1);
} else {
- cbl_unimplementedw("SECTION segment %s was ignored", $1);
+ if( dialect_ibm() ) {
+ int sectno;
+ sscanf($1, "%d", &sectno);
+ if( ! (0 <= sectno && sectno <= 99) ) {
+ error_msg(@1, "SECTION segment %qs must be 0-99", $1);
+ } else {
+ if(false) { // stand-in for warning, someday.
+ yywarn("SECTION segment %qs was ignored", $1);
+ }
+ }
+ } else {
+ cbl_unimplemented("SECTION segment %qs is not ISO syntax", $1);
+ }
}
}
}
@@ -7121,6 +7326,15 @@ signed_literal: num_literal
struct cbl_field_t *zero = constant_of(constant_index(ZERO));
parser_subtract( $$, zero, $2, current_rounded_mode() );
}
+ | LENGTH_OF binary_type[size] {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ $$->clear_attr(signable_e);
+ if( dialect_gcc() ) {
+ dialect_error(@1, "LENGTH OF", "ibm");
+ }
+ parser_set_numeric($$, $size);
+ }
| LENGTH_OF name[val] {
location_set(@1);
$$ = new_tempnumeric();
@@ -7375,6 +7589,7 @@ perform_inline: perform_start statements END_PERFORM
}
}
;
+
perform_start: %empty %prec LOCATION {
perform_ec_setup();
$$ = 0;
@@ -7401,18 +7616,7 @@ perform_except: perform_start
perform_ec_finally
END_PERFORM
{
- auto perf = perform_current();
- // produce blob, jumped over by FINALLY paragraph
- size_t iblob = symbol_declaratives_add( PROGRAM, perf->dcls );
- auto lave = perf->ec_labels.new_label(LblParagraph, "lave");
- auto handlers = cbl_field_of(symbol_at(iblob));
-
- // install blob
- parser_label_label(perf->ec_labels.init);
- declarative_runtime_match(handlers, lave);
-
- // uninstall blob
- parser_label_label(perf->ec_labels.fini);
+ cbl_unimplemented("PERFORM Format 3");
}
;
@@ -7430,7 +7634,7 @@ perform_when1: WHEN perform_ec {
std::transform( $perform_ec->elems.begin(),
$perform_ec->elems.end(),
std::back_inserter(perf->dcls),
- []( cbl_declarative_t *p ) {
+ []( const cbl_declarative_t *p ) {
return *p;
} );
ast_enter_paragraph(when);
@@ -7520,12 +7724,12 @@ except_files: except_name[ec] FILE_KW filenames {
perform_ec_other:
%empty %prec WHEN {
- auto& ec_labels( perform_current()->ec_labels );
+ const auto& ec_labels( perform_current()->ec_labels );
ast_enter_paragraph(ec_labels.other);
parser_exit_paragraph();
}
| WHEN OTHER {
- auto& ec_labels( perform_current()->ec_labels );
+ const auto& ec_labels( perform_current()->ec_labels );
ast_enter_paragraph(ec_labels.other);
}
exception statements %prec WHEN {
@@ -7534,12 +7738,12 @@ perform_ec_other:
;
perform_ec_common:
%empty {
- auto& ec_labels( perform_current()->ec_labels );
+ const auto& ec_labels( perform_current()->ec_labels );
ast_enter_paragraph(ec_labels.common);
parser_exit_paragraph();
}
| WHEN COMMON {
- auto& ec_labels( perform_current()->ec_labels );
+ const auto& ec_labels( perform_current()->ec_labels );
ast_enter_paragraph(ec_labels.common);
}
exception statements {
@@ -7548,18 +7752,18 @@ perform_ec_common:
;
perform_ec_finally:
%empty {
- auto& ec_labels( perform_current()->ec_labels );
+ const auto& ec_labels( perform_current()->ec_labels );
ast_enter_paragraph(ec_labels.finally);
parser_exit_paragraph();
parser_label_goto(ec_labels.fini);
}
| FINALLY {
- auto& ec_labels( perform_current()->ec_labels );
+ const auto& ec_labels( perform_current()->ec_labels );
ast_enter_paragraph(ec_labels.finally);
}
exception statements {
parser_exit_paragraph();
- auto& ec_labels( perform_current()->ec_labels );
+ const auto& ec_labels( perform_current()->ec_labels );
parser_label_goto(ec_labels.fini);
}
;
@@ -7690,6 +7894,15 @@ varg1a: ADDRESS OF scalar {
{
$$ = new_reference(constant_of(constant_index($1)));
}
+ | LENGTH_OF binary_type[size] {
+ location_set(@1);
+ $$ = new cbl_refer_t( new_tempnumeric() );
+ $$->field->clear_attr(signable_e);
+ if( dialect_gcc() ) {
+ dialect_error(@1, "LENGTH OF", "ibm");
+ }
+ parser_set_numeric($$->field, $size);
+ }
| LENGTH_OF name[val] {
location_set(@1);
$$ = new cbl_refer_t( new_tempnumeric() );
@@ -7714,6 +7927,10 @@ varg1a: ADDRESS OF scalar {
}
;
+binary_type: BINARY_INTEGER { $$ = $1.capacity; }
+ | COMPUTATIONAL { $$ = $1.capacity; }
+ ;
+
literal: literalism
{
$$ = $1.isymbol()?
@@ -7757,7 +7974,7 @@ raise: RAISE EXCEPTION NAME
"EXCEPTION CONDITION: %s", $NAME);
YYERROR;
}
- cbl_unimplemented("RAISE <EXCEPTION OBJECT>");
+ cbl_unimplemented("RAISE %<EXCEPTION OBJECT%>");
YYERROR;
}
;
@@ -7824,10 +8041,6 @@ read_body: NAME read_next read_into read_key
error_msg(@1, "syntax error? invalid file record name");
YYERROR;
}
- if( 0 && $$->access == file_access_dyn_e && $read_next >= 0 ) {
- error_msg(@1, "sequential DYNAMIC access requires NEXT RECORD");
- YYERROR;
- }
if( $read_key->field && is_sequential($$) ) {
error_msg(@1, "SEQUENTIAL file %s has no KEY", $$->name);
YYERROR;
@@ -7838,7 +8051,7 @@ read_body: NAME read_next read_into read_key
YYERROR;
}
if( $read_key->field && $read_next < 0 ) {
- error_msg(@1, "cannot read NEXT with KEY", $$->name);
+ error_msg(@1, "cannot read NEXT with KEY %qs", $$->name);
YYERROR;
}
@@ -8275,8 +8488,8 @@ merge: MERGE { statement_begin(@1, MERGE); }
USING filenames[inputs] sort_output
{
std::vector <cbl_key_t> keys($sort_keys->key_list.size());
- std::copy( $sort_keys->key_list.begin(),
- $sort_keys->key_list.end(), keys.begin() );
+ std::copy( $sort_keys->key_list.begin(),
+ $sort_keys->key_list.end(), keys.begin() );
size_t ninput = $inputs->files.size();
size_t noutput = $sort_output->nfile();
@@ -8295,8 +8508,7 @@ merge: MERGE { statement_begin(@1, MERGE); }
out_proc = &$sort_output->tgt;
}
- parser_file_merge( $file, $sort_seq,
- keys.size(), keys.empty()? NULL : keys.data(),
+ parser_file_merge( $file, $sort_seq, keys,
ninput, inputs,
noutput, outputs,
out_proc );
@@ -8462,7 +8674,7 @@ set: SET set_tgts[tgts] TO set_operand[src]
class set_conditional {
bool tf;
public:
- set_conditional( int token ) : tf(token == TRUE_kw) {}
+ explicit set_conditional( int token ) : tf(token == TRUE_kw) {}
void operator()(cbl_refer_t& refer) {
if( refer.field->data.false_value_of() == NULL && !tf ) {
auto loc = symbol_field_location(field_index(refer.field));
@@ -8487,7 +8699,7 @@ set_switches: switches TO on_off
{
struct switcheroo {
bitop_t op;
- switcheroo( bool tf ) : op( tf? bit_set_op : bit_clear_op ) {}
+ explicit switcheroo( bool tf ) : op( tf? bit_set_op : bit_clear_op ) {}
switcheroo& operator()(cbl_field_t* sw) {
assert(sw->type == FldSwitch);
assert(sw->data.initial); // not a switch condition
@@ -8627,14 +8839,14 @@ search_terms: search_term
;
search_term: scalar[key] '=' search_expr[sarg]
{
- if( $key->nsubscript == 0 ) {
+ if( $key->nsubscript() == 0 ) {
error_msg(@1, "no index for key");
YYERROR;
}
- if( dimensions($key->field) < $key->nsubscript ) {
+ if( dimensions($key->field) < $key->nsubscript() ) {
error_msg(@1, "too many subscripts: "
- "%zu for table of %zu dimensions",
- $key->nsubscript, dimensions($key->field) );
+ "%u for table of %zu dimensions",
+ $key->nsubscript(), dimensions($key->field) );
YYERROR;
}
@@ -8673,8 +8885,7 @@ sort_table: SORT tableref[table] sort_keys sort_dup sort_seq {
keys.at(i++) = cbl_key_t(k);
}
- parser_sort( *$table, $sort_dup, $sort_seq,
- keys.size(), keys.empty()? NULL : keys.data() );
+ parser_sort( *$table, $sort_dup, $sort_seq, keys );
}
| SORT tableref[table] sort_dup sort_seq {
statement_begin(@1, SORT);
@@ -8684,9 +8895,10 @@ sort_table: SORT tableref[table] sort_keys sort_dup sort_seq {
cbl_key_t
key = cbl_key_t($table->field->occurs.keys[0]),
guess(1, &$table->field);
- ;
- if( key.nfield == 0 ) key = guess;
- parser_sort( *$table, $sort_dup, $sort_seq, 1, &key );
+
+ if( key.fields.empty() ) key = guess;
+ std::vector<cbl_key_t> keys(1, key);
+ parser_sort( *$table, $sort_dup, $sort_seq, keys );
}
;
@@ -8727,7 +8939,7 @@ sort_file: SORT FILENAME[file] sort_keys sort_dup sort_seq
parser_file_sort( file,
$sort_dup,
$sort_seq,
- keys.size(), keys.empty()? NULL : keys.data(),
+ keys,
ninput, inputs,
noutput, outputs,
in_proc, out_proc );
@@ -8919,7 +9131,7 @@ backward: %empty { $$ = false; }
inspect: INSPECT backward inspected TALLYING tallies
{
statement_begin(@1, INSPECT);
- ast_inspect( *$inspected, $backward, *$tallies );
+ ast_inspect( @$, *$inspected, $backward, *$tallies );
}
| INSPECT backward inspected TALLYING tallies REPLACING replacements
{
@@ -8931,8 +9143,8 @@ inspect: INSPECT backward inspected TALLYING tallies
}
statement_begin(@1, INSPECT);
// All tallying is done before any replacing
- ast_inspect( *$inspected, $backward, *$tallies );
- ast_inspect( *$inspected, $backward, *$replacements );
+ ast_inspect( @$, *$inspected, $backward, *$tallies );
+ ast_inspect( @$, *$inspected, $backward, *$replacements );
}
| INSPECT backward inspected REPLACING replacements
{
@@ -8943,11 +9155,11 @@ inspect: INSPECT backward inspected TALLYING tallies
YYERROR;
}
statement_begin(@1, INSPECT);
- ast_inspect( *$inspected, $backward, *$replacements );
+ ast_inspect( @$, *$inspected, $backward, *$replacements );
}
| INSPECT backward inspected CONVERTING alpha_val[match]
TO all alpha_val[replace_oper]
- insp_mtquals[qual]
+ insp_mtqual[qual]
{
if( $all ) {
$replace_oper->all = true;
@@ -8961,6 +9173,19 @@ inspect: INSPECT backward inspected TALLYING tallies
error_msg(@all, "ALL must be part of a figurative constant");
YYERROR;
}
+ } else {
+ cbl_field_t *match = $match->field,
+ *replace = $replace_oper->field;
+ if( is_literal(match) && is_literal(replace) ) {
+ if( !$match->all && !$replace_oper->all) {
+ if( match->data.capacity != replace->data.capacity ) {
+ error_msg(@match, "%qs, size %u NOT EQUAL %qs, size %u",
+ nice_name_of(match), match->data.capacity,
+ nice_name_of(replace), replace->data.capacity);
+ YYERROR;
+ }
+ }
+ }
}
if( is_constant($inspected->field) ) {
auto name = nice_name_of($inspected->field);
@@ -8980,7 +9205,7 @@ inspect: INSPECT backward inspected TALLYING tallies
tallies: { need_nume_set(); } tally
{
- $$ = new ast_inspect_list_t( *$tally );
+ $$ = new cbl_inspect_opers_t( 1, *$tally );
}
| tallies { need_nume_set(); } tally
{
@@ -8990,12 +9215,17 @@ tallies: { need_nume_set(); } tally
if( !next.tally.field ) {
// prior tally swallowed one too many
cbl_inspect_t& prior = $$->back();
- assert(prior.nbound > 0);
- assert(prior.opers);
- cbl_inspect_oper_t& prior_op = prior.opers[prior.nbound - 1];
-
- assert(prior_op.n_identifier_3 > 0 );
- next.tally = prior_op.matches[--prior_op.n_identifier_3].matching;
+ assert(prior.nbound() > 0);
+ cbl_inspect_oper_t& prior_op = prior.back();
+ assert(! prior_op.matches.empty() );
+ assert(prior_op.n_identifier_3() > 0 );
+ cbl_inspect_match_t wrong_match = prior_op.matches.back();
+ dbgmsg("moving overeager tally to next clause");
+ dump_inspect_match(wrong_match);
+ next.tally = wrong_match.premature_tally();
+ if( wrong_match.empty() ) {
+ prior_op.matches.pop_back();
+ }
}
if( !next.tally.field ) {
error_msg(@$, "missing summation field before FOR");
@@ -9007,44 +9237,37 @@ tallies: { need_nume_set(); } tally
/*
* numref might be "empty" only because it was consumed by a
- * prior insp_mtquals, which can end in a scalar. If that
+ * prior insp_mtqual, which can end in a scalar. If that
* happens, the tallies target, above, takes back the borrowed
* scalar and assigns it to be the tally total, as the user
* intended.
*/
tally: numeref[total] FOR tally_fors[fors]
- { // reduce ast_inspect_t to cbl_inspect_t
+ {
if( yydebug && !$total ) {
- error_msg(@FOR, "caution: missing summation field before FOR");
+ dbgmsg("tally: caution: missing summation field before FOR");
}
- cbl_refer_t total( $total? *$total : cbl_refer_t() );
- $$ = new cbl_inspect_t( total, $fors->opers() );
+ $$ = $fors;
+ if( $total ) $$->tally = *$total;
}
;
-tally_fors: tally_forth
- { // reduce ast_inspect_oper_t to cbl_inspect_oper_t
- cbl_inspect_oper_t oper( $1->bound, $1->matches );
- $$ = new ast_inspect_t;
- $$ ->push_back(oper);
- }
- | tally_fors tally_forth
- {
- cbl_inspect_oper_t oper( $2->bound, $2->matches );
- $1 ->push_back(oper);
- }
+tally_fors: tally_forth { $$ = new cbl_inspect_t(1, *$1); }
+ | tally_fors tally_forth { $$->push_back(*$2); $$ = $1; }
;
-tally_forth: CHARACTERS insp_mtquals[q] scalar[next_tally]
+tally_forth: CHARACTERS insp_mtqual[q] scalar[next_tally]
{
// Add ensuing scalar as if it were an argument to CHARACTERS.
// It will be moved to the succeeding FOR as its tally.
- $q->matching = *$next_tally;
- $$ = new ast_inspect_oper_t(*$q);
+ dbgmsg("saving overeager tally for next clause");
+ $q->save_premature_tally(*$next_tally);
+ $$ = new cbl_inspect_oper_t(*$q);
+ dump_inspect_match($$->matches.back());
}
- | CHARACTERS insp_mtquals[q]
+ | CHARACTERS insp_mtqual[q]
{
- $$ = new ast_inspect_oper_t(*$q);
+ $$ = new cbl_inspect_oper_t(*$q);
}
| ALL tally_matches[q]
{ $q->bound = bound_all_e;
@@ -9063,26 +9286,23 @@ tally_forth: CHARACTERS insp_mtquals[q] scalar[next_tally]
}
;
-tally_matches: tally_match { $$ = new ast_inspect_oper_t(*$1); }
+tally_matches: tally_match { $$ = new cbl_inspect_oper_t(*$1); }
| tally_matches tally_match
{ // add to the list of matches for an operand
$1->matches.push_back(*$2);
}
;
-tally_match: alpha_val[matching] insp_mtquals[q]
+tally_match: alpha_val[matching] insp_mtqual[q]
{ // include the matching field with the qualifiers
$$ = $q;
- $$->matching = *$matching;
+ $$->matching(*$matching);
}
;
numeref: %empty { $$ = NULL; need_nume_set(false); }
| nume[name] subscripts[subs]
{
- size_t n = $subs->size();
- auto offsets = new cbl_refer_t[n];
- std::copy( $subs->begin(), $subs->end(), offsets );
- $$ = new cbl_refer_t($name, n, offsets);
+ $$ = new cbl_refer_t($name, $subs->vectorize());
}
| nume { $$ = new cbl_refer_t($nume); }
;
@@ -9112,13 +9332,13 @@ qnume: NUME { name_queue.qualify(@1, $1); }
replacements: replacement
{
- cbl_inspect_t inspect( cbl_refer_t(), $1->opers() );
- $$ = new ast_inspect_list_t(inspect);
+ cbl_inspect_t inspect( cbl_refer_t(), *$1 );
+ $$ = new cbl_inspect_opers_t(1, inspect);
}
;
replacement: replace_oper
{
- $$ = new ast_inspect_t;
+ $$ = new cbl_inspect_t;
$$->push_back( cbl_inspect_oper_t($1->bound, $1->replaces) );
}
| replacement replace_oper
@@ -9126,9 +9346,9 @@ replacement: replace_oper
$$->push_back( cbl_inspect_oper_t($2->bound, $2->replaces) );
}
;
-replace_oper: CHARACTERS BY alpha_val[replace] insp_mtquals[q]
+replace_oper: CHARACTERS BY alpha_val[replace] insp_mtqual[q]
{
- $$ = new ast_inspect_oper_t( cbl_inspect_replace_t(NULL,
+ $$ = new cbl_inspect_oper_t( cbl_inspect_replace_t(NULL,
*$replace,
$q->before,
$q->after) );
@@ -9142,21 +9362,22 @@ replace_oper: CHARACTERS BY alpha_val[replace] insp_mtquals[q]
x_by_ys: x_by_y
{
- $$ = new ast_inspect_oper_t(*$1);
+ $$ = new cbl_inspect_oper_t(*$1);
}
| x_by_ys x_by_y
{
$$->replaces.push_back(*$2);
}
;
-x_by_y: alpha_val[matching] BY alpha_val[replace] insp_mtquals[q]
+x_by_y: alpha_val[matching] BY alpha_val[replace] insp_mtqual[q]
{
$$ = new cbl_inspect_replace_t(*$matching, *$replace,
$q->before, $q->after);
}
;
-insp_mtquals: %empty { $$ = new cbl_inspect_match_t; }
+ /* mt may be "empty": match may have no qualifiers */
+insp_mtqual: %empty { $$ = new cbl_inspect_match_t; }
| insp_quals
;
insp_quals: insp_qual {
@@ -9166,6 +9387,7 @@ insp_quals: insp_qual {
} else {
$$->after = *$insp_qual.qual;
}
+ dump_inspect_match(*$$);
}
| insp_quals insp_qual
{
@@ -9585,7 +9807,7 @@ alter_tgt: label_1[old] alter_to label_1[new]
cbl_perform_tgt_t tgt( $old, $new );
parser_alter(&tgt);
- auto prog = cbl_label_of( symbol_at(symbol_elem_of($old)->program));
+ const auto prog = cbl_label_of( symbol_at(symbol_elem_of($old)->program));
if( prog->initial ) {
cbl_unimplemented("ALTER %s", $old->name);
}
@@ -9976,12 +10198,14 @@ function_udf: FUNCTION_UDF '(' arg_list[args] ')' {
if( ! current.udf_args_valid(L, $args->refers, params) ) {
YYERROR;
}
- $$ = new_temporary_clone(cbl_field_of(symbol_at(L->returning)));
+ const auto returning = cbl_field_of(symbol_at(L->returning));
+ $$ = new_temporary_clone(returning);
+ $$->data.initial = returning->name; // user's name for the field
std::vector <cbl_ffi_arg_t> args($args->refers.size());
size_t i = 0;
// Pass parameters as defined by the function.
std::transform( $args->refers.begin(), $args->refers.end(), args.begin(),
- [params, &i]( cbl_refer_t& arg ) {
+ [params, &i]( const cbl_refer_t& arg ) {
function_descr_arg_t param = params.at(i++);
auto ar = new cbl_refer_t(arg);
cbl_ffi_arg_t actual(param.crv, ar);
@@ -9995,7 +10219,9 @@ function_udf: FUNCTION_UDF '(' arg_list[args] ')' {
static cbl_ffi_arg_t *args = NULL;
auto L = cbl_label_of(symbol_at($1));
- $$ = new_temporary_clone(cbl_field_of(symbol_at(L->returning)));
+ const auto returning = cbl_field_of(symbol_at(L->returning));
+ $$ = new_temporary_clone(returning);
+ $$->data.initial = returning->name; // user's name for the field
auto name = new_literal(strlen(L->name), L->name, quoted_e);
ast_call( @1, name, $$, narg, args, NULL, NULL, true );
@@ -10028,15 +10254,15 @@ intrinsic: function_udf
args.data());
if( p != NULL ) {
auto loc = symbol_field_location(field_index(p->field));
- error_msg(loc, "FUNCTION %s has "
- "inconsistent parameter type %zu ('%s')",
+ error_msg(loc, "FUNCTION %qs has "
+ "inconsistent parameter type %zu (%qs)",
keyword_str($1), p - args.data(), name_of(p->field) );
YYERROR;
}
$$ = is_numeric(args[0].field)?
new_tempnumeric_float() :
new_alphanumeric();
-
+ $$->data.initial = keyword_str($1);
parser_intrinsic_callv( $$, intrinsic_cname($1),
args.size(), args.data() );
}
@@ -10045,7 +10271,7 @@ intrinsic: function_udf
{
static char s[] = "__gg__present_value";
location_set(@1);
- $$ = new_tempnumeric_float();
+ $$ = new_tempnumeric_float("PRESENT-VALUE");
size_t n = $args->size();
assert(n > 0);
if( n < 2 ) {
@@ -10063,56 +10289,56 @@ intrinsic: function_udf
| BASECONVERT '(' varg[r1] varg[r2] varg[r3] ')' {
location_set(@1);
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("BASECONVERT");
cbl_unimplemented("BASECONVERT");
if( ! intrinsic_call_3($$, BASECONVERT, $r1, $r2, $r3 )) YYERROR;
}
| BIT_OF '(' expr[r1] ')' {
location_set(@1);
- $$ = new_alphanumeric();
+ $$ = new_alphanumeric("BIT-OF");
if( ! intrinsic_call_1($$, BIT_OF, $r1, @r1)) YYERROR;
}
| CHAR '(' expr[r1] ')' {
location_set(@1);
- $$ = new_alphanumeric(1);
+ $$ = new_alphanumeric(1,"CHAR");
if( ! intrinsic_call_1($$, CHAR, $r1, @r1)) YYERROR;
}
| CONVERT '(' varg[r1] convert_src[src] convert_dst[dst] ')' {
location_set(@1);
- $$ = new_alphanumeric(1);
+ $$ = new_alphanumeric(1,"CONVERT");
cbl_unimplemented("CONVERT");
/* if( ! intrinsic_call_3($$, CONVERT, $r1, $src, $dst) ) YYERROR; */
}
| DISPLAY_OF '(' varg[r1] ')' {
location_set(@1);
- $$ = new_alphanumeric();
+ $$ = new_alphanumeric("DISPLAY-OF");
if( ! intrinsic_call_2($$, DISPLAY_OF, $r1, NULL) ) YYERROR;
}
| DISPLAY_OF '(' varg[r1] varg[r2] ')' {
location_set(@1);
- $$ = new_alphanumeric();
+ $$ = new_alphanumeric("DISPLAY-OF");
if( ! intrinsic_call_2($$, DISPLAY_OF, $r1, $r2) ) YYERROR;
}
| EXCEPTION_FILE filename {
location_set(@1);
- $$ = new_alphanumeric();
+ $$ = new_alphanumeric("EXCEPTION-FILE");
parser_exception_file( $$, $filename );
}
| FIND_STRING '(' varg[r1] last start_after anycase ')' {
location_set(@1);
- $$ = new_alphanumeric();
+ $$ = new_alphanumeric("FIND-STRING");
/* auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e)); */
- cbl_unimplemented("FIND_STRING");
+ cbl_unimplemented("%<FIND_STRING%>");
/* if( ! intrinsic_call_4($$, FIND_STRING, r1, $r2) ) YYERROR; */
}
| FORMATTED_DATE '(' DATE_FMT[r1] expr[r2] ')' {
location_set(@1);
- $$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATE);
+ $$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATE, "FORMATTED-DATE");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_2($$, FORMATTED_DATE, r1, $r2) ) YYERROR;
}
@@ -10121,7 +10347,7 @@ intrinsic: function_udf
| FORMATTED_DATETIME '(' DATETIME_FMT[r1] expr[r2]
expr[r3] ')' {
location_set(@1);
- $$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME);
+ $$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME, "FORMATTED-DATETIME");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
static cbl_refer_t r3(literally_zero);
if( ! intrinsic_call_4($$, FORMATTED_DATETIME,
@@ -10130,7 +10356,7 @@ intrinsic: function_udf
| FORMATTED_DATETIME '(' DATETIME_FMT[r1] expr[r2]
expr[r3] expr[r4] ')' {
location_set(@1);
- $$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME);
+ $$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME, "FORMATTED-DATETIME");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_4($$, FORMATTED_DATETIME,
r1, $r2, $r3, $r4) ) YYERROR;
@@ -10141,14 +10367,14 @@ intrinsic: function_udf
| FORMATTED_TIME '(' TIME_FMT[r1] expr[r2]
expr[r3] ')' {
location_set(@1);
- $$ = new_alphanumeric(MAXLENGTH_FORMATTED_TIME);
+ $$ = new_alphanumeric(MAXLENGTH_FORMATTED_TIME, "FORMATTED-DATETIME");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_3($$, FORMATTED_TIME,
r1, $r2, $r3) ) YYERROR;
}
| FORMATTED_TIME '(' TIME_FMT[r1] expr[r2] ')' {
location_set(@1);
- $$ = new_alphanumeric(MAXLENGTH_FORMATTED_TIME);
+ $$ = new_alphanumeric(MAXLENGTH_FORMATTED_TIME, "FORMATTED-TIME");
auto r3 = new_reference(new_literal("0"));
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_3($$, FORMATTED_TIME,
@@ -10156,21 +10382,21 @@ intrinsic: function_udf
}
| FORMATTED_CURRENT_DATE '(' DATETIME_FMT[r1] ')' {
location_set(@1);
- $$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME);
+ $$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME, "FORMATTED-CURRENT_DATE");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_1($$, FORMATTED_CURRENT_DATE, r1, @r1) )
YYERROR;
}
| TEST_FORMATTED_DATETIME '(' DATE_FMT[r1] varg[r2] ')' {
location_set(@1);
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("TEST-FORMATTED-DATETIME");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_2($$, TEST_FORMATTED_DATETIME,
r1, $r2) ) YYERROR;
}
| TEST_FORMATTED_DATETIME '(' TIME_FMT[r1] varg[r2] ')' {
location_set(@1);
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("TEST-FORMATTED-DATETIME");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_2($$, TEST_FORMATTED_DATETIME,
r1, $r2) ) YYERROR;
@@ -10178,14 +10404,14 @@ intrinsic: function_udf
| TEST_FORMATTED_DATETIME '(' DATETIME_FMT[r1] varg[r2] ')'
{
location_set(@1);
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("TEST-FORMATTED-DATETIME");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_2($$, TEST_FORMATTED_DATETIME,
r1, $r2) ) YYERROR;
}
| INTEGER_OF_FORMATTED_DATE '(' DATE_FMT[r1] varg[r2] ')' {
location_set(@1);
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("INTEGER-OF-FORMATTED-DATE");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_2($$, INTEGER_OF_FORMATTED_DATE,
r1, $r2) ) YYERROR;
@@ -10193,14 +10419,14 @@ intrinsic: function_udf
| INTEGER_OF_FORMATTED_DATE '(' DATETIME_FMT[r1] varg[r2] ')'
{
location_set(@1);
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("INTEGER-OF-FORMATTED-DATE");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_2($$, INTEGER_OF_FORMATTED_DATE,
r1, $r2) ) YYERROR;
}
| SECONDS_FROM_FORMATTED_TIME '(' TIME_FMT[r1] varg[r2] ')' {
location_set(@1);
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("SECONDS-FROM-FORMATTED-TIME");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_2($$, SECONDS_FROM_FORMATTED_TIME,
r1, $r2) ) YYERROR;
@@ -10208,7 +10434,7 @@ intrinsic: function_udf
| SECONDS_FROM_FORMATTED_TIME '(' DATETIME_FMT[r1] varg[r2] ')'
{
location_set(@1);
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("SECONDS-FROM-FORMATTED-TIME");
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_2($$, SECONDS_FROM_FORMATTED_TIME,
r1, $r2) ) YYERROR;
@@ -10216,85 +10442,85 @@ intrinsic: function_udf
| HEX_OF '(' varg[r1] ')' {
location_set(@1);
- $$ = new_alphanumeric();
+ $$ = new_alphanumeric("HEX-OF");
if( ! intrinsic_call_1($$, HEX_OF, $r1, @r1)) YYERROR;
}
| LENGTH '(' tableish[val] ')' {
location_set(@1);
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("LENGTH");
$$->clear_attr(signable_e);
parser_set_numeric($$, $val->field->size());
if( ! intrinsic_call_1($$, LENGTH, $val, @val)) YYERROR;
}
| LENGTH '(' varg1a[val] ')' {
location_set(@1);
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("LENGTH");
$$->clear_attr(signable_e);
parser_set_numeric($$, $val->field->data.capacity);
if( ! intrinsic_call_1($$, LENGTH, $val, @val)) YYERROR;
}
| lopper_case[func] '(' alpha_val[r1] ')' {
location_set(@1);
- $$ = new_alphanumeric($r1->field->data.capacity);
+ $$ = new_alphanumeric($r1->field->data.capacity, "lopper_case[func]");
if( ! intrinsic_call_1($$, $func, $r1, @r1)) YYERROR;
}
| MODULE_NAME '(' module_type[type] ')'
{
- $$ = new_alphanumeric(sizeof(cbl_name_t));
+ $$ = new_alphanumeric(sizeof(cbl_name_t), "MODULE-NAME");
parser_module_name( $$, $type );
}
| NUMVAL_C '(' varg[r1] numval_locale[r2] anycase ')' {
location_set(@1);
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("NUMVAL-C");
parser_intrinsic_numval_c( $$, *$r1, $r2.is_locale,
*$r2.arg2, $anycase );
}
| ORD '(' alpha_val[r1] ')'
{
location_set(@1);
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("ORD");
if( ! intrinsic_call_1($$, ORD, $r1, @r1)) YYERROR;
}
| RANDOM
{
location_set(@1);
- $$ = new_tempnumeric_float();
+ $$ = new_tempnumeric_float("RANDOM");
parser_intrinsic_call_0( $$, intrinsic_cname(RANDOM) );
}
| RANDOM_SEED expr[r1] ')'
{ // left parenthesis consumed by lexer
location_set(@1);
- $$ = new_tempnumeric_float();
+ $$ = new_tempnumeric_float("RANDOM-SEED");
if( ! intrinsic_call_1($$, RANDOM, $r1, @r1)) YYERROR;
}
| STANDARD_COMPARE '(' varg[r1] varg[r2] varg[r3] varg[r4] ')'
{
location_set(@1);
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("STANDARD-COMPARE");
cbl_unimplemented("STANDARD-COMPARE");
/* if( ! intrinsic_call_4($$, STANDARD_COMPARE, $r1) ) YYERROR; */
}
| STANDARD_COMPARE '(' varg[r1] varg[r2] varg[r3] ')'
{
location_set(@1);
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("STANDARD-COMPARE");
cbl_unimplemented("STANDARD-COMPARE");
/* if( ! intrinsic_call_4($$, STANDARD_COMPARE, $r1) ) YYERROR; */
}
| STANDARD_COMPARE '(' varg[r1] varg[r2] ')'
{
location_set(@1);
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("STANDARD-COMPARE");
cbl_unimplemented("STANDARD-COMPARE");
/* if( ! intrinsic_call_4($$, STANDARD_COMPARE, $r1) ) YYERROR; */
}
| SUBSTITUTE '(' varg[r1] subst_inputs[inputs] ')' {
location_set(@1);
- $$ = new_alphanumeric();
+ $$ = new_alphanumeric("SUBSTITUTE");
std::vector <cbl_substitute_t> args($inputs->size());
std::transform( $inputs->begin(), $inputs->end(), args.begin(),
[]( const substitution_t& arg ) {
@@ -10310,7 +10536,7 @@ intrinsic: function_udf
| TEST_NUMVAL_C '(' varg[r1] numval_locale[r2] anycase ')' {
location_set(@1);
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("parser_intrinsic_subst($$,");
parser_intrinsic_numval_c( $$, *$r1, $r2.is_locale,
*$r2.arg2, $anycase, true );
}
@@ -10337,14 +10563,14 @@ intrinsic: function_udf
YYERROR;
break;
}
- $$ = new_alphanumeric();
+ $$ = new_alphanumeric("TRIM");
cbl_refer_t * how = new_reference($trim_trailing);
if( ! intrinsic_call_2($$, TRIM, $r1, how) ) YYERROR;
}
| USUBSTR '(' alpha_val[r1] expr[r2] expr[r3] ')' {
location_set(@1);
- $$ = new_alphanumeric();
+ $$ = new_alphanumeric("USUBSTR");
if( ! intrinsic_call_3($$, FORMATTED_DATETIME,
$r1, $r2, $r3) ) YYERROR;
}
@@ -10352,14 +10578,14 @@ intrinsic: function_udf
| intrinsic_I '(' expr[r1] ')'
{
location_set(@1);
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric(keyword_str($1));
if( ! intrinsic_call_1($$, $1, $r1, @r1)) YYERROR;
}
| intrinsic_N '(' expr[r1] ')'
{
location_set(@1);
- $$ = new_tempnumeric_float();
+ $$ = new_tempnumeric_float(keyword_str($1));
if( ! intrinsic_call_1($$, $1, $r1, @r1)) YYERROR;
}
@@ -10369,17 +10595,14 @@ intrinsic: function_udf
auto type = intrinsic_return_type($1);
switch(type) {
case FldAlphanumeric:
- $$ = new_alphanumeric();
+ $$ = new_alphanumeric(keyword_str($1));
break;
default:
- if( $1 == NUMVAL || $1 == NUMVAL_F )
- {
- $$ = new_temporary(FldFloat);
- }
- else
- {
- $$ = new_temporary(type);
- }
+ if( $1 == NUMVAL || $1 == NUMVAL_F ) {
+ $$ = new_temporary(FldFloat, keyword_str($1));
+ } else {
+ $$ = new_temporary(type, keyword_str($1));
+ }
}
if( $1 == NUMVAL_F ) {
if( is_literal($r1->field) && ! is_numeric($r1->field->type) ) {
@@ -10394,7 +10617,7 @@ intrinsic: function_udf
| intrinsic_I2 '(' expr[r1] expr[r2] ')'
{
location_set(@1);
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("intrinsic_I2");
if( ! intrinsic_call_2($$, $1, $r1, $r2) ) YYERROR;
}
@@ -10410,7 +10633,7 @@ intrinsic: function_udf
parser_intrinsic_call_0( r3->field, "__gg__current_date" );
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("DATE_TO_YYYYMMDD");
if( ! intrinsic_call_3($$, DATE_TO_YYYYMMDD,
$r1, r2, r3) ) YYERROR;
}
@@ -10426,7 +10649,7 @@ intrinsic: function_udf
parser_intrinsic_call_0( r3->field, "__gg__current_date" );
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("DATE_TO_YYYYMMDD");
if( ! intrinsic_call_3($$, DATE_TO_YYYYMMDD,
$r1, $r2, r3) ) YYERROR;
}
@@ -10435,7 +10658,7 @@ intrinsic: function_udf
expr[r2] expr[r3] ')'
{
location_set(@1);
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("DATE_TO_YYYYMMDD");
if( ! intrinsic_call_3($$, DATE_TO_YYYYMMDD,
$r1, $r2, $r3) ) YYERROR;
}
@@ -10452,7 +10675,7 @@ intrinsic: function_udf
parser_intrinsic_call_0( r3->field, "__gg__current_date" );
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("DAY_TO_YYYYDDD");
if( ! intrinsic_call_3($$, DAY_TO_YYYYDDD,
$r1, r2, r3) ) YYERROR;
}
@@ -10468,7 +10691,7 @@ intrinsic: function_udf
parser_intrinsic_call_0( r3->field, "__gg__current_date" );
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("DAY_TO_YYYYDDD");
if( ! intrinsic_call_3($$, DAY_TO_YYYYDDD,
$r1, $r2, r3) ) YYERROR;
}
@@ -10477,7 +10700,7 @@ intrinsic: function_udf
expr[r2] expr[r3] ')'
{
location_set(@1);
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("DAY_TO_YYYYDDD");
if( ! intrinsic_call_3($$, DAY_TO_YYYYDDD,
$r1, $r2, $r3) ) YYERROR;
}
@@ -10494,7 +10717,7 @@ intrinsic: function_udf
parser_intrinsic_call_0( r3->field, "__gg__current_date" );
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("YEAR_TO_YYYY");
if( ! intrinsic_call_3($$, YEAR_TO_YYYY,
$r1, r2, r3) ) YYERROR;
}
@@ -10510,7 +10733,7 @@ intrinsic: function_udf
parser_intrinsic_call_0( r3->field, "__gg__current_date" );
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("YEAR_TO_YYYY");
if( ! intrinsic_call_3($$, YEAR_TO_YYYY,
$r1, $r2, r3) ) YYERROR;
}
@@ -10519,7 +10742,7 @@ intrinsic: function_udf
expr[r2] expr[r3] ')'
{
location_set(@1);
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("YEAR_TO_YYYY");
if( ! intrinsic_call_3($$, YEAR_TO_YYYY,
$r1, $r2, $r3) ) YYERROR;
}
@@ -10527,25 +10750,25 @@ intrinsic: function_udf
| intrinsic_N2 '(' expr[r1] expr[r2] ')'
{
location_set(@1);
- switch($1)
- {
- case ANNUITY:
- $$ = new_tempnumeric_float();
- break;
- case COMBINED_DATETIME:
- $$ = new_tempnumeric();
- break;
- case REM:
- $$ = new_tempnumeric_float();
- break;
- }
+ switch($1) {
+ case ANNUITY:
+ $$ = new_tempnumeric_float();
+ break;
+ case COMBINED_DATETIME:
+ $$ = new_tempnumeric();
+ break;
+ case REM:
+ $$ = new_tempnumeric_float();
+ break;
+ }
+ $$->data.initial = keyword_str($1); // function name
if( ! intrinsic_call_2($$, $1, $r1, $r2) ) YYERROR;
}
| intrinsic_X2 '(' varg[r1] varg[r2] ')'
{
location_set(@1);
- $$ = new_alphanumeric();
+ $$ = new_alphanumeric(keyword_str($1));
if( ! intrinsic_call_2($$, $1, $r1, $r2) ) YYERROR;
}
| intrinsic_locale
@@ -10576,7 +10799,7 @@ numval_locale: %empty {
$$.arg2 = cbl_refer_t::empty();
}
| LOCALE NAME { $$.is_locale = true; $$.arg2 = NULL;
- cbl_unimplemented("NUMVAL_C LOCALE"); YYERROR;
+ cbl_unimplemented("%<NUMVAL_C LOCALE%>"); YYERROR;
}
| varg { $$.is_locale = false; $$.arg2 = $1; }
;
@@ -10656,65 +10879,66 @@ trim_trailing: %empty { $$ = new_literal("0"); } // Remove both
intrinsic0: CURRENT_DATE {
location_set(@1);
- $$ = new_alphanumeric(MAXLENGTH_CALENDAR_DATE);
+ $$ = new_alphanumeric(MAXLENGTH_CALENDAR_DATE, "CURRENT-DATE");
parser_intrinsic_call_0( $$, "__gg__current_date" );
}
| E {
location_set(@1);
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("E");
parser_intrinsic_call_0( $$, "__gg__e" );
}
| EXCEPTION_FILE_N {
location_set(@1);
- $$ = new_alphanumeric();
+ $$ = new_alphanumeric("EXCEPTION-FILE-N");
intrinsic_call_0( $$, EXCEPTION_FILE_N );
}
| EXCEPTION_FILE {
location_set(@1);
- $$ = new_alphanumeric();
+ $$ = new_alphanumeric("EXCEPTION-FILE");
parser_exception_file( $$ );
}
| EXCEPTION_LOCATION_N {
location_set(@1);
- $$ = new_alphanumeric();
+ $$ = new_alphanumeric("EXCEPTION-LOCATION-N");
intrinsic_call_0( $$, EXCEPTION_LOCATION_N );
}
| EXCEPTION_LOCATION {
location_set(@1);
- $$ = new_alphanumeric();
+ $$ = new_alphanumeric("EXCEPTION-LOCATION");
intrinsic_call_0( $$, EXCEPTION_LOCATION );
}
| EXCEPTION_STATEMENT {
location_set(@1);
- $$ = new_alphanumeric();
+ $$ = new_alphanumeric("EXCEPTION-STATEMENT");
intrinsic_call_0( $$, EXCEPTION_STATEMENT );
}
| EXCEPTION_STATUS {
location_set(@1);
- $$ = new_alphanumeric();
+ $$ = new_alphanumeric("EXCEPTION-STATUS");
intrinsic_call_0( $$, EXCEPTION_STATUS );
}
| PI {
location_set(@1);
- $$ = new_tempnumeric_float();
+ $$ = new_tempnumeric_float("PI");
parser_intrinsic_call_0( $$, "__gg__pi" );
}
| SECONDS_PAST_MIDNIGHT {
location_set(@1);
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric("SECONDS-PAST-MIDNIGHT");
intrinsic_call_0( $$, SECONDS_PAST_MIDNIGHT );
}
| UUID4 {
location_set(@1);
- $$ = new_alphanumeric();
+ $$ = new_alphanumeric("UUID4");
parser_intrinsic_call_0( $$, "__gg__uuid4" );
}
| WHEN_COMPILED {
location_set(@1);
- $$ = new_alphanumeric(MAXLENGTH_CALENDAR_DATE); // Returns YYYYMMDDhhmmssss-0500
+ // Returns YYYYMMDDhhmmssss-0500)
+ $$ = new_alphanumeric(MAXLENGTH_CALENDAR_DATE, "WHEN-COMPILED");
parser_intrinsic_call_0( $$, "__gg__when_compiled" );
}
;
@@ -10918,6 +11142,11 @@ sign: %empty
| SIGN
;
+is_signed: %empty { $$ = true; }
+ | SIGNED_kw { $$ = true; }
+ | UNSIGNED_kw { $$ = false; }
+ ;
+
start_after: %empty %prec AFTER
| START AFTER varg
;
@@ -11119,7 +11348,7 @@ first_line_of( YYLTYPE loc ) {
return loc;
}
-void ast_call( const YYLTYPE& loc, cbl_refer_t name, cbl_refer_t returning,
+void ast_call( const YYLTYPE& loc, cbl_refer_t name, const cbl_refer_t& returning,
size_t narg, cbl_ffi_arg_t args[],
cbl_label_t *except,
cbl_label_t *not_except,
@@ -11211,7 +11440,7 @@ statement_begin( const YYLTYPE& loc, int token ) {
struct string_match {
const char *name;
- string_match( const char name[] ) : name(name) {}
+ explicit string_match( const char name[] ) : name(name) {}
bool operator()( const char input[] ) const {
return strlen(name) == strlen(input) && 0 == strcasecmp(name, input);
}
@@ -11219,9 +11448,13 @@ struct string_match {
const char *
keyword_str( int token ) {
- if( token == YYEOF ) return "YYEOF";
- if( token == YYEMPTY ) return "YYEMPTY";
-
+ switch( token ) {
+ case YYEOF: return "YYEOF";
+ case YYEMPTY: return "YYEMPTY";
+ case 256: return "YYerror";
+ case 257: return "invalid token"; // YYUNDEF
+ }
+
if( token < 256 ) {
static char ascii[2];
ascii[0] = token;
@@ -11245,7 +11478,7 @@ tokenset_t::tokenset_t() {
#include "token_names.h"
}
-bool iso_cobol_word( const std::string& name, bool include_intrinsics );
+bool iso_cobol_word( const std::string& name, bool include_context );
// Look up the lowercase form of a keyword, excluding some CDF names.
int
@@ -11265,9 +11498,9 @@ tokenset_t::find( const cbl_name_t name, bool include_intrinsics ) {
if( dialect_ibm() ) {
static const cbl_name_t ibm_non_names[] = {
"RESUME",
- }, * const eonames = ibm_non_names + COUNT_OF(ibm_non_names);
+ }, * const eoibm = ibm_non_names + COUNT_OF(ibm_non_names);
- if( std::any_of(ibm_non_names, eonames,
+ if( std::any_of(ibm_non_names, eoibm,
[candidate=name](const cbl_name_t non_name) {
return 0 == strcasecmp(non_name, candidate)
&& strlen(non_name) == strlen(candidate);
@@ -11276,8 +11509,13 @@ tokenset_t::find( const cbl_name_t name, bool include_intrinsics ) {
}
}
- //// if( ! iso_cobol_word(uppercase(name), include_intrinsics) ) return 0;
-
+ /*
+ * The input name may be one of:
+ * 1. an intrinsic function name (OK if include_intrinsics)
+ * 2. an ISO/GCC reserved word or context-sensitive word (OK)
+ * 3. a token in our token list for convenience, such as BINARY_INTEGER (bzzt)
+ */
+
cbl_name_t lname;
std::transform(name, name + strlen(name) + 1, lname, ftolower);
auto p = tokens.find(lname);
@@ -11286,9 +11524,10 @@ tokenset_t::find( const cbl_name_t name, bool include_intrinsics ) {
if( token == SECTION ) yylval.number = 0;
- if( include_intrinsics ) return token;
-
- return intrinsic_cname(token)? 0 : token;
+ if( include_intrinsics && intrinsic_cname(token) ) return token;
+ if( iso_cobol_word(uppercase(name), true) ) return token;
+
+ return 0;
}
int
@@ -11298,7 +11537,7 @@ keyword_tok( const char * text, bool include_intrinsics ) {
static inline size_t
verify_figconst( enum cbl_figconst_t figconst , size_t pos ) {
- cbl_field_t *f = cbl_field_of(symbol_at(pos));
+ const cbl_field_t *f = cbl_field_of(symbol_at(pos));
assert((f->attr & FIGCONST_MASK) == figconst);
return pos;
}
@@ -11344,7 +11583,7 @@ relop_invert(relop_t op) {
case ge_op: return lt_op;
case gt_op: return le_op;
}
- cbl_errx( "%s:%d: invalid relop_t %d", __func__, __LINE__, op);
+ cbl_internal_error("%s:%d: invalid %<relop_t%> %d", __func__, __LINE__, op);
return relop_t(0); // not reached
}
@@ -11590,7 +11829,7 @@ current_t::udf_update( const ffi_args_t *ffi_args ) {
if( ! ffi_args ) return;
assert(ffi_args->elems.size() < sizeof(function_descr_t::types));
- auto returning = cbl_field_of(symbol_at(L->returning));
+ const auto returning = cbl_field_of(symbol_at(L->returning));
auto key = function_descr_t::init(L->name);
auto func = udfs.find(key);
assert(func != udfs.end());
@@ -11632,12 +11871,12 @@ current_t::udf_args_valid( const cbl_label_t *L,
}
size_t i = 0;
- for( cbl_refer_t arg : args ) {
+ for( const cbl_refer_t& arg : args ) {
if( arg.field ) { // else omitted
auto tgt = cbl_field_of(symbol_at(udf.linkage_fields.at(i).isym));
if( ! valid_move(tgt, arg.field) ) {
auto loc = symbol_field_location(field_index(arg.field));
- error_msg(loc, "FUNCTION %s arg %zu, '%s' cannot be passed to %s, type %s",
+ error_msg(loc, "FUNCTION %s argument %zu, '%s' cannot be passed to %s, type %s",
L->name, i, arg.field->pretty_name(),
tgt->pretty_name(), 3 + cbl_field_type_str(tgt->type) );
return false;
@@ -11653,7 +11892,10 @@ current_t::repository_add( const char name[]) {
assert( !programs.empty() );
function_descr_t arg = function_descr_t::init(name);
auto parg = std::find( function_descrs, function_descrs_end, arg );
- if( parg == function_descrs_end ) return false;
+ if( parg == function_descrs_end ) {
+ dbgmsg("%s:%d: no intrinsic %s found", __func__, __LINE__, name);
+ return false;
+ }
auto p = programs.top().function_repository.insert(*parg);
if( yydebug ) {
for( auto descr : programs.top().function_repository ) {
@@ -11689,7 +11931,7 @@ function_descr_t
function_descr_t::init( int isym ) {
function_descr_t descr = { FUNCTION_UDF_0 };
descr.ret_type = FldInvalid;
- auto L = cbl_label_of(symbol_at(isym));
+ const auto L = cbl_label_of(symbol_at(isym));
bool ok = namcpy(YYLTYPE(), descr.name, L->name);
gcc_assert(ok);
return descr;
@@ -11703,16 +11945,16 @@ arith_t::arith_t( cbl_arith_format_t format, refer_list_t * refers )
delete refers;
}
-
-cbl_key_t::cbl_key_t( const sort_key_t& that )
+cbl_key_t::cbl_key_t( sort_key_t that )
: ascending(that.ascending)
- , nfield(that.fields.size())
- , fields(NULL)
-{
- if( nfield > 0 ) {
- fields = new cbl_field_t* [nfield];
- std::copy(that.fields.begin(), that.fields.end(), fields);
- }
+ , fields( that.fields.begin(), that.fields.end() )
+{}
+
+cbl_key_t&
+cbl_key_t::operator=( const sort_key_t& that ) {
+ ascending = that.ascending;
+ fields = that.as_vector();
+ return *this;
}
static cbl_refer_t *
@@ -11818,10 +12060,10 @@ ast_divide( arith_t *arith ) {
* the convenience of the parser.
*/
struct stringify_src_t : public cbl_string_src_t {
- stringify_src_t( const refer_marked_list_t& marked = refer_marked_list_t() )
- : cbl_string_src_t( marked.marker? *marked.marker : null_reference,
- marked.refers.size(),
- new cbl_refer_t[marked.refers.size()] )
+ stringify_src_t( const refer_marked_list_t& marked = refer_marked_list_t() )
+ : cbl_string_src_t( marked.marker? *marked.marker : null_reference,
+ marked.refers.size(),
+ new cbl_refer_t[marked.refers.size()] )
{
std::copy( marked.refers.begin(), marked.refers.end(), inputs );
}
@@ -11835,13 +12077,13 @@ struct stringify_src_t : public cbl_string_src_t {
protected:
static void dump_input( const cbl_refer_t& refer ) {
- yywarn( "%s:\t%s", __func__, field_str(refer.field) );
+ yywarn( "%s: %s", __func__, field_str(refer.field) );
}
};
void
stringify( refer_collection_t *inputs,
- cbl_refer_t into, cbl_refer_t pointer,
+ const cbl_refer_t& into, const cbl_refer_t& pointer,
cbl_label_t *on_error,
cbl_label_t *not_error )
{
@@ -11856,7 +12098,7 @@ stringify( refer_collection_t *inputs,
}
void
-unstringify( cbl_refer_t& src,
+unstringify( const cbl_refer_t& src,
refer_list_t *delimited,
unstring_into_t * into,
cbl_label_t *on_error,
@@ -11864,6 +12106,7 @@ unstringify( cbl_refer_t& src,
{
size_t ndelimited = delimited? delimited->size() : 0;
cbl_refer_t *pdelimited = NULL;
+ // cppcheck-suppress [variableScope] pdelimited points to delimiteds.data()
std::vector <cbl_refer_t> delimiteds(ndelimited);
if( ndelimited > 0 ) {
pdelimited = use_any( delimited->refers, delimiteds );
@@ -11975,15 +12218,19 @@ lang_check_failed (const char* file, int line, const char* function) {}
#pragma GCC diagnostic pop
-void ast_inspect( cbl_refer_t& input, bool backward, ast_inspect_list_t& inspects ) {
+void
+ast_inspect( YYLTYPE loc, cbl_refer_t& input, bool backward,
+ cbl_inspect_opers_t& inspects )
+{
if( yydebug ) {
- dbgmsg("%s:%d: INSPECT " HOST_SIZE_T_PRINT_UNSIGNED " operations on %s, line %d",
- __func__, __LINE__, (fmt_size_t)inspects.size(), input.field->name, yylineno);
+ dbgmsg("%s:%d: INSPECT " HOST_SIZE_T_PRINT_UNSIGNED " operations on %s, "
+ "lines %d:%d - %d:%d",
+ __func__, __LINE__,
+ (fmt_size_t)inspects.size(), input.field->name,
+ loc.first_line, loc.first_column, loc.last_line, loc.last_column );
}
std::for_each(inspects.begin(), inspects.end(), dump_inspect);
- auto array = inspects.as_array();
- parser_inspect( input, backward, inspects.size(), array );
- delete[] array;
+ parser_inspect( input, backward, inspects );
}
static const char *
@@ -11995,28 +12242,29 @@ cbl_refer_str( char output[], const cbl_refer_t& R ) {
return output;
}
-static void
+void
dump_inspect_match( const cbl_inspect_match_t& M ) {
- static char fields[3][4 * 64];
- cbl_refer_str(fields[0], M.matching);
- cbl_refer_str(fields[1], M.before.identifier_4);
- cbl_refer_str(fields[2], M.after.identifier_4);
-
- yywarn( "matching %s \n\t\tbefore %s%s \n\t\tafter %s%s",
- fields[0],
- M.before.initial? "initial " : "", fields[1],
- M.after.initial? "initial " : "", fields[2] );
+ static char fields[4][4 * 64];
+ cbl_refer_str(fields[0], M.match);
+ cbl_refer_str(fields[1], M.tally);
+ cbl_refer_str(fields[2], M.before.identifier_4);
+ cbl_refer_str(fields[3], M.after.identifier_4);
+
+ dbgmsg( "matching %s [tally %s]\n\t\tbefore %s%s \n\t\tafter %s%s",
+ fields[0], fields[1],
+ M.before.initial? "initial " : "", fields[2],
+ M.after.initial? "initial " : "", fields[3] );
}
static void
dump_inspect_replace( const cbl_inspect_replace_t& R ) {
static char fields[4][4 * 64];
- cbl_refer_str(fields[0], R.matching);
+ cbl_refer_str(fields[0], R.matching());
cbl_refer_str(fields[1], R.before.identifier_4);
cbl_refer_str(fields[2], R.after.identifier_4);
cbl_refer_str(fields[3], R.replacement);
- yywarn( "matching %s \n\treplacement %s\n\t\tbefore %s%s \n\t\tafter %s%s",
+ dbgmsg( "matching %s \n\treplacement %s\n\t\tbefore %s%s \n\t\tafter %s%s",
fields[0], fields[3],
R.before.initial? "initial " : "", fields[1],
R.after.initial? "initial " : "", fields[2] );
@@ -12132,13 +12380,13 @@ numstr2i( const char input[], radix_t radix ) {
break;
case hexadecimal_e:
erc = sscanf(input, "%" GCC_PRISZ "x", &integerf);
- integer = integer;
+ integer = integerf;
real_from_integer (&output, VOIDmode, integer, UNSIGNED);
break;
case boolean_e:
for( const char *p = input; *p != '\0'; p++ ) {
if( ssize_t(8 * sizeof(integer) - 1) < p - input ) {
- yywarn("'%s' was accepted as %d", input, integer);
+ yywarn("'%s' was accepted as %zu", input, integer);
break;
}
switch(*p) {
@@ -12148,7 +12396,7 @@ numstr2i( const char input[], radix_t radix ) {
integer |= ((*p) == '0' ? 0 : 1);
break;
default:
- yywarn("'%s' was accepted as %d", input, integer);
+ yywarn("'%s' was accepted as %zu", input, integer);
break;
}
}
@@ -12156,7 +12404,7 @@ numstr2i( const char input[], radix_t radix ) {
return output;
}
if( erc == -1 ) {
- yywarn("'%s' was accepted as %lld", input, output);
+ yywarn("'%s' was accepted as %zu", input, integer);
}
return output;
}
@@ -12182,7 +12430,7 @@ new_literal( const char initial[], enum radix_t radix ) {
class is_elementary_type { // for INITIALIZE purposes
bool with_filler;
public:
- is_elementary_type( bool with_filler ) : with_filler(with_filler) {}
+ explicit is_elementary_type( bool with_filler ) : with_filler(with_filler) {}
bool operator()( const symbol_elem_t& elem ) const {
if( elem.type != SymField ) return false;
@@ -12196,7 +12444,7 @@ public:
size_t end_of_group( size_t igroup );
static std::list<cbl_refer_t>
-symbol_group_data_members( cbl_refer_t refer, bool with_filler ) {
+symbol_group_data_members( const cbl_refer_t& refer, bool with_filler ) {
std::list<cbl_refer_t> refers;
refers.push_front( refer );
@@ -12204,7 +12452,7 @@ symbol_group_data_members( cbl_refer_t refer, bool with_filler ) {
class refer_of : public cbl_refer_t {
public:
- refer_of( const cbl_refer_t& refer ) : cbl_refer_t(refer) {}
+ explicit refer_of( const cbl_refer_t& refer ) : cbl_refer_t(refer) {}
cbl_refer_t operator()( symbol_elem_t& elem ) {
this->field = cbl_field_of(&elem); // preserve subscript/refmod
return *this;
@@ -12228,7 +12476,7 @@ struct expand_group : public std::list<cbl_refer_t> {
return cbl_refer_t(field);
}
bool with_filler;
- expand_group( bool with_filler ) : with_filler(with_filler) {}
+ explicit expand_group( bool with_filler ) : with_filler(with_filler) {}
void operator()( const cbl_refer_t& refer ) {
assert(refer.field);
@@ -12254,7 +12502,7 @@ wsclear( char ch ) {
}
static void
-initialize_allocated( cbl_refer_t input ) {
+initialize_allocated( const cbl_refer_t& input ) {
cbl_num_result_t result = { truncation_e, input };
std::list<cbl_num_result_t> results;
results.push_back(result);
@@ -12263,13 +12511,14 @@ initialize_allocated( cbl_refer_t input ) {
}
static int
-initialize_with( cbl_refer_t tgt ) {
+initialize_with( const cbl_refer_t& tgt ) {
if( tgt.field->type == FldPointer ) return ZERO;
if( tgt.is_refmod_reference() ) return SPACES;
return is_numeric(tgt.field)? ZERO : SPACES;
}
static bool
+// cppcheck-suppress [passedByValue] target.refer.field is modified
initialize_one( cbl_num_result_t target, bool with_filler,
data_category_t value_category,
const category_map_t& replacements,
@@ -12339,11 +12588,11 @@ typedef std::pair<size_t, size_t> cbl_bytespan_t;
* After the 1st record is initialized, copy it to the others.
*/
static bool
-initialize_table( cbl_num_result_t target,
+initialize_table( const cbl_num_result_t& target,
size_t nspan, const cbl_bytespan_t spans[],
const std::list<cbl_subtable_t>& subtables )
{
- assert( target.refer.nsubscript == dimensions(target.refer.field) );
+ assert( target.refer.nsubscript() == dimensions(target.refer.field) );
const cbl_refer_t& src( target.refer );
size_t n( src.field->occurs.ntimes());
assert( 0 < n );
@@ -12359,17 +12608,17 @@ static cbl_refer_t
synthesize_table_refer( cbl_refer_t tgt ) {
// For a table, use supplied subscripts or start with 1.
auto ndim( dimensions(tgt.field) );
- if( tgt.nsubscript < ndim ) { // it's an incomplete table
+ if( tgt.nsubscript() < ndim ) { // it's an incomplete table
std::vector <cbl_refer_t> subscripts(ndim);
for( size_t i=0; i < ndim; i++ ) {
- if( i < tgt.nsubscript ) {
+ if( i < tgt.nsubscript() ) {
subscripts[i] = tgt.subscripts[i];
continue;
}
subscripts[i].field = new_tempnumeric();
parser_set_numeric(subscripts[i].field, 1);
}
- return cbl_refer_t( tgt.field, subscripts.size(), subscripts.data() );
+ return cbl_refer_t( tgt.field, subscripts );
}
return tgt;
}
@@ -12379,7 +12628,7 @@ group_offset( const cbl_field_t *field ) {
if( field->parent ) {
auto e = symbol_at(field->parent);
if( e->type == SymField ) {
- auto parent = cbl_field_of(e);
+ const auto parent = cbl_field_of(e);
return field->offset - parent->offset;
}
}
@@ -12393,7 +12642,7 @@ initialize_statement( const cbl_num_result_t& target, bool with_filler,
size_t depth = 0 )
{
const cbl_refer_t& tgt( target.refer );
- assert(dimensions(tgt.field) == tgt.nsubscript || 0 < depth);
+ assert(dimensions(tgt.field) == tgt.nsubscript() || 0 < depth);
assert(!is_literal(tgt.field));
if( tgt.field->type == FldGroup ) {
@@ -12430,7 +12679,7 @@ initialize_statement( const cbl_num_result_t& target, bool with_filler,
if( fOK && is_table(tgt.field) ) {
cbl_num_result_t output = { target.rounded, synthesize_table_refer(tgt) };
- if( tgt.nsubscript < output.refer.nsubscript ) { // tgt is whole table
+ if( tgt.nsubscript() < output.refer.nsubscript() ) { // tgt is whole table
std::list<field_span_t> field_spans;
static const field_span_t empty_span = { NULL, NULL };
field_span_t span = empty_span;
@@ -12541,17 +12790,7 @@ static void
initialize_statement( std::list<cbl_num_result_t>& tgts, bool with_filler,
data_category_t value_category,
const category_map_t& replacements) {
-
- bool is_refmod = std::any_of( tgts.begin(), tgts.end(),
- []( const auto& tgt ) {
- return tgt.refer.is_refmod_reference();
- } );
- if( false && is_refmod ) { // refmod seems valid per ISO
- dbgmsg("INITIALIZE cannot initialize a refmod");
- return;
- }
-
- for( auto tgt : tgts ) {
+ for( const auto& tgt : tgts ) {
initialize_statement( tgt, with_filler, value_category,
replacements );
}
@@ -12562,13 +12801,11 @@ static void
dump_inspect_oper( const cbl_inspect_oper_t& op ) {
dbgmsg("\t%s: " HOST_SIZE_T_PRINT_UNSIGNED
" \"matches\", " HOST_SIZE_T_PRINT_UNSIGNED " \"replaces\"",
- bound_str(op.bound),
- op.matches? (fmt_size_t)op.n_identifier_3 : 0,
- op.replaces? (fmt_size_t)op.n_identifier_3 : 0);
- if( op.matches )
- std::for_each(op.matches, op.matches + op.n_identifier_3, dump_inspect_match);
- if( op.replaces )
- std::for_each(op.replaces, op.replaces + op.n_identifier_3, dump_inspect_replace);
+ bound_str(op.bound),
+ (fmt_size_t)op.matches.size(),
+ (fmt_size_t)op.replaces.size());
+ std::for_each(op.matches.begin(), op.matches.end(), dump_inspect_match);
+ std::for_each(op.replaces.begin(), op.replaces.end(), dump_inspect_replace);
}
#pragma GCC diagnostic push
@@ -12585,14 +12822,14 @@ dump_inspect( const cbl_inspect_t& I ) {
} else {
fprintf( stderr, "\tREPLACING:\n" );
}
- std::for_each( I.opers, I.opers + I.nbound, dump_inspect_oper );
+ std::for_each( I.begin(), I.end(), dump_inspect_oper );
}
#pragma GCC diagnostic pop
#include <iterator>
struct declarative_file_list_t : protected cbl_declarative_t {
- declarative_file_list_t( const cbl_declarative_t& d )
+ explicit declarative_file_list_t( const cbl_declarative_t& d )
: cbl_declarative_t(d)
{
if( nfile > 0 )
@@ -12617,7 +12854,7 @@ operator<<( std::ostream& os, const declarative_file_list_t& dcl ) {
static declarative_file_list_t
file_list_of( const cbl_declarative_t& dcl ) {
- return dcl;
+ return declarative_file_list_t(dcl);
}
std::ostream&
@@ -12689,7 +12926,7 @@ cbl_file_t::validate_key( const cbl_file_key_t& key ) const {
bool
cbl_file_t::validate() const {
- size_t members[] = { user_status, vsam_status, record_length };
+ const size_t members[] = { user_status, vsam_status, record_length };
bool tf = true;
for( auto isym : members ) {
@@ -12736,6 +12973,34 @@ cbl_figconst_of( const char *value ) {
return p == eovalues? normal_value_e : p->type;
}
+int
+cbl_figconst_tok( const char *value ) {
+ struct values_t {
+ const char *value; int token;
+ } static const values[] = {
+ { constant_of(constant_index(ZERO))->data.initial, ZERO },
+ { constant_of(constant_index(SPACES))->data.initial, SPACES },
+ { constant_of(constant_index(HIGH_VALUES))->data.initial, HIGH_VALUES },
+ { constant_of(constant_index(LOW_VALUES))->data.initial, LOW_VALUES },
+ { constant_of(constant_index(QUOTES))->data.initial, QUOTES },
+ { constant_of(constant_index(NULLS))->data.initial, NULLS },
+ }, *eovalues = values + COUNT_OF(values);
+
+ auto p = std::find_if( values, eovalues,
+ [value]( const values_t& elem ) {
+ return elem.value == value;
+ } );
+
+ return p == eovalues? 0 : p->token;
+}
+
+const cbl_field_t *
+cbl_figconst_field_of( const char *value ) {
+ int token = cbl_figconst_tok(value);
+ return token == 0 ? nullptr : constant_of(constant_index(token));
+}
+
+
cbl_field_attr_t
literal_attr( const char prefix[] ) {
switch(strlen(prefix)) {
@@ -12762,7 +13027,7 @@ literal_attr( const char prefix[] ) {
}
// must be [BN]X
- cbl_internal_error("'%s': invalid literal prefix", prefix);
+ cbl_internal_error("invalid literal prefix: %qs", prefix);
gcc_unreachable();
return none_e;
}
@@ -12799,10 +13064,22 @@ mode_syntax_only() {
void
cobol_dialect_set( cbl_dialect_t dialect ) {
- cbl_dialect = dialect;
- if( dialect & dialect_ibm_e ) cobol_gcobol_feature_set(feature_embiggen_e);
+ switch(dialect) {
+ case dialect_gcc_e:
+ break;
+ case dialect_ibm_e:
+ cobol_gcobol_feature_set(feature_embiggen_e);
+ break;
+ case dialect_mf_e:
+ break;
+ case dialect_gnu_e:
+ if( 0 == (cbl_dialects & dialect) ) { // first time
+ tokens.equate(YYLTYPE(), "BINARY-DOUBLE", "BINARY-C-LONG");
+ }
+ break;
+ }
+ cbl_dialects |= dialect;
}
-cbl_dialect_t cobol_dialect() { return cbl_dialect; }
static bool internal_ebcdic_locked = false;
@@ -12860,7 +13137,7 @@ literal_refmod_valid( YYLTYPE loc, const cbl_refer_t& r ) {
if( --edge < r.field->data.capacity ) return true;
}
// len < 0 or not: 0 < from + len <= capacity
- auto loc = symbol_field_location(field_index(r.field));
+ loc = symbol_field_location(field_index(r.field));
error_msg(loc, "%s(%zu:%zu) out of bounds, "
"size is %u",
r.field->name,
@@ -12883,19 +13160,22 @@ literal_subscript_oob( const cbl_refer_t& r, size_t& isub );
static bool
literal_subscripts_valid( YYLTYPE loc, const cbl_refer_t& name ) {
- static char subs[ 7 * 32 ], *esub = subs + sizeof(subs);
- char *p = subs;
size_t isub;
- // Find subscript in the supplied refer
+ // Report any out-of-bound subscript.
const cbl_field_t *oob = literal_subscript_oob(name, isub);
if( oob ) {
- const char *sep = "";
- for( auto r = name.subscripts; r < name.subscripts + name.nsubscript; r++ ) {
- snprintf( p, esub - p, "%s%s", sep, nice_name_of(r->field) );
- sep = " ";
- }
-
+ std::string sep("");
+ std::string subscript_names =
+ std::accumulate( name.subscripts.begin(),
+ name.subscripts.end(),
+ std::string(),
+ [&sep]( std::string acc, const auto& sub ) {
+ acc += sep;
+ sep = " ";
+ return acc + nice_name_of(sub.field);
+ } );
+
const char *upper_phrase = "";
if( ! oob->occurs.bounds.fixed_size() ) {
static char ub[32] = "boo";
@@ -12906,8 +13186,8 @@ literal_subscripts_valid( YYLTYPE loc, const cbl_refer_t& name ) {
// X(0): subscript 1 of for out of range for 02 X OCCURS 4 to 6
error_msg(loc, "%s(%s): subscript %zu out of range "
- "for %s %s OCCURS %lu%s",
- oob->name, subs, 1 + isub,
+ "for %s %s OCCURS %zu%s",
+ oob->name, subscript_names.c_str(), 1 + isub,
oob->level_str(), oob->name,
oob->occurs.bounds.lower, upper_phrase );
return false;
@@ -12929,14 +13209,14 @@ subscript_dimension_error( YYLTYPE loc, size_t nsub, const cbl_refer_t *scalar )
}
static void
-reject_refmod( YYLTYPE loc, cbl_refer_t scalar ) {
+reject_refmod( YYLTYPE loc, const cbl_refer_t& scalar ) {
if( scalar.is_refmod_reference() ) {
error_msg(loc, "%s cannot be reference-modified here", scalar.name());
}
}
static bool
-require_pointer( YYLTYPE loc, cbl_refer_t scalar ) {
+require_pointer( YYLTYPE loc, const cbl_refer_t& scalar ) {
if( scalar.field->type != FldPointer ) {
error_msg(loc, "%s must have USAGE POINTER", scalar.name());
return false;
@@ -12945,7 +13225,7 @@ require_pointer( YYLTYPE loc, cbl_refer_t scalar ) {
}
static bool
-require_numeric( YYLTYPE loc, cbl_refer_t scalar ) {
+require_numeric( YYLTYPE loc, const cbl_refer_t& scalar ) {
if( ! is_numeric(scalar.field) ) {
error_msg(loc, "%s must have numeric USAGE", scalar.name());
return false;
@@ -12954,7 +13234,7 @@ require_numeric( YYLTYPE loc, cbl_refer_t scalar ) {
}
static bool
-require_integer( YYLTYPE loc, cbl_refer_t scalar ) {
+require_integer( YYLTYPE loc, const cbl_refer_t& scalar ) {
if( is_literal(scalar.field) ) {
if( ! is_integer_literal(scalar.field) ) {
error_msg(loc, "numeric literal '%s' must be an integer",
generated by cgit v1.1 at 2025-07-02 04:43:17 +0000