diff --git a/gcc/cobol/failures/nc250/analyze b/gcc/cobol/failures/nc250/analyze
new file mode 100755
index 0000000000000000000000000000000000000000..2dfb0aebb12f77692f4d10ad389dbe22f669e336
--- /dev/null
+++ b/gcc/cobol/failures/nc250/analyze
@@ -0,0 +1,118 @@
+#!/usr/bin/python3
+
+import sys
+import os
+
+def extract_name(instring:str):
+ left = instring.find("#") + 2
+ right = instring.find("_analyze")
+ return instring[left:right]
+
+def extract_summary_name(instring:str):
+ left = instring.find("#") + 1
+ right = instring.rindex("_")
+ return instring[left:right]
+
+def sort_sortit(p):
+ return p[1]
+
+def main():
+ sfile:str = None
+ if len(sys.argv) == 1:
+ # There were no parameters. See if there is one, and only one,
+ # .s assembler file:
+ fcount:int = 0
+ sfile:str = None
+ files:list = os.listdir()
+ for file in files:
+ if file[-2:] == ".s":
+ fcount += 1;
+ sfile = file
+ if fcount > 1:
+ sys.exit("There are more than one .s files; specify one")
+ elif len(sys.argv) == 2:
+ sfile:str = sys.argv[1]
+ if not sfile:
+ sys.exit("{} must have one parameter, the file name".format(sys.argv[0]))
+
+ all_lines:list = open(sfile).read().split('\n')
+
+ lines:list = []
+ total_lines:int = 0
+ known_lines:int = 0
+ for line in all_lines:
+ sline:str = line.strip()
+ if len(sline) == 0:
+ continue
+ if not (line.strip()[0] in ('.', '#', '_')
+ or line.strip()[-1] == ':'):
+ total_lines += 1
+ if (line.strip()[0] in ('.', '#', '_')
+ and line.find("_analyze_enter") == -1
+ and line.find("_analyze_exit") == -1):
+ continue
+ if sline[-1] == ':':
+ continue
+ lines.append(sline)
+
+ starts:dict = {}
+ ends:dict = {}
+
+ # First pass creates the entries for _analyze_enter and _analyze_exit
+ for nline in range(len(lines)):
+ line = lines[nline]
+ if line.find("_analyze_enter") > -1:
+ starts[extract_name(line)] = nline
+ if line.find("_analyze_exit") > -1:
+ ends.update({extract_name(line) : nline})
+
+ # Create the details
+ details:dict = {}
+ for key in starts:
+ if key in ends:
+ ender = key + "_analyze_exit"
+ nlevel = 0
+ ncount = 0
+ nleft = starts[key]
+ nright = ends[key]
+ for nline in range(nright-1, nleft, -1):
+ line = lines[nline]
+ if line.find(ender) > -1:
+ continue
+ if line.find("_analyze_exit") > -1:
+ nlevel += 1;
+ continue
+ if line.find("_analyze_enter") > -1:
+ nlevel -= 1;
+ if nlevel == 0:
+ ncount += 1;
+ known_lines += 1;
+ details.update({key : ncount})
+
+ # create the summary
+ summary:dict = {}
+ for key in details:
+ summary_key = extract_summary_name(key)
+ if summary_key in summary:
+ newval = summary[summary_key] + details[key]
+ summary.update({summary_key : newval})
+ else:
+ summary.update({summary_key : details[key]})
+
+ # build a list of tuples:
+ sortit:list = []
+ for key in summary:
+ sortit.append( (key, summary[key]) )
+
+ # sort that list:
+ sortit = sorted(sortit, key=sort_sortit)
+
+ for pair in sortit:
+ print( "{0: <32} {1: >6}".format(pair[0], pair[1]) )
+
+ print("lines of assembler {0:>6}".format(total_lines))
+ print("lines accounted for {0:>6}".format(known_lines))
+ print("lines remaining {0:>6}".format(total_lines-known_lines))
+
+main()
+
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index e246f97044f6323ff8fd8e1364dea256bb758693..48e6874c410dacf1de7320f9f0427fcd231a3aca 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -14465,10 +14465,21 @@ actually_create_the_static_field( cbl_field_t *new_var,
next_field = TREE_CHAIN(next_field);
// SIZE_T, "allocated",
- CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
- next_field,
- build_int_cst_type( SIZE_T,
- new_var->data.capacity) );
+ if( data_area != null_pointer_node )
+ {
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ next_field,
+ build_int_cst_type( SIZE_T,
+ new_var->data.capacity) );
+ }
+ else
+ {
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ next_field,
+ build_int_cst_type( SIZE_T,
+ 0) );
+ }
+
next_field = TREE_CHAIN(next_field);
// SIZE_T, "offset",
@@ -14840,6 +14851,70 @@ void
parser_symbol_add(struct cbl_field_t *new_var )
{
Analyze();
+ SHOW_PARSE
+ {
+ do
+ {
+ fprintf(stderr, "( %d ) %s():", new_var->line? (new_var->line) : CURRENT_LINE_NUMBER, __func__);
+ }
+ while(0);
+
+ fprintf(stderr, " %2.2d %s<%s> off:%zd msiz:%d cap:%d dig:%d rdig:%d attr:0x%lx loc:%p",
+ new_var->level,
+ new_var->name,
+ cbl_field_type_str(new_var->type),
+ new_var->offset,
+ new_var->data.memsize,
+ new_var->data.capacity,
+ new_var->data.digits,
+ new_var->data.rdigits,
+ new_var->attr,
+ new_var);
+
+ if( is_table(new_var) )
+ {
+ fprintf(stderr," OCCURS:%zd", new_var->occurs.ntimes());
+ }
+ cbl_field_t *parent = parent_of(new_var);
+ if( parent )
+ {
+ fprintf(stderr,
+ " parent:(%zd)%s",
+ new_var->parent,
+ parent->name);
+ }
+ else
+ {
+ // Parent isn't a field
+ size_t parent_index = new_var->parent;
+ if( parent_index )
+ {
+ symbol_elem_t *e = symbol_at(parent_index);
+ if( e->type == SymFile )
+ {
+ fprintf(stderr,
+ " parent_file:(%zd)%s",
+ new_var->parent,
+ e->elem.file.name);
+ if( e->elem.file.attr & external_e )
+ {
+ fprintf(stderr, " (flagged external)");
+ }
+ }
+ }
+ }
+
+ if( symbol_redefines(new_var) )
+ {
+ fprintf(stderr,
+ " redefines:(%p)%s",
+ symbol_redefines(new_var),
+ symbol_redefines(new_var)->name);
+ }
+
+ SHOW_PARSE_END
+ }
+
if( new_var->type == FldLiteralA )
{
return;
@@ -14888,70 +14963,6 @@ parser_symbol_add(struct cbl_field_t *new_var )
return;
}
- SHOW_PARSE
- {
- do
- {
- fprintf(stderr, "( %d ) %s():", new_var->line? (new_var->line) : CURRENT_LINE_NUMBER, __func__);
- }
- while(0);
-
- fprintf(stderr, " %2.2d %s<%s> off:%zd msiz:%d cap:%d dig:%d rdig:%d attr:0x%lx loc:%p",
- new_var->level,
- new_var->name,
- cbl_field_type_str(new_var->type),
- new_var->offset,
- new_var->data.memsize,
- new_var->data.capacity,
- new_var->data.digits,
- new_var->data.rdigits,
- new_var->attr,
- new_var);
-
- if( is_table(new_var) )
- {
- fprintf(stderr," OCCURS:%zd", new_var->occurs.ntimes());
- }
- cbl_field_t *parent = parent_of(new_var);
- if( parent )
- {
- fprintf(stderr,
- " parent:(%zd)%s",
- new_var->parent,
- parent->name);
- }
- else
- {
- // Parent isn't a field
- size_t parent_index = new_var->parent;
- if( parent_index )
- {
- symbol_elem_t *e = symbol_at(parent_index);
- if( e->type == SymFile )
- {
- fprintf(stderr,
- " parent_file:(%zd)%s",
- new_var->parent,
- e->elem.file.name);
- if( e->elem.file.attr & external_e )
- {
- fprintf(stderr, " (flagged external)");
- }
- }
- }
- }
-
- if( symbol_redefines(new_var) )
- {
- fprintf(stderr,
- " redefines:(%p)%s",
- symbol_redefines(new_var),
- symbol_redefines(new_var)->name);
- }
-
- SHOW_PARSE_END
- }
-
size_t length_of_initial_string = 0;
const char *new_initial = NULL;
diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y
index c08baf627c84e36abfd558749139227b9bdefe65..ee915ea413d74e0d70c5ea6a292d962c6d9b669d 100644
--- a/gcc/cobol/parse.y
+++ b/gcc/cobol/parse.y
@@ -66,8 +66,8 @@
set_prefix( "", 0 );
set_data( field->data.capacity,
- const_cast<char*>(field->data.initial),
- field_index(field) );
+ const_cast<char*>(field->data.initial),
+ field_index(field) );
return *this;
}
literal_t&
@@ -76,9 +76,9 @@
this->len = len;
this->data = data;
if( this->prefix[0] == 'Z' ) {
- this->data = new char[++this->len];
- auto p = std::copy(data, data + len, this->data);
- *p = '\0';
+ this->data = new char[++this->len];
+ auto p = std::copy(data, data + len, this->data);
+ *p = '\0';
}
return *this;
}
@@ -96,8 +96,8 @@
relop_t op;
bool invert;
acrc_t& init( cbl_refer_t *term = NULL,
- relop_t op = relop_t(-1),
- bool invert = false )
+ relop_t op = relop_t(-1),
+ bool invert = false )
{
this->term = term;
this->op = op;
@@ -105,8 +105,8 @@
return *this;
}
static acrc_t make( cbl_refer_t *term = NULL,
- relop_t op = relop_t(-1),
- bool invert = false )
+ relop_t op = relop_t(-1),
+ bool invert = false )
{
acrc_t output;
return output.init( term, op, invert );
@@ -142,14 +142,14 @@
cbl_refer_t *orig, *replacement;
substitution_t& init( bool anycase, char first_last,
- cbl_refer_t *orig, cbl_refer_t *replacement ) {
+ cbl_refer_t *orig, cbl_refer_t *replacement ) {
this->anycase = anycase;
switch(first_last) {
case 'F': this->first_last = subst_first_e; break;
case 'L': this->first_last = subst_last_e; break;
default:
- this->first_last = subst_all_e;
- break;
+ this->first_last = subst_all_e;
+ break;
}
this->orig = orig;
this->replacement = replacement;
@@ -200,18 +200,18 @@
enum select_clause_t {
access_clause_e = 0x0001,
- alt_key_clause_e = 0x0002,
- assign_clause_e = 0x0004,
- collating_clause_e = 0x0008,
+ alt_key_clause_e = 0x0002,
+ assign_clause_e = 0x0004,
+ collating_clause_e = 0x0008,
file_status_clause_e = 0x0010,
- lock_mode_clause_e = 0x0020,
+ lock_mode_clause_e = 0x0020,
organization_clause_e = 0x0040,
padding_clause_e = 0x0080,
record_delim_clause_e = 0x0100,
- record_key_clause_e = 0x0200,
+ record_key_clause_e = 0x0200,
relative_key_clause_e = 0x0400,
- reserve_clause_e = 0x0800,
- sharing_clause_e = 0x1000,
+ reserve_clause_e = 0x0800,
+ sharing_clause_e = 0x1000,
};
struct symbol_elem_t;
@@ -273,7 +273,7 @@
%token <string> CLASS_NAME NAME NAME88 NUME NUMED NUMED_CR NUMED_DB
%token <number> NINEDOT NINES NINEV PIC_P
%token <string> SPACES
-%token <literal> LITERAL
+%token <literal> LITERAL
%token <number> END EOP
%token <string> FILENAME
%token <number> INVALID
@@ -306,7 +306,7 @@
// https://savannah.gnu.org/forum/forum.php?forum_id=9735
%token YYEOF 0 "end of file"
-%type <number> sentence sentences statements statement
+%type <number> sentence sentences statements statement
%type <number> star_cbl_opt close_how
@@ -314,20 +314,20 @@
%type <boolean> all optional sign_leading on_off initialized strong
%type <number> count data_clauses data_clause
%type <number> nine nps relop spaces_etc reserved_value signed
-%type <number> rounded rounded_mode rounded_type round_between
+%type <number> rounded rounded_mode rounded_type round_between
%type <number> variable_type
%type <number> true_false posneg
%type <number> open_io alphabet_etc
-%type <special_type> env_name1
+%type <special_type> env_name1
%type <string> numed collating_sequence context_word ctx_name locale_spec
-%type <literal> namestr alphabet_lit program_as repo_as
+%type <literal> namestr alphabet_lit program_as repo_as
%type <field> perform_cond kind_of_name alloc_ret
%type <refer> simple_cond
%type <relop_term> and_term bool_expr
-%type <relop_result> rel_expr
+%type <relop_result> rel_expr
%type <refer> rel_operand num_value num_term value factor
-%type <field_data> value78
+%type <field_data> value78
%type <field> literal name nume typename
%type <field> advance_by num_literal signed_literal
%type <refer> perform_times
@@ -337,20 +337,20 @@
%type <vargs> vargs disp_vargs;
%type <field> level_name
%type <string> fd_name picture_sym name66
-%type <literal> literal_part literalism
+%type <literal> literal_part literalism
%type <number> bound advance_when org_clause1 read_next
%type <number> access_mode multiple lock_how lock_mode
%type <select_clauses> select_clauses
-%type <select_clause> select_clause access_clause alt_key_clause
- assign_clause collate_clause status_clause
- lock_mode_clause org_clause padding_clause
- record_delim_clause record_key_clause
- relative_key_clause reserve_clause sharing_clause
+%type <select_clause> select_clause access_clause alt_key_clause
+ assign_clause collate_clause status_clause
+ lock_mode_clause org_clause padding_clause
+ record_delim_clause record_key_clause
+ relative_key_clause reserve_clause sharing_clause
%type <file> filename read_body write_body delete_body
-%type <rewrite_t> rewrite_body
-%type <min_max> record_vary rec_contains from_to record_desc
-%type <file_op> read_file rewrite1 write_file
+%type <rewrite_t> rewrite_body
+%type <min_max> record_vary rec_contains from_to record_desc
+%type <file_op> read_file rewrite1 write_file
%type <field> advancing data_descr data_descr1 write_what file_record
%type <refer> alphaval alpha_val scalar numeref varg varg1 name88
%type <refer> expr expr_term compute_expr free_tgt by_value_arg
@@ -400,7 +400,7 @@
%type <refer2> str_into
%type <refers> sum name88s ffi_names
-%type <delimited_1> str_delimited
+%type <delimited_1> str_delimited
%type <delimiteds> str_delimiteds
%type <str_body> string_body
@@ -415,8 +415,8 @@
%type <error> on_overflow on_overflows
%type <error> arith_err arith_errs
-%type <error> call_except call_excepts
-%type <compute_body_t> compute_body
+%type <error> call_except call_excepts
+%type <compute_body_t> compute_body
%type <refer> ffi_name set_operand set_tgt scalar_arg unstring_src
%type <number> /* addr_len_of */ alphanum_pic
@@ -433,9 +433,9 @@
%type <error_clauses> io_invalids read_eofs write_eops
%type <boolean> io_invalid read_eof write_eop
- global is_global anycase
+ global is_global anycase
%type <number> mistake globally first_last
-%type <use_culprit> culprits
+%type <use_culprit> culprits
%type <labels> labels
%type <label> label_1 declaratives section
@@ -454,11 +454,11 @@
%type <replacement> init_by
%type <replacements> init_bys init_replace
%type <refer> init_data stop_how stop_status
-%type <float128> cce_expr cce_factor const_value
-%type <prog_end> end_program1
-%type <substitution> subst_input
-%type <substitutions> subst_inputs
-%type <numval_locale_t> numval_locale
+%type <float128> cce_expr cce_factor const_value
+%type <prog_end> end_program1
+%type <substitution> subst_input
+%type <substitutions> subst_inputs
+%type <numval_locale_t> numval_locale
%union {
bool boolean;
@@ -503,7 +503,7 @@
struct file_sort_io_t *sort_io;
struct arith_t *arith;
struct { size_t ntgt; cbl_num_result_t *tgts;
- cbl_refer_t *expr; } compute_body_t;
+ 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;
@@ -547,8 +547,8 @@
category_map_t *replacements;
init_statement_t *init_stmt;
struct { cbl_special_name_t *special; vargs_t *vargs; } display;
- substitution_t substitution;
- substitutions_t *substitutions;
+ substitution_t substitution;
+ substitutions_t *substitutions;
struct { bool is_locale; cbl_refer_t *arg2; } numval_locale_t;
}
@@ -557,32 +557,32 @@
%printer { fprintf(yyo, "%s %s", refer_type_str($$), $$? $$->name() : "<none>"); } <refer>
%printer { fprintf(yyo, "%s", $$? name_of($$) : "[omitted]"); } alloc_ret
%printer { fprintf(yyo, "%s %s '%s' (%s)",
- $$? cbl_field_type_str($$->type) : "<%empty>",
- $$? name_of($$) : "",
- $$? $$->data.initial? $$->data.initial : "<nil>" : "",
- $$? $$->value_str() : "" ); } <field>
+ $$? cbl_field_type_str($$->type) : "<%empty>",
+ $$? name_of($$) : "",
+ $$? $$->data.initial? $$->data.initial : "<nil>" : "",
+ $$? $$->value_str() : "" ); } <field>
%printer { fprintf(yyo, "%s {%c%s %s}",
- $$.cond->field->name,
- $$.ante.invert? '!' : ' ',
- $$.ante.term? $$.ante.term->name() : "",
- $$.ante.term? relop_str($$.ante.op) : ""); } <relop_term>
+ $$.cond->field->name,
+ $$.ante.invert? '!' : ' ',
+ $$.ante.term? $$.ante.term->name() : "",
+ $$.ante.term? relop_str($$.ante.op) : ""); } <relop_term>
%printer { fprintf(yyo, "[%s] %s {%c%s %s}",
- cbl_field_type_str($$.cond->field->type),
- $$.cond->field->name,
- $$.ante.invert? '!' : ' ',
- $$.ante.term? $$.ante.term->name() : "",
- $$.ante.term? relop_str($$.ante.op) : ""); } <relop_result>
+ cbl_field_type_str($$.cond->field->type),
+ $$.cond->field->name,
+ $$.ante.invert? '!' : ' ',
+ $$.ante.term? $$.ante.term->name() : "",
+ $$.ante.term? relop_str($$.ante.op) : ""); } <relop_result>
%printer { fprintf(yyo, "%s (token %d)", keyword_str($$), $$ ); } relop
%printer { fprintf(yyo, "'%s'", $$? $$ : "" ); } NAME <string>
%printer { fprintf(yyo, "%s'%.*s'{%zu} %s", $$.prefix, int($$.len), $$.data, $$.len,
- $$.symbol_name()); } <literal>
+ $$.symbol_name()); } <literal>
%printer { fprintf(yyo, "%s (1st of %zu)",
- $$->targets.empty()? "" : $$->targets.front().refer.field->name,
- $$->targets.size() ); } <targets>
+ $$->targets.empty()? "" : $$->targets.front().refer.field->name,
+ $$->targets.size() ); } <targets>
%printer { fprintf(yyo, "#%zu: %s",
- is_temporary($$)? 0 : field_index($$),
- $$? name_of($$) : "<nil>" ); } name
+ is_temporary($$)? 0 : field_index($$),
+ $$? name_of($$) : "<nil>" ); } name
%printer { fprintf(yyo, "{%zu-%zu}", $$.min, $$.max ); } <min_max>
%printer { fprintf(yyo, "{%s}", $$? "+/-" : "" ); } signed
%printer { fprintf(yyo, "{%s of %zu}", names.front(), names.size() ); } qname
@@ -591,30 +591,30 @@
%printer { const char *s = string_of($$);
fprintf(yyo, "{%s}", s? s : "??" ); } <float128>
%printer { fprintf(yyo, "{%s %c%u}", cbl_field_type_str($$.type),
- $$.signable? '+' : ' ',
- $$.capacity ); } <computational>
+ $$.signable? '+' : ' ',
+ $$.capacity ); } <computational>
%printer { fprintf(yyo, "{'%s'-'%s'%s}",
- $$.low? (const char*) $$.low : "",
- $$.high? (const char*) $$.high : "",
- $$.also? "+" : "" ); } <colseq>
+ $$.low? (const char*) $$.low : "",
+ $$.high? (const char*) $$.high : "",
+ $$.also? "+" : "" ); } <colseq>
%printer { fprintf(yyo, "{%s, %zu parameters}",
- name_of($$.ffi_name->field), !$$.using_params? 0 :
- $$.using_params->elems.size()); } call_body
+ name_of($$.ffi_name->field), !$$.using_params? 0 :
+ $$.using_params->elems.size()); } call_body
%printer { fprintf(yyo, "%s <- %s", data_category_str($$.category),
- name_of($$.replacement->field)); } init_by
+ name_of($$.replacement->field)); } init_by
/* CDF (COPY and >> defined here but used in cdf.y) */
%left BASIS CBL CONSTANT COPY
- DEFINED ENTER FEATURE INSERT
+ DEFINED ENTER FEATURE INSERT
LIST LSUB MAP NOLIST NOMAP NOSOURCE
- PARAMETER_kw OVERRIDE READY RESET RSUB
+ PARAMETER_kw OVERRIDE READY RESET RSUB
SERVICE_RELOAD STAR_CBL
- SUBSCRIPT SUPPRESS TITLE TRACE USE
+ SUBSCRIPT SUPPRESS TITLE TRACE USE
- CDF_DEFINE CDF_DISPLAY
- CDF_IF CDF_ELSE CDF_END_IF
- CDF_EVALUATE CDF_WHEN CDF_END_EVALUATE
- CALL_COBOL CALL_VERBATIM
+ CDF_DEFINE CDF_DISPLAY
+ CDF_IF CDF_ELSE CDF_END_IF
+ CDF_EVALUATE CDF_WHEN CDF_END_EVALUATE
+ CALL_COBOL CALL_VERBATIM
%right IF THEN ELSE
SENTENCE
@@ -626,23 +626,23 @@
READ RELEASE RETURN REWRITE
SECTION_NAME
SEARCH SET SELECT SORT SORT_MERGE
- STRING_kw STOP SUBTRACT START
+ STRING_kw STOP SUBTRACT START
UNSTRING WRITE WHEN INVALID
%left ABS ACCESS ACOS ACTUAL ADVANCING AFP_5A AFTER ALL
- ALLOCATE
+ ALLOCATE
ALPHABET ALPHABETIC ALPHABETIC_LOWER
ALPHABETIC_UPPER ALPHANUMERIC ALPHANUMERIC_EDITED
ALPHED ALSO ALTERNATE ANNUITY ANY ANYCASE APPLY ARE
- AREA AREAS AS
+ AREA AREAS AS
ASCENDING ASIN ASSIGN AT ATAN AUTHOR
BASED BEFORE BINARY BIT BIT_OF BIT_TO_CHAR BLANK BLOCK
- BOTTOM BY BYTE_LENGTH
+ BOTTOM BY BYTE_LENGTH
C01 C02 C03 C04 C05 C06 C07 C08 C09 C10 C11 C12 CF CH
CHANGED CHAR CHARACTER CHARACTERS CHECKING CLASS
- COBOL CODE CODESET COLLATING
+ COBOL CODE CODESET COLLATING
COLUMN COMBINED_DATETIME COMMA COMMAND_LINE
COMMAND_LINE_COUNT COMMIT COMMON COMPUTATIONAL
CONCAT CONDITION CONFIGURATION_SECT CONSOLE CONTAINS
@@ -660,24 +660,24 @@
E EBCDIC EC EGCS ENTRY ENVIRONMENT EQUAL ERROR EVERY
EXAMINE EXCEPTION EXHIBIT EXP EXP10 EXTEND EXTERNAL
- EXCEPTION_FILE EXCEPTION_FILE_N
- EXCEPTION_LOCATION EXCEPTION_LOCATION_N
- EXCEPTION_NAME
- EXCEPTION_STATEMENT EXCEPTION_STATUS
+ EXCEPTION_FILE EXCEPTION_FILE_N
+ EXCEPTION_LOCATION EXCEPTION_LOCATION_N
+ EXCEPTION_NAME
+ EXCEPTION_STATEMENT EXCEPTION_STATUS
FACTORIAL FALSE_kw FD FILENAME FILE_CONTROL FILE_KW
FILE_LIMIT FINAL FIRST FIXED FOOTING FOR
FORMATTED_CURRENT_DATE FORMATTED_DATE FORMATTED_DATETIME
FORMATTED_TIME FORM_OVERFLOW FREE
- FRACTION_PART FROM FUNCTION FUNCTION_UDF
+ FRACTION_PART FROM FUNCTION FUNCTION_UDF
GENERATE GIVING GLOBAL GO GROUP
HEADING HEX_OF HEX_TO_CHAR
- HIGH_VALUE HIGH_VALUES HIGHEST_ALGEBRAIC HOLD
+ HIGH_VALUE HIGH_VALUES HIGHEST_ALGEBRAIC HOLD
IBM_360 IN INCLUDE INDEX INDEXED INDICATE INITIAL_kw
INITIATE INPUT INSTALLATION INTERFACE
- INTEGER INTEGER_OF_DATE
+ INTEGER INTEGER_OF_DATE
INTEGER_OF_DAY INTEGER_OF_FORMATTED_DATE INTEGER_PART
INTO INTRINSIC INVOKE IO IO_CONTROL IS ISNT
@@ -685,47 +685,47 @@
LABEL LAST LEADING LEFT LENGTH LENGTH_OF LEVEL LEVEL66
LEVEL88 LIMIT LIMITS LINE LINES LINE_COUNTER
- LINAGE LINKAGE LOCALE LOCALE_COMPARE
- LOCALE_DATE LOCALE_TIME LOCALE_TIME_FROM_SECONDS
- LOCAL_STORAGE LOCATION
+ LINAGE LINKAGE LOCALE LOCALE_COMPARE
+ LOCALE_DATE LOCALE_TIME LOCALE_TIME_FROM_SECONDS
+ LOCAL_STORAGE LOCATION
LOCK LOCK_ON LOG LOG10 LOWER_CASE LOW_VALUE LOW_VALUES
- LOWEST_ALGEBRAIC LPAREN
+ LOWEST_ALGEBRAIC LPAREN
MANUAL MAX MEAN MEDIAN MIDRANGE
- MIGHT_BE MIN MULTIPLE MOD MODE
+ MIGHT_BE MIN MULTIPLE MOD MODE
NAMED NATIONAL NATIONAL_EDITED NATIONAL_OF
NATIVE NEGATIVE NEXT NINEDOT NINES NINEV NO NOTE
NO_CONDITION NULLS NULLPTR NUMBER
- NUME NUMED NUMED_CR NUMED_DB NUMERIC
+ NUME NUMED NUMED_CR NUMED_DB NUMERIC
NUMERIC_EDITED NUMSTR NUMVAL NUMVAL_C NUMVAL_F
OCCURS OF OFF OMITTED ON ONLY OPTIONAL OPTIONS ORD ORDER
ORD_MAX ORD_MIN ORGANIZATION OTHER OTHERWISE OUTPUT
PACKED_DECIMAL PADDING PAGE PAGE_COUNTER
- PF PH PI PIC PICTURE PIC_P
+ PF PH PI PIC PICTURE PIC_P
PLUS POINTER POSITIVE PRESENT_VALUE PRINT_SWITCH
PROCEDURE PROCEDURES PROCEED PROCESS
- PROGRAM_ID PROGRAM_kw PROPERTY PROTOTYPE PSEUDOTEXT
+ PROGRAM_ID PROGRAM_kw PROPERTY PROTOTYPE PSEUDOTEXT
QUOTE QUOTES
RANDOM RANDOM_SEED RANGE RAISE
- RD RECORD RECORDING RECORDS RECURSIVE
+ RD RECORD RECORDING RECORDS RECURSIVE
REDEFINES REEL REFERENCE RELATIVE REM REMAINDER REMARKS
REMOVAL RENAMES REPLACE REPLACING REPORT REPORTING REPORTS
- REPOSITORY RERUN RESERVE RESTRICTED RESUME
- REVERSE REVERSED REWIND RF RH RIGHT ROUNDED RUN
+ REPOSITORY RERUN RESERVE RESTRICTED RESUME
+ REVERSE REVERSED REWIND RF RH RIGHT ROUNDED RUN
S01 S02 S03 S04 S05 SAME SCREEN SD SECONDS_FROM_FORMATTED_TIME
SECONDS_PAST_MIDNIGHT SECTION SECURITY
SEPARATE SEQUENCE SEQUENTIAL SHARING
- SIGN SIN SIZE SIZE_ERROR SOURCE SOURCE_COMPUTER
+ SIGN SIN SIZE SIZE_ERROR SOURCE SOURCE_COMPUTER
SPACES SPECIAL_NAMES SQRT STANDARD STANDARD_ALPHABET
STANDARD_1 STANDARD_DEVIATION STATUS STRONG
- STDERR STDIN STDOUT
- LITERAL SUBSTITUTE SUM SWITCH SYMBOL SYMBOLIC SYNCHRONIZED
+ STDERR STDIN STDOUT
+ LITERAL SUBSTITUTE SUM SWITCH SYMBOL SYMBOLIC SYNCHRONIZED
SYSIN SYSIPT SYSLST SYSOUT SYSPCH SYSPUNCH
TALLY TALLYING TAN TERMINATE TEST TEST_DATE_YYYYMMDD
@@ -740,35 +740,35 @@
VALUE VARIANCE VARYING VOLATILE
- WHEN_COMPILED WITH WORKING_STORAGE
+ WHEN_COMPILED WITH WORKING_STORAGE
XML XMLGENERATE XMLPARSE
YEAR_TO_YYYY YYYYDDD YYYYMMDD
ZERO
- /* unused Context Words */
- ARITHMETIC ATTRIBUTE AUTO AUTOMATIC AWAY_FROM_ZERO
- BACKGROUND_COLOR BELL BINARY_ENCODING BLINK
- CAPACITY CENTER CLASSIFICATION CYCLE
- DECIMAL_ENCODING ENTRY_CONVENTION EOL EOS ERASE EXPANDS
- FLOAT_BINARY FLOAT_DECIMAL FOREGROUND_COLOR FOREVER FULL
- HIGHLIGHT HIGH_ORDER_LEFT HIGH_ORDER_RIGHT
- IGNORING IMPLEMENTS INITIALIZED INTERMEDIATE
- LC_ALL_kw LC_COLLATE_kw LC_CTYPE_kw LC_MESSAGES_kw
- LC_MONETARY_kw LC_NUMERIC_kw LC_TIME_kw
- LOWLIGHT
- NEAREST_AWAY_FROM_ZERO NEAREST_EVEN NEAREST_TOWARD_ZERO
- NONE NORMAL NUMBERS
- PREFIXED PREVIOUS PROHIBITED RELATION REQUIRED
- REVERSE_VIDEO ROUNDING
- SECONDS SECURE SHORT SIGNED STANDARD_BINARY
- STANDARD_DECIMAL STATEMENT STEP STRUCTURE
- TOWARD_GREATER TOWARD_LESSER TRUNCATION
- UCS_4 UNDERLINE UNSIGNED UTF_16 UTF_8
+ /* unused Context Words */
+ ARITHMETIC ATTRIBUTE AUTO AUTOMATIC AWAY_FROM_ZERO
+ BACKGROUND_COLOR BELL BINARY_ENCODING BLINK
+ CAPACITY CENTER CLASSIFICATION CYCLE
+ DECIMAL_ENCODING ENTRY_CONVENTION EOL EOS ERASE EXPANDS
+ FLOAT_BINARY FLOAT_DECIMAL FOREGROUND_COLOR FOREVER FULL
+ HIGHLIGHT HIGH_ORDER_LEFT HIGH_ORDER_RIGHT
+ IGNORING IMPLEMENTS INITIALIZED INTERMEDIATE
+ LC_ALL_kw LC_COLLATE_kw LC_CTYPE_kw LC_MESSAGES_kw
+ LC_MONETARY_kw LC_NUMERIC_kw LC_TIME_kw
+ LOWLIGHT
+ NEAREST_AWAY_FROM_ZERO NEAREST_EVEN NEAREST_TOWARD_ZERO
+ NONE NORMAL NUMBERS
+ PREFIXED PREVIOUS PROHIBITED RELATION REQUIRED
+ REVERSE_VIDEO ROUNDING
+ SECONDS SECURE SHORT SIGNED STANDARD_BINARY
+ STANDARD_DECIMAL STATEMENT STEP STRUCTURE
+ TOWARD_GREATER TOWARD_LESSER TRUNCATION
+ UCS_4 UNDERLINE UNSIGNED UTF_16 UTF_8
%left CLASS_NAME NAME NAME88
%left ADDRESS
%left END_ACCEPT END_ADD END_CALL END_COMPUTE
- END_DELETE END_DISPLAY END_DIVIDE
+ END_DELETE END_DISPLAY END_DIVIDE
END_EVALUATE END_MULTIPLY END_PERFORM
END_READ END_RETURN END_REWRITE
END_SEARCH END_STRING END_SUBTRACT END_START
@@ -805,32 +805,32 @@
bool ok = true;
// The only targets that can have addr_of are BASED or in Linkage Section.
auto baddie = std::find_if( tgts.targets.begin(),
- tgts.targets.end(),
- []( const auto& num_result ) {
- if( num_result.refer.addr_of ) {
- auto f = num_result.refer.field;
- if( ! (f->has_attr(based_e) || f->has_attr(linkage_e)) ) {
- return true;
- }
- }
- return false;
- } );
+ tgts.targets.end(),
+ []( const auto& num_result ) {
+ if( num_result.refer.addr_of ) {
+ auto f = num_result.refer.field;
+ if( ! (f->has_attr(based_e) || f->has_attr(linkage_e)) ) {
+ return true;
+ }
+ }
+ return false;
+ } );
if( baddie != tgts.targets.end() ) {
yyerrorv( "error: target %s must be BASED or in LINKAGE SECTION",
- baddie->refer.name() );
+ baddie->refer.name() );
return false;
}
for( const auto& num_result : tgts.targets ) {
if( refer_pointer(num_result) ) {
- if( !want_pointers ) {
- ok = false;
- yyerrorv( "error: %s is a pointer", num_result.refer.name() );
+ if( !want_pointers ) {
+ ok = false;
+ yyerrorv( "error: %s is a pointer", num_result.refer.name() );
}
} else {
- if( want_pointers ) {
- ok = false;
- yyerrorv( "error: %s is not a pointer", num_result.refer.name() );
+ if( want_pointers ) {
+ ok = false;
+ yyerrorv( "error: %s is not a pointer", num_result.refer.name() );
}
}
}
@@ -857,18 +857,18 @@
static void
initialize_statement( std::list<cbl_refer_t> tgts,
- bool with_filler,
- data_category_t category,
- const category_map_t& replacement = category_map_t(),
- bool to_default = false );
+ bool with_filler,
+ data_category_t category,
+ const category_map_t& replacement = category_map_t(),
+ bool to_default = false );
unsigned char cbl_alphabet_t::nul_string[2] = ""; // 2 NULs lets us use one
unsigned char *nul_string() { return cbl_alphabet_t::nul_string; }
static inline literal_t literal_of( char *s ) {
- literal_t output;
- return output.set( strlen(s), s, "" );
+ literal_t output;
+ return output.set( strlen(s), s, "" );
}
static inline char * string_of( const literal_t& lit ) {
return strlen(lit.data) == lit.len? lit.data : NULL;
@@ -879,9 +879,9 @@
char output[64];
int len = strfromf128 (output, sizeof(output), format, cce);
if( sizeof(output) < size_t(len) ) {
- yyerrorv("error: string_of: value requires %d digits (of %zu)",
- len, sizeof(output));
- return strdup(empty);
+ yyerrorv("error: string_of: value requires %d digits (of %zu)",
+ len, sizeof(output));
+ return strdup(empty);
}
char decimal = symbol_decimal_point();
@@ -893,53 +893,53 @@
new_literal( const literal_t& lit, enum cbl_field_attr_t attr );
static acrc_t * apply_acrcs( cbl_refer_t *cond,
- const acrc_t& ante, acrcs_t& abbrs,
- logop_t and_or, acrc_t& rhs );
+ const acrc_t& ante, acrcs_t& abbrs,
+ logop_t and_or, acrc_t& rhs );
%}
%locations
%expect 3
-%require "3.5.1" // 3.8.2 also works, but not 3.8.0
+%require "3.5.1" // 3.8.2 also works, but not 3.8.0
%%
top: programs
{
- if( ! goodnight_gracie() ) {
- YYABORT;
- }
+ if( ! goodnight_gracie() ) {
+ YYABORT;
+ }
if( nparse_error > 0 ) YYABORT;
}
| programs end_program
- {
- if( nparse_error > 0 ) YYABORT;
- }
+ {
+ if( nparse_error > 0 ) YYABORT;
+ }
;
programs: program
| programs end_program program
;
program: cdf_empty id_div options_para env_div data_div
- {
- if( ! data_division_ready() ) YYERROR;
- current_division = procedure_div_e;
- }
- procedure_div
{
- if( yydebug ) labels_dump();
- }
+ if( ! data_division_ready() ) YYERROR;
+ current_division = procedure_div_e;
+ }
+ procedure_div
+ {
+ if( yydebug ) labels_dump();
+ }
;
id_div: IDENTIFICATION_DIV '.' program_id author
| program_id author
- | IDENTIFICATION_DIV '.' function_id
+ | IDENTIFICATION_DIV '.' function_id
;
program_id: PROGRAM_ID dot namestr[name] program_as program_attrs[attr] dot
{
- const char *name = string_of($name);
+ const char *name = string_of($name);
- internal_ebcdic_lock();
+ internal_ebcdic_lock();
current_division = identification_div_e;
parser_division( identification_div_e, NULL, 0, NULL );
location_set(@1);
@@ -948,26 +948,26 @@ program_id: PROGRAM_ID dot namestr[name] program_as program_attrs[attr] dot
symbol_table_init();
}
if( !current.new_program(LblProgram, name, $program_as.data,
- $attr.common, $attr.initial) ) {
- auto L = symbol_program(current_program_index(), name);
- assert(L);
- yyerrorv("error: PROGRAM-ID %s already defined on line %d",
- name, L->line);
- YYERROR;
- }
+ $attr.common, $attr.initial) ) {
+ auto L = symbol_program(current_program_index(), name);
+ assert(L);
+ yyerrorv("error: PROGRAM-ID %s already defined on line %d",
+ name, L->line);
+ YYERROR;
+ }
if( nparse_error > 0 ) YYABORT;
}
;
-dot: %empty
- | '.'
- ;
-program_as: %empty { $$ = (literal_t){}; }
- | AS LITERAL { $$ = $2; }
- ;
+dot: %empty
+ | '.'
+ ;
+program_as: %empty { $$ = (literal_t){}; }
+ | AS LITERAL { $$ = $2; }
+ ;
-function_id: FUNCTION '.' NAME program_as program_attrs[attr] '.'
+function_id: FUNCTION '.' NAME program_as program_attrs[attr] '.'
{
- internal_ebcdic_lock();
+ internal_ebcdic_lock();
current_division = identification_div_e;
parser_division( identification_div_e, NULL, 0, NULL );
statement_begin(@1, FUNCTION);
@@ -976,110 +976,110 @@ function_id: FUNCTION '.' NAME program_as program_attrs[attr] '.'
symbol_table_init();
}
if( !current.new_program(LblFunction, $NAME, $program_as.data,
- $attr.common, $attr.initial) ) {
- auto L = symbol_program(current_program_index(), $NAME);
- assert(L);
- yyerrorv("error: FUNCTION %s already defined on line %d",
- $NAME, L->line);
- YYERROR;
- }
- if( keyword_tok($NAME, true) ) {
- yyerrorv("error: FUNCTION %s is an intrinsic function",
- $NAME);
- YYERROR;
- }
- current.udf_add(current_program_index());
+ $attr.common, $attr.initial) ) {
+ auto L = symbol_program(current_program_index(), $NAME);
+ assert(L);
+ yyerrorv("error: FUNCTION %s already defined on line %d",
+ $NAME, L->line);
+ YYERROR;
+ }
+ if( keyword_tok($NAME, true) ) {
+ yyerrorv("error: FUNCTION %s is an intrinsic function",
+ $NAME);
+ YYERROR;
+ }
+ current.udf_add(current_program_index());
if( nparse_error > 0 ) YYABORT;
}
- | FUNCTION '.' NAME program_as is PROTOTYPE '.'
- {
- yyerror("error: FUNCTION PROTOTYPE: not implemented");
- }
- ;
-
-options_para: %empty
- | OPTIONS opt_clauses '.'
- { yyerror("error: unimplemented: OPTIONS"); }
- | OPTIONS
- ;
-
-opt_clauses: opt_clause
- | opt_clauses opt_clause
- ;
-opt_clause: opt_arith
- | opt_round
- | opt_entry
- | opt_binary
- | opt_decimal
- | opt_intermediate
- | opt_init { yyerror("error: unimplemented: OPTIONS INITIALIZE"); }
- ;
-
-opt_arith: ARITHMETIC is opt_arith_type
- ;
-opt_arith_type: NATIVE
- | STANDARD
- | STANDARD_BINARY
- | STANDARD_DECIMAL
- ;
-opt_round: DEFAULT ROUNDED mode is rounded_type[token]
- {
- current_rounded_mode($token);
- }
- ;
-opt_entry: ENTRY_CONVENTION is COBOL
- ;
-opt_binary: FLOAT_BINARY default_kw is HIGH_ORDER_LEFT
- | FLOAT_BINARY default_kw is HIGH_ORDER_RIGHT
- ;
-default_kw: %empty
- | DEFAULT
- ;
-opt_decimal: FLOAT_DECIMAL default_kw is HIGH_ORDER_LEFT
- | FLOAT_DECIMAL default_kw is HIGH_ORDER_RIGHT
- | FLOAT_DECIMAL default_kw is BINARY_ENCODING
- | FLOAT_DECIMAL default_kw is DECIMAL_ENCODING
- ;
+ | FUNCTION '.' NAME program_as is PROTOTYPE '.'
+ {
+ yyerror("error: FUNCTION PROTOTYPE: not implemented");
+ }
+ ;
+
+options_para: %empty
+ | OPTIONS opt_clauses '.'
+ { yyerror("error: unimplemented: OPTIONS"); }
+ | OPTIONS
+ ;
+
+opt_clauses: opt_clause
+ | opt_clauses opt_clause
+ ;
+opt_clause: opt_arith
+ | opt_round
+ | opt_entry
+ | opt_binary
+ | opt_decimal
+ | opt_intermediate
+ | opt_init { yyerror("error: unimplemented: OPTIONS INITIALIZE"); }
+ ;
+
+opt_arith: ARITHMETIC is opt_arith_type
+ ;
+opt_arith_type: NATIVE
+ | STANDARD
+ | STANDARD_BINARY
+ | STANDARD_DECIMAL
+ ;
+opt_round: DEFAULT ROUNDED mode is rounded_type[token]
+ {
+ current_rounded_mode($token);
+ }
+ ;
+opt_entry: ENTRY_CONVENTION is COBOL
+ ;
+opt_binary: FLOAT_BINARY default_kw is HIGH_ORDER_LEFT
+ | FLOAT_BINARY default_kw is HIGH_ORDER_RIGHT
+ ;
+default_kw: %empty
+ | DEFAULT
+ ;
+opt_decimal: FLOAT_DECIMAL default_kw is HIGH_ORDER_LEFT
+ | FLOAT_DECIMAL default_kw is HIGH_ORDER_RIGHT
+ | FLOAT_DECIMAL default_kw is BINARY_ENCODING
+ | FLOAT_DECIMAL default_kw is DECIMAL_ENCODING
+ ;
opt_intermediate:
- INTERMEDIATE ROUNDING is round_between
- ;
-
-opt_init: INITIALIZE opt_init_sects SECTION to opt_init_value
- | INITIALIZE opt_init_sects to opt_init_value
- ;
-opt_init_sects: ALL
- | opt_init_sect
- | opt_init_sects opt_init_sect
- ;
-opt_init_sect: LOCAL_STORAGE
- | SCREEN { yyerror("error: unimplemented: SCREEN SECTION"); }
- | WORKING_STORAGE
- ;
-opt_init_value: BINARY ZERO
- | HIGH_VALUES
- | LITERAL
- | LOW_VALUES
- | SPACES
- ;
+ INTERMEDIATE ROUNDING is round_between
+ ;
+
+opt_init: INITIALIZE opt_init_sects SECTION to opt_init_value
+ | INITIALIZE opt_init_sects to opt_init_value
+ ;
+opt_init_sects: ALL
+ | opt_init_sect
+ | opt_init_sects opt_init_sect
+ ;
+opt_init_sect: LOCAL_STORAGE
+ | SCREEN { yyerror("error: unimplemented: SCREEN SECTION"); }
+ | WORKING_STORAGE
+ ;
+opt_init_value: BINARY ZERO
+ | HIGH_VALUES
+ | LITERAL
+ | LOW_VALUES
+ | SPACES
+ ;
namestr: ctx_name {
- $$ = literal_of($1);
- if( ! string_of($$) ) {
- yyerrorv("'%s' has embedded NUL", $$.data);
- YYERROR;
- }
- }
+ $$ = literal_of($1);
+ if( ! string_of($$) ) {
+ yyerrorv("'%s' has embedded NUL", $$.data);
+ YYERROR;
+ }
+ }
| LITERAL {
- if( $$.prefix[0] != '\0' ) {
- yyerrorv("error: literal cannot use %s prefix in this context",
- $$.prefix);
- YYERROR;
- }
- if( !is_cobol_word($$.data) ) {
- yyerrorv("error: literal '%s' must be a COBOL or C identifier",
- $$.data);
- }
- }
+ if( $$.prefix[0] != '\0' ) {
+ yyerrorv("error: literal cannot use %s prefix in this context",
+ $$.prefix);
+ YYERROR;
+ }
+ if( !is_cobol_word($$.data) ) {
+ yyerrorv("error: literal '%s' must be a COBOL or C identifier",
+ $$.data);
+ }
+ }
;
program_attrs: %empty { $$.common = $$.initial = $$.recursive = false; }
@@ -1087,49 +1087,49 @@ program_attrs: %empty { $$.common = $$.initial = $$.recursive = false; }
;
comminits: comminit
| comminits comminit {
- if( ($1.initial && $2.recursive) ||
- ($2.initial && $1.recursive) ) {
- yyerror("syntax error: INITIAL cannot be used with RECURSIVE");
- }
- if( $2.common ) {
- if( $1.common ) {
- yyerror("syntax error: COMMON repeated");
- }
- $1.common = $2.common;
- }
- if( $2.initial ) {
- if( $1.initial ) {
- yyerror("syntax error: INITIAL repeated");
- }
- $1.initial = $2.initial;
- }
- if( $2.recursive ) {
- // yyerror("syntax error: not implemented: RECURSIVE");
- // if( $1.recursive ) {
- // yyerror("syntax error: RECURSIVE repeated");
- // }
- $1.recursive = $2.recursive;
- }
-
- $$ = $1;
- }
+ if( ($1.initial && $2.recursive) ||
+ ($2.initial && $1.recursive) ) {
+ yyerror("syntax error: INITIAL cannot be used with RECURSIVE");
+ }
+ if( $2.common ) {
+ if( $1.common ) {
+ yyerror("syntax error: COMMON repeated");
+ }
+ $1.common = $2.common;
+ }
+ if( $2.initial ) {
+ if( $1.initial ) {
+ yyerror("syntax error: INITIAL repeated");
+ }
+ $1.initial = $2.initial;
+ }
+ if( $2.recursive ) {
+ // yyerror("syntax error: not implemented: RECURSIVE");
+ // if( $1.recursive ) {
+ // yyerror("syntax error: RECURSIVE repeated");
+ // }
+ $1.recursive = $2.recursive;
+ }
+
+ $$ = $1;
+ }
;
comminit: COMMON {
- if( program_level() == 0 ) { // PROGRAM-ID being parsed not added yet.
- yyerror("error: COMMON may be used only in a contained program");
- }
- $$.common = true;
- $$.initial = $$.recursive = false;
- }
+ if( program_level() == 0 ) { // PROGRAM-ID being parsed not added yet.
+ yyerror("error: COMMON may be used only in a contained program");
+ }
+ $$.common = true;
+ $$.initial = $$.recursive = false;
+ }
| INITIAL_kw { $$.initial = true; $$.common = $$.recursive = false;}
- | RECURSIVE {
- //yyerror("syntax error: not implemented: RECURSIVE");
- $$.recursive = true; $$.common = $$.initial = false;
- }
+ | RECURSIVE {
+ //yyerror("syntax error: not implemented: RECURSIVE");
+ $$.recursive = true; $$.common = $$.initial = false;
+ }
;
author: %empty
- | cdf
+ | cdf
| AUTHOR NAME
{
current.new_author($NAME);
@@ -1139,8 +1139,8 @@ author: %empty
env_div: %empty { current_division = environment_div_e; }
| ENVIRONMENT_DIV '.' { current_division = environment_div_e; }
| ENVIRONMENT_DIV '.' {
- current_division = environment_div_e;
- } env_sections
+ current_division = environment_div_e;
+ } env_sections
;
env_sections: env_section
@@ -1152,7 +1152,7 @@ env_section: INPUT_OUTPUT_SECT '.'
| INPUT_OUTPUT_SECT '.' selects { /* IBM requires FILE CONTROL. */ }
| CONFIGURATION_SECT '.'
| CONFIGURATION_SECT '.' config_paragraphs
- | cdf
+ | cdf
;
io_sections: io_section
@@ -1160,34 +1160,34 @@ io_sections: io_section
;
io_section: FILE_CONTROL '.'
- | FILE_CONTROL '.' selects
- | IO_CONTROL '.'
- | IO_CONTROL '.' io_control_clauses '.'
+ | FILE_CONTROL '.' selects
+ | IO_CONTROL '.'
+ | IO_CONTROL '.' io_control_clauses '.'
;
io_control_clauses: io_control_clause
- | io_control_clauses io_control_clause
- ;
+ | io_control_clauses io_control_clause
+ ;
io_control_clause:
- SAME record area for_kw filenames
- {
- symbol_file_same_record_area( $filenames->files );
- }
- | SAME smerge area for_kw filenames
- {
- symbol_file_same_record_area( $filenames->files );
- }
- | APPLY COMMIT on field_list
- {
- warnx("not implemented: I-O-CONTROL APPLY COMMIT");
- }
- ;
-area: %empty
- | AREA
- ;
-smerge: SORT
- | SORT_MERGE
- ;
+ SAME record area for_kw filenames
+ {
+ symbol_file_same_record_area( $filenames->files );
+ }
+ | SAME smerge area for_kw filenames
+ {
+ symbol_file_same_record_area( $filenames->files );
+ }
+ | APPLY COMMIT on field_list
+ {
+ warnx("not implemented: I-O-CONTROL APPLY COMMIT");
+ }
+ ;
+area: %empty
+ | AREA
+ ;
+smerge: SORT
+ | SORT_MERGE
+ ;
selects: select
| selects select
@@ -1196,83 +1196,83 @@ selects: select
select: SELECT optional NAME[name] select_clauses[clauses] '.'
{
assert($clauses.file);
- cbl_file_t *file = $clauses.file;
+ cbl_file_t *file = $clauses.file;
file->optional = $optional;
- file->line = yylineno;
+ file->line = yylineno;
if( !namcpy(file->name, $name) ) YYERROR;
- if( ! ($clauses.clauses & assign_clause_e) ) {
- yyerrorv("error: ASSIGN clause missing for %s", file->name);
- }
-
- // key check
- switch(file->org) {
- case file_indexed_e:
- // indexed file cannot have relative key
- if( ($clauses.clauses & relative_key_clause_e) != 0) {
- assert(file->keys);
- auto ikey = file->nkey - 1;
- assert(file->keys[ikey].fields);
- auto f = cbl_field_of(symbol_at(file->keys[ikey].fields[0]));
- yyerrorv("error: INDEXED file %s cannot have RELATIVE key %s",
- file->name, f->name);
- break; // because next message would be redundant
- }
- if( ($clauses.clauses & record_key_clause_e) == 0 ) {
- yyerrorv("error: INDEXED file %s has no RECORD KEY",
- file->name);
- }
- break;
- case file_disorganized_e:
- file->org = file_sequential_e;
- __attribute__((fallthrough));
- default:
- if( ($clauses.clauses & record_key_clause_e) != 0 ) {
- assert(file->keys);
- auto ikey = file->nkey - 1;
- assert(file->keys[ikey].fields);
- auto f = cbl_field_of(symbol_at(file->keys[ikey].fields[0]));
- yyerrorv("error: %s file %s cannot have RECORD key %s",
- file_org_str(file->org), file->name, f->name);
- }
- break;
- }
-
- // access check
- switch(file->access) {
- case file_access_rnd_e:
- case file_access_dyn_e:
- if( is_sequential(file) ) {
- yyerrorv("error: %s file %s cannot have ACCESS %s",
- file_org_str(file->org), file->name,
- file_access_str(file->access));
- }
- break;
- default:
- break;
- }
-
- // install file, and set record area's name
+ if( ! ($clauses.clauses & assign_clause_e) ) {
+ yyerrorv("error: ASSIGN clause missing for %s", file->name);
+ }
+
+ // key check
+ switch(file->org) {
+ case file_indexed_e:
+ // indexed file cannot have relative key
+ if( ($clauses.clauses & relative_key_clause_e) != 0) {
+ assert(file->keys);
+ auto ikey = file->nkey - 1;
+ assert(file->keys[ikey].fields);
+ auto f = cbl_field_of(symbol_at(file->keys[ikey].fields[0]));
+ yyerrorv("error: INDEXED file %s cannot have RELATIVE key %s",
+ file->name, f->name);
+ break; // because next message would be redundant
+ }
+ if( ($clauses.clauses & record_key_clause_e) == 0 ) {
+ yyerrorv("error: INDEXED file %s has no RECORD KEY",
+ file->name);
+ }
+ break;
+ case file_disorganized_e:
+ file->org = file_sequential_e;
+ __attribute__((fallthrough));
+ default:
+ if( ($clauses.clauses & record_key_clause_e) != 0 ) {
+ assert(file->keys);
+ auto ikey = file->nkey - 1;
+ assert(file->keys[ikey].fields);
+ auto f = cbl_field_of(symbol_at(file->keys[ikey].fields[0]));
+ yyerrorv("error: %s file %s cannot have RECORD key %s",
+ file_org_str(file->org), file->name, f->name);
+ }
+ break;
+ }
+
+ // access check
+ switch(file->access) {
+ case file_access_rnd_e:
+ case file_access_dyn_e:
+ if( is_sequential(file) ) {
+ yyerrorv("error: %s file %s cannot have ACCESS %s",
+ file_org_str(file->org), file->name,
+ file_access_str(file->access));
+ }
+ break;
+ default:
+ break;
+ }
+
+ // install file, and set record area's name
if( (file = file_add(file)) == NULL ) YYERROR;
- auto ifile = symbol_index(symbol_elem_of(file));
- // update keys
- for( auto p = file->keys;
- p && p < file->keys + file->nkey; p++ )
- {
- if( p->name[0] == '\0' ) continue;
- auto f = symbol_field(PROGRAM, 0, p->name);
- cbl_field_of(f)->parent = ifile;
- size_t isym = field_index(cbl_field_of(f));
- update_symbol_map(symbol_at(isym));
- }
+ auto ifile = symbol_index(symbol_elem_of(file));
+ // update keys
+ for( auto p = file->keys;
+ p && p < file->keys + file->nkey; p++ )
+ {
+ if( p->name[0] == '\0' ) continue;
+ auto f = symbol_field(PROGRAM, 0, p->name);
+ cbl_field_of(f)->parent = ifile;
+ size_t isym = field_index(cbl_field_of(f));
+ update_symbol_map(symbol_at(isym));
+ }
}
| SELECT optional NAME[name] '.'
{
cbl_file_t file = protofile;
file.optional = $optional;
- file.line = yylineno;
+ file.line = yylineno;
if( !namcpy(file.name, $name) ) YYERROR;
if( file_add(&file) == NULL ) YYERROR;
@@ -1281,17 +1281,17 @@ select: SELECT optional NAME[name] select_clauses[clauses] '.'
selected_name: external scalar { $$ = $2; }
| external LITERAL[name]
{
- const char *name = string_of($name);
- if( ! name ) {
- yyerrorv("'%s' has embedded NUL", $name.data);
- YYERROR;
- }
+ const char *name = string_of($name);
+ if( ! name ) {
+ yyerrorv("'%s' has embedded NUL", $name.data);
+ YYERROR;
+ }
uint32_t len = $name.len;
cbl_field_t field = {
0, FldLiteralA, FldInvalid, quoted_e | constant_e,
0, 0, 0, nonarray, 0, "", 0,
{len,len,0,0, $name.data, NULL, {NULL}, {NULL}}, NULL };
- field.attr |= literal_attr($name.prefix);
+ field.attr |= literal_attr($name.prefix);
$$ = new cbl_refer_t( field_add(&field) );
}
;
@@ -1302,142 +1302,142 @@ external: %empty /* GnuCOBOL uses EXTERNAL to control name resolution. */
select_clauses: select_clause { $$.clauses = $1.clause; $$.file = $1.file; }
| select_clauses[total] select_clause[part]
{
- // The default organization is sequential.
+ // The default organization is sequential.
if( ($total.clauses & organization_clause_e) == 0 ) {
$total.file->org = file_sequential_e;
}
- const bool exists = ($total.clauses & $part.clause);
+ const bool exists = ($total.clauses & $part.clause);
$total.clauses |= $part.clause;
switch($part.clause) {
- case alt_key_clause_e:
- assert( $part.file->nkey == 1 );
- if( $total.file->nkey++ == 0 ) {
- // If no key yet exists, create room for it and the
- // present alternate.
- assert($total.file->keys == &no_key);
- $total.file->keys = new cbl_file_key_t[++$total.file->nkey];
- }
- {
- auto keys = new cbl_file_key_t[$total.file->nkey];
- auto alt = std::copy($total.file->keys,
- $total.file->keys +
+ case alt_key_clause_e:
+ assert( $part.file->nkey == 1 );
+ if( $total.file->nkey++ == 0 ) {
+ // If no key yet exists, create room for it and the
+ // present alternate.
+ assert($total.file->keys == &no_key);
+ $total.file->keys = new cbl_file_key_t[++$total.file->nkey];
+ }
+ {
+ auto keys = new cbl_file_key_t[$total.file->nkey];
+ auto alt = std::copy($total.file->keys,
+ $total.file->keys +
$total.file->nkey - 1,
- keys);
- // Assign the alternate key to the last element,
- // and update the pointer.
- *alt = $part.file->keys[0];
- delete[] $total.file->keys;
- $total.file->keys = keys;
- }
- break;
- case assign_clause_e:
- if( exists ) {
- yyerror("clause is repeated");
- YYERROR;
- }
- $total.file->filename = $part.file->filename;
- break;
- case collating_clause_e:
- if( exists ) {
- yyerror("clause is repeated");
- YYERROR;
- }
- break;
- case lock_mode_clause_e:
- if( exists ) {
- yyerror("clause is repeated");
- YYERROR;
- }
+ keys);
+ // Assign the alternate key to the last element,
+ // and update the pointer.
+ *alt = $part.file->keys[0];
+ delete[] $total.file->keys;
+ $total.file->keys = keys;
+ }
+ break;
+ case assign_clause_e:
+ if( exists ) {
+ yyerror("clause is repeated");
+ YYERROR;
+ }
+ $total.file->filename = $part.file->filename;
+ break;
+ case collating_clause_e:
+ if( exists ) {
+ yyerror("clause is repeated");
+ YYERROR;
+ }
+ break;
+ case lock_mode_clause_e:
+ if( exists ) {
+ yyerror("clause is repeated");
+ YYERROR;
+ }
$total.file->lock = $part.file->lock;
- break;
+ break;
case organization_clause_e:
- if( exists ) {
- yyerror("clause is repeated");
- YYERROR;
- }
+ if( exists ) {
+ yyerror("clause is repeated");
+ YYERROR;
+ }
$total.file->org = $part.file->org;
break;
case padding_clause_e:
case reserve_clause_e:
case sharing_clause_e:
case record_delim_clause_e:
- if( exists ) {
- yyerror("clause is repeated");
- YYERROR;
- }
+ if( exists ) {
+ yyerror("clause is repeated");
+ YYERROR;
+ }
break;
case access_clause_e:
- if( exists ) {
- yyerror("clause is repeated");
- YYERROR;
- }
+ if( exists ) {
+ yyerror("clause is repeated");
+ YYERROR;
+ }
$total.file->access = $part.file->access;
break;
- case relative_key_clause_e:
- if( exists ) {
- yyerror("clause is repeated");
- YYERROR;
- }
- if( $total.clauses & record_key_clause_e ) {
- yyerrorv("FILE %s is INDEXED, has no RELATIVE key",
- $total.file->name);
- YYERROR;
- }
- // fall thru
+ case relative_key_clause_e:
+ if( exists ) {
+ yyerror("clause is repeated");
+ YYERROR;
+ }
+ if( $total.clauses & record_key_clause_e ) {
+ yyerrorv("FILE %s is INDEXED, has no RELATIVE key",
+ $total.file->name);
+ YYERROR;
+ }
+ // fall thru
case record_key_clause_e:
- if( exists ) {
- yyerror("clause is repeated");
- YYERROR;
- }
- if( ($total.clauses & relative_key_clause_e) &&
- $part.clause == record_key_clause_e ) {
- yyerrorv("FILE %s is RELATIVE, has no RECORD key",
- $total.file->name);
- YYERROR;
- }
- if( $total.file->nkey == 0 ) {
+ if( exists ) {
+ yyerror("clause is repeated");
+ YYERROR;
+ }
+ if( ($total.clauses & relative_key_clause_e) &&
+ $part.clause == record_key_clause_e ) {
+ yyerrorv("FILE %s is RELATIVE, has no RECORD key",
+ $total.file->name);
+ YYERROR;
+ }
+ if( $total.file->nkey == 0 ) {
$total.file->nkey = $part.file->nkey;
$total.file->keys = $part.file->keys;
- } else {
+ } else {
$total.file->keys[0] = $part.file->keys[0];
- }
- break;
+ }
+ break;
/* case password_clause_e: */
case file_status_clause_e:
- if( exists ) {
- yyerror("clause is repeated");
- YYERROR;
- }
+ if( exists ) {
+ yyerror("clause is repeated");
+ YYERROR;
+ }
$total.file->user_status = $part.file->user_status;
$total.file->vsam_status = $part.file->vsam_status;
break;
}
- if( $total.file->lock.locked() ) {
- if( $total.file->org == file_sequential_e &&
- $total.file->lock.multiple ) {
- yyerror("SEQUENTIAL file cannot lock MULTIPLE records");
- }
- }
+ if( $total.file->lock.locked() ) {
+ if( $total.file->org == file_sequential_e &&
+ $total.file->lock.multiple ) {
+ yyerror("SEQUENTIAL file cannot lock MULTIPLE records");
+ }
+ }
delete $part.file;
- $$ = $total;
+ $$ = $total;
}
;
select_clause: access_clause
- | alt_key_clause[alts]
- | assign_clause[alts]
- | collate_clause
+ | alt_key_clause[alts]
+ | assign_clause[alts]
+ | collate_clause
| /* file */ status_clause
- | lock_mode_clause
+ | lock_mode_clause
| org_clause
| padding_clause
- | record_delim_clause
+ | record_delim_clause
| record_key_clause
| relative_key_clause
- | reserve_clause
- | sharing_clause
+ | reserve_clause
+ | sharing_clause
;
access_clause: ACCESS mode is access_mode[acc]
@@ -1447,56 +1447,56 @@ access_clause: ACCESS mode is access_mode[acc]
$$.file->access = static_cast<cbl_file_access_t>($acc);
}
;
-access_mode: RANDOM { $$ = file_access_rnd_e; }
+access_mode: RANDOM { $$ = file_access_rnd_e; }
| DYNAMIC { $$ = file_access_dyn_e; }
- | SEQUENTIAL { $$ = file_access_seq_e; }
+ | SEQUENTIAL { $$ = file_access_seq_e; }
;
-alt_key_clause: ALTERNATE record key is name key_source[fields] unique_key
- {
+alt_key_clause: ALTERNATE record key is name key_source[fields] unique_key
+ {
$$.clause = alt_key_clause_e;
$$.file = new cbl_file_t(protofile);
- $$.file->nkey = 1;
+ $$.file->nkey = 1;
if( $fields == NULL ) {
$$.file->keys = new cbl_file_key_t(field_index($name),
- $unique_key);
- } else {
- $name->type = FldLiteralA;
- $name->data.initial = $name->name;
- $name->attr |= record_key_e;
- auto& name = *$name;
- $$.file->keys = new cbl_file_key_t(name.name,
+ $unique_key);
+ } else {
+ $name->type = FldLiteralA;
+ $name->data.initial = $name->name;
+ $name->attr |= record_key_e;
+ auto& name = *$name;
+ $$.file->keys = new cbl_file_key_t(name.name,
$fields->fields,
- $unique_key);
- }
- }
- ;
-key_source: %empty { $$ = NULL; }
- | SOURCE is key_sources[fields] { $$ = $fields; }
- ;
-key_sources: name { $$ = new field_list_t($1); }
- | key_sources name { $$ = $1; $$->fields.push_back($2); }
- ;
+ $unique_key);
+ }
+ }
+ ;
+key_source: %empty { $$ = NULL; }
+ | SOURCE is key_sources[fields] { $$ = $fields; }
+ ;
+key_sources: name { $$ = new field_list_t($1); }
+ | key_sources name { $$ = $1; $$->fields.push_back($2); }
+ ;
unique_key: %empty { $$ = true; }
| with DUPLICATES { $$ = false; }
;
-assign_clause: ASSIGN to selected_name[selected] {
+assign_clause: ASSIGN to selected_name[selected] {
$$.clause = assign_clause_e;
$$.file = new cbl_file_t(protofile);
$$.file->filename = field_index($selected->field);
- }
- ;
+ }
+ ;
-collate_clause: collate_claus1 {
+collate_clause: collate_claus1 {
$$.clause = collating_clause_e;
$$.file = new cbl_file_t(protofile);
- }
- ;
-collate_claus1: collating SEQUENCE NAME /* SEQUENCE swallows IS/FOR */
- | collating SEQUENCE ALPHANUMERIC is NAME
- | collating SEQUENCE NATIONAL is NAME
- ;
+ }
+ ;
+collate_claus1: collating SEQUENCE NAME /* SEQUENCE swallows IS/FOR */
+ | collating SEQUENCE ALPHANUMERIC is NAME
+ | collating SEQUENCE NATIONAL is NAME
+ ;
status_clause: file STATUS is name[user]
{
@@ -1514,28 +1514,28 @@ status_clause: file STATUS is name[user]
;
lock_mode_clause: // ISO only
- LOCK mode is lock_mode lock_how[how]
- {
+ LOCK mode is lock_mode lock_how[how]
+ {
$$.clause = lock_mode_clause_e;
$$.file = new cbl_file_t(protofile);
- $$.file->lock.multiple = $how > 0;
- $$.file->lock.mode_set($lock_mode);
- }
-lock_how: %empty { $$ = 0; }
- | with LOCK_ON multiple records { $$ = $multiple; }
- ;
-lock_mode: MANUAL { $$ = MANUAL; }
- | RECORD { $$ = RECORD; }
- | AUTOMATIC { $$ = AUTOMATIC; }
- ;
-multiple: %empty { $$ = 0; }
- | MULTIPLE { $$ = MULTIPLE; }
- ;
-records: RECORD
- | RECORDS
- ;
-
-org_clause: org_clause1[org]
+ $$.file->lock.multiple = $how > 0;
+ $$.file->lock.mode_set($lock_mode);
+ }
+lock_how: %empty { $$ = 0; }
+ | with LOCK_ON multiple records { $$ = $multiple; }
+ ;
+lock_mode: MANUAL { $$ = MANUAL; }
+ | RECORD { $$ = RECORD; }
+ | AUTOMATIC { $$ = AUTOMATIC; }
+ ;
+multiple: %empty { $$ = 0; }
+ | MULTIPLE { $$ = MULTIPLE; }
+ ;
+records: RECORD
+ | RECORDS
+ ;
+
+org_clause: org_clause1[org]
{
$$.clause = organization_clause_e;
$$.file = new cbl_file_t(protofile);
@@ -1562,13 +1562,13 @@ padding_clause: PADDING character is padding_char
$$.file = new cbl_file_t(protofile);
}
;
-character: %empty
- | CHARACTER
- ;
-padding_char: NAME
- | LITERAL
- | NUMSTR
- ;
+character: %empty
+ | CHARACTER
+ ;
+padding_char: NAME
+ | LITERAL
+ | NUMSTR
+ ;
record_delim_clause: RECORD DELIMITER is STANDARD_ALPHABET
{
@@ -1584,15 +1584,15 @@ record_key_clause: RECORD key is name key_source[fields]
$$.file->nkey = 1;
if( $fields == NULL ) {
$$.file->keys = new cbl_file_key_t(field_index($name));
- } else { // "special" not-literal literal: a key name
- $name->type = FldLiteralA;
- $name->data.initial = $name->name;
- $name->attr |= record_key_e;
- $$.file->keys = new cbl_file_key_t($name->name,
- $fields->fields, true);
- }
- }
- ;
+ } else { // "special" not-literal literal: a key name
+ $name->type = FldLiteralA;
+ $name->data.initial = $name->name;
+ $name->attr |= record_key_e;
+ $$.file->keys = new cbl_file_key_t($name->name,
+ $fields->fields, true);
+ }
+ }
+ ;
relative_key_clause: /* RELATIVE */ KEY is name
{ // lexer returns KEY for RELATIVE ... NAME
@@ -1600,40 +1600,40 @@ relative_key_clause: /* RELATIVE */ KEY is name
$$.file = new cbl_file_t(protofile);
$$.file->nkey = 1;
$$.file->keys = new cbl_file_key_t(field_index($name));
- }
- ;
+ }
+ ;
reserve_clause: RESERVE NUMSTR reserve_area
{
$$.clause = reserve_clause_e;
$$.file = new cbl_file_t(protofile);
}
- ;
-reserve_area: %empty
- | AREA
- | AREAS
- ;
+ ;
+reserve_area: %empty
+ | AREA
+ | AREAS
+ ;
-sharing_clause: SHARING with sharing_who
+sharing_clause: SHARING with sharing_who
{
$$.clause = sharing_clause_e;
$$.file = new cbl_file_t(protofile);
}
- ;
-sharing_who: ALL other
- | NO other
- | READ ONLY
- ;
-other: %empty
- | OTHER
- ;
+ ;
+sharing_who: ALL other
+ | NO other
+ | READ ONLY
+ ;
+other: %empty
+ | OTHER
+ ;
config_paragraphs: config_paragraph
| config_paragraphs config_paragraph
;
config_paragraph:
- SPECIAL_NAMES '.'
+ SPECIAL_NAMES '.'
| SPECIAL_NAMES specials '.'
| SOURCE_COMPUTER '.' NAME with_debug '.'
| OBJECT_COMPUTER '.' NAME collating_sequence[name] '.'
@@ -1648,109 +1648,109 @@ config_paragraph:
}
| REPOSITORY '.'
| REPOSITORY '.' repo_members '.'
- ;
-
-repo_members: repo_member
- | repo_members repo_member
- ;
-repo_member: repo_class
- { yyerror("syntax error: CLASS not implemented"); }
- | repo_interface
- { yyerror("syntax error: INTERFACE not implemented"); }
- | repo_func
- | repo_program
- | repo_property
- { yyerror("syntax error: PROPERTY not implemented"); }
- ;
-
-repo_class: CLASS NAME repo_as repo_expands
- ;
-repo_as: %empty { $$ = literal_t(); }
- | AS LITERAL { $$ = $2; }
- ;
+ ;
+
+repo_members: repo_member
+ | repo_members repo_member
+ ;
+repo_member: repo_class
+ { yyerror("syntax error: CLASS not implemented"); }
+ | repo_interface
+ { yyerror("syntax error: INTERFACE not implemented"); }
+ | repo_func
+ | repo_program
+ | repo_property
+ { yyerror("syntax error: PROPERTY not implemented"); }
+ ;
+
+repo_class: CLASS NAME repo_as repo_expands
+ ;
+repo_as: %empty { $$ = literal_t(); }
+ | AS LITERAL { $$ = $2; }
+ ;
repo_expands: %empty
- | EXPANDS NAME USING NAME
- ;
-
-repo_interface: INTERFACE NAME repo_as repo_expands
- ;
-
-repo_func: FUNCTION repo_func_names INTRINSIC
- {
- for( const auto& name : names ) {
- current.repository_add(name);
- }
- names.clear();
- }
+ | EXPANDS NAME USING NAME
+ ;
+
+repo_interface: INTERFACE NAME repo_as repo_expands
+ ;
+
+repo_func: FUNCTION repo_func_names INTRINSIC
+ {
+ for( const auto& name : names ) {
+ current.repository_add(name);
+ }
+ names.clear();
+ }
| FUNCTION ALL INTRINSIC
- {
- current.repository_add_all();
- }
- | FUNCTION repo_func_names
- ;
+ {
+ current.repository_add_all();
+ }
+ | FUNCTION repo_func_names
+ ;
repo_func_names:
- repo_func_name
- | repo_func_names repo_func_name
- ;
+ 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);
- if( !token ) {
- yyerrorv("error: %s is not defined here as a user-defined function",
- $NAME);
- current.udf_dump();
- YYERROR;
- }
- auto e = symbol_function(0, $NAME);
- assert(e);
- current.repository_add(symbol_index(e)); // add UDF to repository
- }
- }
- ;
-
-repo_program: PROGRAM_kw NAME repo_as
- {
- size_t parent = 0;
- auto program = symbol_label( PROGRAM, LblProgram, 0, $NAME );
- if( ! program ) {
- if( $repo_as.empty() ) {
- yyerrorv("error: '%s' does not name an earlier program", $NAME);
- YYERROR;
- }
- program = symbol_label( PROGRAM, LblProgram, 0,
- "", $repo_as.data );
- }
- if( ! program ) {
- yyerrorv("'%s' does not name an earlier program",
- $repo_as.data);
- YYERROR;
- }
- assert(program);
- parent = symbol_index(symbol_elem_of(program));
- // Literal field whose parent is the the aliased program.
- cbl_field_t prog = { .type = FldLiteralA,
- .attr = quoted_e,
- .parent = parent,
- .data = {.initial = $repo_as.data} };
- namcpy(prog.name, $NAME);
- if( ! prog.data.initial ) {
- assert(program);
- prog.data.initial = program->name;
- }
- symbol_field_add(PROGRAM, &prog);
- }
- ;
-
-repo_property: PROPERTY NAME repo_as
- ;
+ if( ! current.repository_add($NAME) ) { // add intrinsic by name
+ auto token = current.udf_in($NAME);
+ if( !token ) {
+ yyerrorv("error: %s is not defined here as a user-defined function",
+ $NAME);
+ current.udf_dump();
+ YYERROR;
+ }
+ auto e = symbol_function(0, $NAME);
+ assert(e);
+ current.repository_add(symbol_index(e)); // add UDF to repository
+ }
+ }
+ ;
+
+repo_program: PROGRAM_kw NAME repo_as
+ {
+ size_t parent = 0;
+ auto program = symbol_label( PROGRAM, LblProgram, 0, $NAME );
+ if( ! program ) {
+ if( $repo_as.empty() ) {
+ yyerrorv("error: '%s' does not name an earlier program", $NAME);
+ YYERROR;
+ }
+ program = symbol_label( PROGRAM, LblProgram, 0,
+ "", $repo_as.data );
+ }
+ if( ! program ) {
+ yyerrorv("'%s' does not name an earlier program",
+ $repo_as.data);
+ YYERROR;
+ }
+ assert(program);
+ parent = symbol_index(symbol_elem_of(program));
+ // Literal field whose parent is the the aliased program.
+ cbl_field_t prog = { .type = FldLiteralA,
+ .attr = quoted_e,
+ .parent = parent,
+ .data = {.initial = $repo_as.data} };
+ namcpy(prog.name, $NAME);
+ if( ! prog.data.initial ) {
+ assert(program);
+ prog.data.initial = program->name;
+ }
+ symbol_field_add(PROGRAM, &prog);
+ }
+ ;
+
+repo_property: PROPERTY NAME repo_as
+ ;
with_debug: %empty
| with DEBUGGING MODE {
- if( ! set_debug(true) ) {
- yyerror("syntax error: "
- "DEBUGGING MODE valid only in fixed format");
- }
- }
+ if( ! set_debug(true) ) {
+ yyerror("syntax error: "
+ "DEBUGGING MODE valid only in fixed format");
+ }
+ }
;
collating_sequence: %empty { $$ = NULL; }
@@ -1761,7 +1761,7 @@ collating_sequence: %empty { $$ = NULL; }
;
specials: '.' special_names
- ;
+ ;
special_names: special_name
| special_names special_name
;
@@ -1769,7 +1769,7 @@ special_names: special_name
special_name: env_name
| ALPHABET NAME[name] is alphabet_name[abc]
{
- if( !$abc ) YYERROR;
+ if( !$abc ) YYERROR;
assert($abc); // already in symbol table
if( !namcpy($abc->name, $name) ) YYERROR;
if( yydebug ) $abc->dump();
@@ -1802,19 +1802,19 @@ special_name: env_name
// symbol_currency_add (symbol, sign-string). 'symbol' is the
// character in the PICTURE string, and 'sign' is the substitution
// that gets made in memory.
- if( ! string_of($lit) ) {
- yyerrorv("'%s' has embedded NUL", $lit.data);
- YYERROR;
- }
+ if( ! string_of($lit) ) {
+ yyerrorv("'%s' has embedded NUL", $lit.data);
+ YYERROR;
+ }
symbol_currency_add( $picture_sym, $lit.data );
}
| DECIMAL_POINT is COMMA
{
symbol_decimal_point_set(',');
}
- | LOCALE NAME is locale_spec
+ | LOCALE NAME is locale_spec
{
- current.locale($NAME, $locale_spec);
+ current.locale($NAME, $locale_spec);
yyerrorv("%s:%d: LOCALE syntax not implemented",
__FILE__, __LINE__);
}
@@ -1826,10 +1826,10 @@ special_name: env_name
__FILE__, __LINE__);
}
;
-locale_spec: NAME { $$ = $1; }
- | LITERAL { $$ = string_of($1); }
+locale_spec: NAME { $$ = $1; }
+ | LITERAL { $$ = string_of($1); }
- ;
+ ;
symbolic: NAME
| NUMSTR
;
@@ -1840,7 +1840,7 @@ is_alphabet: ARE NUMSTR
env_name: env_name1 is NAME
{
cbl_special_name_t special = { .token = $1.token,
- .id = $1.id };
+ .id = $1.id };
if( !namcpy(special.name, $NAME) ) YYERROR;
const char *filename;
@@ -1906,12 +1906,12 @@ alphabet_name: STANDARD_ALPHABET { $$ = alphabet_add(ASCII_e); }
{
$$ = cbl_alphabet_of(symbol_alphabet_add(PROGRAM, $1));
}
- | error
- {
- yyerror("code-name-1 may be STANDARD-1, STANDARD-2, "
- "NATIVE, OR EBCDIC");
- $$ = NULL;
- }
+ | error
+ {
+ yyerror("code-name-1 may be STANDARD-1, STANDARD-2, "
+ "NATIVE, OR EBCDIC");
+ $$ = NULL;
+ }
;
alphabet_seqs: alphabet_seq[seq]
/*
@@ -1935,7 +1935,7 @@ alphabet_seqs: alphabet_seq[seq]
}
| alphabet_seqs alphabet_seq[seq]
{
- // ALSO x'00' is valid, but in that case the low pointer is NULL
+ // ALSO x'00' is valid, but in that case the low pointer is NULL
if( !$seq.low ) {
$$->also($seq.also);
} else {
@@ -1950,28 +1950,28 @@ alphabet_seqs: alphabet_seq[seq]
alphabet_seq: alphabet_lit[low]
{
$$.also = 0;
- if( $low.len == 1 && $low.data[0] == '\0' ) {
- $$.high = $$.low = nul_string();
- } else {
+ if( $low.len == 1 && $low.data[0] == '\0' ) {
+ $$.high = $$.low = nul_string();
+ } else {
size_t size = 1 + $low.len;
$$.low = new unsigned char[size];
memcpy($$.low, $low.data, size);
$$.high = $$.low + size - 1;
assert($$.high[0] == '\0');
}
- }
+ }
| alphabet_lit[low] THRU alphabet_lit[high]
{
$$.also = 0;
size_t size = 1 + $low.len;
- if( $low.len == 1 && $low.data[0] == '\0' ) {
- $$.low = nul_string();
- } else {
+ if( $low.len == 1 && $low.data[0] == '\0' ) {
+ $$.low = nul_string();
+ } else {
$$.low = new unsigned char[size];
memcpy($$.low, $low.data, size);
- }
- assert($high.len > 0);
- assert($high.data[0] != '\0');
+ }
+ assert($high.len > 0);
+ assert($high.data[0] != '\0');
size = 1 + $high.len;
$$.high = new unsigned char[size];
memcpy($$.high, $high.data, size);
@@ -1987,19 +1987,19 @@ alphabet_etc: alphabet_lit
$$ = (unsigned char)$1.data[0];
}
| spaces_etc {
- // For figurative constants, pass the synmbol table index,
- // marked with the high bit.
- static const auto bits = sizeof($$) * 8 - 1;
- $$ = 1;
- $$ = $$ << bits;
- $$ |= constant_index($1);
- }
+ // For figurative constants, pass the synmbol table index,
+ // marked with the high bit.
+ static const auto bits = sizeof($$) * 8 - 1;
+ $$ = 1;
+ $$ = $$ << bits;
+ $$ |= constant_index($1);
+ }
;
alphabet_lit: LITERAL { $$ = $1; assert($$.len > 0); }
- | NUMSTR {
- assert( $1.radix == decimal_e);
- $$ = literal_of($1.string);
- }
+ | NUMSTR {
+ assert( $1.radix == decimal_e);
+ $$ = literal_of($1.string);
+ }
;
upsi: UPSI is NAME
@@ -2007,7 +2007,7 @@ upsi: UPSI is NAME
assert($UPSI);
size_t parent = symbol_index(symbol_field(0,0,"UPSI-0"));
cbl_field_t *field = field_alloc(FldSwitch, parent, $NAME);
- if( !field ) YYERROR;
+ if( !field ) YYERROR;
field->attr = constant_e;
field->data.initial = $UPSI;
}
@@ -2016,7 +2016,7 @@ upsi: UPSI is NAME
assert($UPSI);
size_t parent = symbol_index(symbol_field(0,0,"UPSI-0"));
cbl_field_t *field = field_alloc(FldSwitch, parent, $NAME);
- if( !field ) YYERROR;
+ if( !field ) YYERROR;
field->attr = constant_e;
field->data.initial = $UPSI;
@@ -2025,12 +2025,12 @@ upsi: UPSI is NAME
if( $entry.on ) {
cbl_field_t *on = field_alloc(FldSwitch, parent, $entry.on);
- if( !on ) YYERROR;
+ if( !on ) YYERROR;
on->data.upsi_mask = new cbl_upsi_mask_t(true, value);
}
if( $entry.off ) {
cbl_field_t *off = field_alloc(FldSwitch, parent, $entry.off);
- if( !off ) YYERROR;
+ if( !off ) YYERROR;
off->data.upsi_mask = new cbl_upsi_mask_t(false, value);
}
}
@@ -2042,24 +2042,24 @@ upsi: UPSI is NAME
if( $entry.on ) {
cbl_field_t *on = field_alloc(FldSwitch, parent, $entry.on);
- if( !on ) YYERROR;
+ if( !on ) YYERROR;
on->data.upsi_mask = new cbl_upsi_mask_t(true, value);
}
if( $entry.off ) {
cbl_field_t *off = field_alloc(FldSwitch, parent, $entry.off);
- if( !off ) YYERROR;
+ if( !off ) YYERROR;
off->data.upsi_mask = new cbl_upsi_mask_t(false, value);
}
}
- /* | error */
- /* { */
- /* yyerror("Switch names are UPSI-0 through UPSI-7"); */
- /* if( max_errors_exceeded(nparse_error) ) { */
- /* yyerrorv("max errors %d reached", nparse_error); */
- /* YYABORT; */
- /* } */
- /* } */
- ;
+ /* | error */
+ /* { */
+ /* yyerror("Switch names are UPSI-0 through UPSI-7"); */
+ /* if( max_errors_exceeded(nparse_error) ) { */
+ /* yyerrorv("max errors %d reached", nparse_error); */
+ /* YYABORT; */
+ /* } */
+ /* } */
+ ;
upsi_entry: ON status is NAME
{
$$.on = $NAME;
@@ -2084,12 +2084,12 @@ upsi_entry: ON status is NAME
picture_sym: %empty { $$ = NULL; }
| PICTURE SYMBOL LITERAL[lit] {
- if( ! string_of($lit) ) {
- yyerrorv("'%s' has embedded NUL", $lit.data);
- YYERROR;
- }
- $$ = string_of($lit);
- }
+ if( ! string_of($lit) ) {
+ yyerrorv("'%s' has embedded NUL", $lit.data);
+ YYERROR;
+ }
+ $$ = string_of($lit);
+ }
;
/*
@@ -2104,24 +2104,24 @@ domains: domain
domain: all LITERAL[a]
{
- if( ! string_of($a) ) {
- yyerrorv("'%s' has embedded NUL", $a.data);
- YYERROR;
- }
+ if( ! string_of($a) ) {
+ yyerrorv("'%s' has embedded NUL", $a.data);
+ YYERROR;
+ }
$$ = NULL;
cbl_domain_t domain($all, extra_null($a.data));
domains.push_back(domain);
}
| all[a_all] LITERAL[a] THRU all[z_all] LITERAL[z]
{
- if( ! string_of($a) ) {
- yyerrorv("'%s' has embedded NUL", $a.data);
- YYERROR;
- }
- if( ! string_of($z) ) {
- yyerrorv("'%s' has embedded NUL", $z.data);
- YYERROR;
- }
+ if( ! string_of($a) ) {
+ yyerrorv("'%s' has embedded NUL", $a.data);
+ YYERROR;
+ }
+ if( ! string_of($z) ) {
+ yyerrorv("'%s' has embedded NUL", $z.data);
+ YYERROR;
+ }
$$ = NULL;
cbl_domain_elem_t first($a_all, extra_null($a.data)),
last($z_all, extra_null($z.data));
@@ -2141,44 +2141,44 @@ domain: all LITERAL[a]
}
| all reserved_value {
$$ = NULL;
- if( $2 == NULLS ) YYERROR;
- auto value = constant_of(constant_index($2))->data.initial;
+ if( $2 == NULLS ) YYERROR;
+ auto value = constant_of(constant_index($2))->data.initial;
struct cbl_domain_t domain( $all, value );
domains.push_back(domain);
}
| all[a_all] reserved_value[a] THRU all[z_all] LITERAL[z] {
- if( ! string_of($z) ) {
- yyerrorv("'%s' has embedded NUL", $z.data);
- YYERROR;
- }
+ if( ! string_of($z) ) {
+ yyerrorv("'%s' has embedded NUL", $z.data);
+ YYERROR;
+ }
$$ = NULL;
- if( $a == NULLS ) YYERROR;
- auto value = constant_of(constant_index($a))->data.initial;
+ if( $a == NULLS ) YYERROR;
+ auto value = constant_of(constant_index($a))->data.initial;
cbl_domain_elem_t first($a_all, value),
last($z_all, extra_null($z.data));
domains.push_back(cbl_domain_t(first, last));
}
| all[a_all] reserved_value[a] THRU all[z_all] NUMSTR[z] {
$$ = NULL;
- if( $a == NULLS ) YYERROR;
- auto value = constant_of(constant_index($a))->data.initial;
+ if( $a == NULLS ) YYERROR;
+ auto value = constant_of(constant_index($a))->data.initial;
cbl_domain_elem_t first($a_all, value, true),
last($z_all, $z.string, true);
domains.push_back(cbl_domain_t(first, last));
}
| when_set_to FALSE_kw is LITERAL[value]
{
- if( ! string_of($value) ) {
- yyerrorv("'%s' has embedded NUL", $value.data);
- YYERROR;
- }
+ if( ! string_of($value) ) {
+ yyerrorv("'%s' has embedded NUL", $value.data);
+ YYERROR;
+ }
char *dom = extra_null($value.data);
$$ = new cbl_domain_t(false, dom);
}
| when_set_to FALSE_kw is reserved_value
{
- if( $4 == NULLS ) YYERROR;
- auto value = constant_of(constant_index($4))->data.initial;
+ if( $4 == NULLS ) YYERROR;
+ auto value = constant_of(constant_index($4))->data.initial;
$$ = new cbl_domain_t( false, value );
}
| when_set_to FALSE_kw is NUMSTR[n]
@@ -2200,7 +2200,7 @@ data_div: %empty
| DATA_DIV
| DATA_DIV { current_division = data_div_e; } data_sections
{
- current_data_section = not_data_datasect_e;
+ current_data_section = not_data_datasect_e;
parser_division( data_div_e, NULL, 0, NULL );
}
;
@@ -2210,7 +2210,7 @@ data_sections: data_section
;
data_section: FILE_SECT '.'
- | FILE_SECT '.' {
+ | FILE_SECT '.' {
current_data_section_set(file_datasect_e);
} file_descrs
| WORKING_STORAGE_SECT '.' {
@@ -2239,97 +2239,97 @@ fd_clauses: fd_clause
| fd_clauses fd_clause
;
fd_clause: record_desc
- {
- auto f = cbl_file_of(symbol_at(file_section_fd));
- f->varying_size.min = $1.min;
- f->varying_size.max = $1.max;
- auto& cap = cbl_field_of(symbol_at(f->default_record))->data.capacity;
- cap = std::max(cap, uint32_t(f->varying_size.max));
- // If min != max now, we know varying is explicitly defined.
- f->varying_size.explicitly = f->varies();
- if( f->varying_size.max != 0 ) {
- if( !(f->varying_size.min <= f->varying_size.max) ) {
- yyerrorv("%zu must be <= %zu",
- f->varying_size.min, f->varying_size.max);
- YYERROR;
- }
- }
- }
+ {
+ auto f = cbl_file_of(symbol_at(file_section_fd));
+ f->varying_size.min = $1.min;
+ f->varying_size.max = $1.max;
+ auto& cap = cbl_field_of(symbol_at(f->default_record))->data.capacity;
+ cap = std::max(cap, uint32_t(f->varying_size.max));
+ // If min != max now, we know varying is explicitly defined.
+ f->varying_size.explicitly = f->varies();
+ if( f->varying_size.max != 0 ) {
+ if( !(f->varying_size.min <= f->varying_size.max) ) {
+ yyerrorv("%zu must be <= %zu",
+ f->varying_size.min, f->varying_size.max);
+ YYERROR;
+ }
+ }
+ }
| block_desc
| label_desc
| DATA record_is field_list
- | RECORDING mode is NAME
- {
- switch( $NAME[0] ) {
- case 'F':
- case 'V':
- case 'U':
- case 'S':
- break;
- default:
- yyerrorv( "syntax error: invalid RECORDING MODE '%s'",
- $NAME);
- YYERROR;
- }
- warnx("warning: RECORDING MODE ignored, not defined by ISO 2023");
- }
+ | RECORDING mode is NAME
+ {
+ switch( $NAME[0] ) {
+ case 'F':
+ case 'V':
+ case 'U':
+ case 'S':
+ break;
+ default:
+ yyerrorv( "syntax error: invalid RECORDING MODE '%s'",
+ $NAME);
+ YYERROR;
+ }
+ warnx("warning: RECORDING MODE ignored, not defined by ISO 2023");
+ }
| VALUE OF fd_values
- | CODESET is NAME
- | is GLOBAL
- {
- auto f = cbl_file_of(symbol_at(file_section_fd));
- f->attr |= global_e;
- }
- | is EXTERNAL
- {
- auto f = cbl_file_of(symbol_at(file_section_fd));
- f->attr |= external_e;
- }
- | is EXTERNAL as LITERAL
- {
- auto f = cbl_file_of(symbol_at(file_section_fd));
- f->attr |= external_e;
- yyerror("AS LITERAL not implemented");
- }
- | fd_linage
- | fd_report {
- yyerror("REPORT WRITER not implemented");
- YYERROR;
- }
+ | CODESET is NAME
+ | is GLOBAL
+ {
+ auto f = cbl_file_of(symbol_at(file_section_fd));
+ f->attr |= global_e;
+ }
+ | is EXTERNAL
+ {
+ auto f = cbl_file_of(symbol_at(file_section_fd));
+ f->attr |= external_e;
+ }
+ | is EXTERNAL as LITERAL
+ {
+ auto f = cbl_file_of(symbol_at(file_section_fd));
+ f->attr |= external_e;
+ yyerror("AS LITERAL not implemented");
+ }
+ | fd_linage
+ | fd_report {
+ yyerror("REPORT WRITER not implemented");
+ YYERROR;
+ }
;
block_desc: BLOCK contains rec_contains chars_recs
;
-rec_contains: NUMSTR[min] {
- ssize_t n;
- if( (n = numstr2i($min.string, $min.radix)) < 0 ) {
- yyerrorv("size %s cannot be negative", $min.string);
- YYERROR;
+rec_contains: NUMSTR[min] {
+ ssize_t n;
+ if( (n = numstr2i($min.string, $min.radix)) < 0 ) {
+ yyerrorv("size %s cannot be negative", $min.string);
+ YYERROR;
}
- $$.min = $$.max = n; // fixed length
- }
- | NUMSTR[min] TO NUMSTR[max] {
- ssize_t n;
- if( (n = numstr2i($min.string, $min.radix)) < 0 ) {
- yyerrorv("size %s cannot be negative", $min.string);
- YYERROR;
+ $$.min = $$.max = n; // fixed length
+ }
+ | NUMSTR[min] TO NUMSTR[max] {
+ ssize_t n;
+ if( (n = numstr2i($min.string, $min.radix)) < 0 ) {
+ yyerrorv("size %s cannot be negative", $min.string);
+ YYERROR;
}
- $$.min = n;
+ $$.min = n;
- if( (n = numstr2i($max.string, $max.radix)) < 0 ) {
- yyerrorv("size %s cannot be negative", $max.string);
- YYERROR;
+ if( (n = numstr2i($max.string, $max.radix)) < 0 ) {
+ yyerrorv("size %s cannot be negative", $max.string);
+ YYERROR;
}
- $$.max = n;
- if( !($$.min < $$.max) ) {
- yyerrorv("FROM (%xz) must be less than TO (%zu)",
- $$.min, $$.max);
- YYERROR;
+ $$.max = n;
+ if( !($$.min < $$.max) ) {
+ yyerrorv("FROM (%xz) must be less than TO (%zu)",
+ $$.min, $$.max);
+ YYERROR;
}
- }
+ }
;
chars_recs: %empty
- | CHARACTERS
+ | CHARACTERS
| RECORDS
;
@@ -2349,9 +2349,9 @@ fd_values: fd_value
no effect on the execution of the program." */
fd_value: NAME is alpha_val
;
-alpha_val: alphaval
- | scalar
- ;
+alpha_val: alphaval
+ | scalar
+ ;
fd_labels: fd_label
| fd_labels fd_label
@@ -2375,63 +2375,63 @@ in_size: IN SIZE
;
from_to: FROM NUMSTR[min] TO NUMSTR[max] characters {
- ssize_t n;
- if( (n = numstr2i($min.string, $min.radix)) < 0 ) {
- yyerrorv("size %s cannot be negative", $min.string);
- YYERROR;
- }
- $$.min = n;
- if( (n = numstr2i($max.string, $max.radix)) < 0 ) {
- yyerrorv("size %s cannot be negative", $max.string);
- YYERROR;
- }
- $$.max = n;
- }
- | NUMSTR[min] TO NUMSTR[max] characters {
- ssize_t n;
- if( (n = numstr2i($min.string, $min.radix)) < 0 ) {
- yyerrorv("size %s cannot be negative", $min.string);
- YYERROR;
- }
- $$.min = n;
- if( (n = numstr2i($max.string, $max.radix)) < 0 ) {
- yyerrorv("size %s cannot be negative", $max.string);
- YYERROR;
- }
- $$.max = n;
- }
-
- | TO NUMSTR[max] characters {
- ssize_t n;
- if( (n = numstr2i($max.string, $max.radix)) < 0 ) {
- yyerrorv("size %s cannot be negative", $max.string);
- YYERROR;
- }
- $$.min = 0;
- $$.max = n;
- }
-
- | FROM NUMSTR[min] characters {
- ssize_t n;
- if( (n = numstr2i($min.string, $min.radix)) < 0 ) {
- yyerrorv("size %s cannot be negative", $min.string);
- YYERROR;
- }
- $$.min = n;
- $$.max = size_t(-1);
- }
- | NUMSTR[min] characters {
- ssize_t n;
- if( (n = numstr2i($min.string, $min.radix)) < 0 ) {
- yyerrorv("size %s cannot be negative", $min.string);
- YYERROR;
+ ssize_t n;
+ if( (n = numstr2i($min.string, $min.radix)) < 0 ) {
+ yyerrorv("size %s cannot be negative", $min.string);
+ YYERROR;
}
$$.min = n;
- $$.max = size_t(-1);
- }
-
- | CHARACTERS { $$.min = 0; $$.max = size_t(-1); }
- ;
+ if( (n = numstr2i($max.string, $max.radix)) < 0 ) {
+ yyerrorv("size %s cannot be negative", $max.string);
+ YYERROR;
+ }
+ $$.max = n;
+ }
+ | NUMSTR[min] TO NUMSTR[max] characters {
+ ssize_t n;
+ if( (n = numstr2i($min.string, $min.radix)) < 0 ) {
+ yyerrorv("size %s cannot be negative", $min.string);
+ YYERROR;
+ }
+ $$.min = n;
+ if( (n = numstr2i($max.string, $max.radix)) < 0 ) {
+ yyerrorv("size %s cannot be negative", $max.string);
+ YYERROR;
+ }
+ $$.max = n;
+ }
+
+ | TO NUMSTR[max] characters {
+ ssize_t n;
+ if( (n = numstr2i($max.string, $max.radix)) < 0 ) {
+ yyerrorv("size %s cannot be negative", $max.string);
+ YYERROR;
+ }
+ $$.min = 0;
+ $$.max = n;
+ }
+
+ | FROM NUMSTR[min] characters {
+ ssize_t n;
+ if( (n = numstr2i($min.string, $min.radix)) < 0 ) {
+ yyerrorv("size %s cannot be negative", $min.string);
+ YYERROR;
+ }
+ $$.min = n;
+ $$.max = size_t(-1);
+ }
+ | NUMSTR[min] characters {
+ ssize_t n;
+ if( (n = numstr2i($min.string, $min.radix)) < 0 ) {
+ yyerrorv("size %s cannot be negative", $min.string);
+ YYERROR;
+ }
+ $$.min = n;
+ $$.max = size_t(-1);
+ }
+
+ | CHARACTERS { $$.min = 0; $$.max = size_t(-1); }
+ ;
depending: %empty
| DEPENDING on NAME
@@ -2440,50 +2440,50 @@ depending: %empty
symbol_elem_t *e = symbol_at(file_section_fd);
assert(e);
auto file = cbl_file_of(e);
- size_t odo;
+ size_t odo;
if( (e = symbol_field(PROGRAM, 0, $3)) != NULL ) {
- assert(e->type == SymField);
- odo = symbol_index(e);
- } else {
- struct cbl_field_t fwd = { 0,
+ assert(e->type == SymField);
+ odo = symbol_index(e);
+ } else {
+ struct cbl_field_t fwd = { 0,
FldForward, FldInvalid, 0,0,0,0, nonarray, 0, "",
0, {0,0,0,0, " ", NULL, {NULL}, {NULL}}, NULL };
if( !namcpy(fwd.name, $3) ) YYERROR;
odo = field_index(field_add(&fwd));
- }
+ }
file->record_length = odo;
assert( file->record_length > 0 );
}
;
-fd_linage: LINAGE is num_value with_footings
- | LINAGE is num_value lines
- ;
-with_footings: with_footing
- | with_footings with_footing
- ;
-with_footing: lines with FOOTING at num_value
- | lines at top_bot num_value
- ;
-top_bot: TOP
- | BOTTOM
- ;
+fd_linage: LINAGE is num_value with_footings
+ | LINAGE is num_value lines
+ ;
+with_footings: with_footing
+ | with_footings with_footing
+ ;
+with_footing: lines with FOOTING at num_value
+ | lines at top_bot num_value
+ ;
+top_bot: TOP
+ | BOTTOM
+ ;
-fd_report: REPORT
- | REPORTS
- ;
+fd_report: REPORT
+ | REPORTS
+ ;
-fields_maybe: %empty
- | fields
- ;
+fields_maybe: %empty
+ | fields
+ ;
fields: field
| fields field
;
field: cdf
- | data_descr '.'
+ | data_descr '.'
{
if( in_file_section() && $data_descr->level == 1 ) {
if( !file_section_parent_set($data_descr) ) {
@@ -2492,63 +2492,63 @@ field: cdf
}
field_done();
- const auto& field(*$data_descr);
-
- // If prior field is complete because it's the same level,
- // make sure it's valid.
- if( false && !YYRECOVERING() ) {
- auto e = symbol_at(field_index($data_descr) - 1);
- if( e->type == SymField ) {
- const auto& prior = *cbl_field_of(e);
- if( !is_record_area(&prior) &&
- prior.type == FldInvalid &&
- prior.level == field.level )
- {
- yyerrorv("error: %02u %s requires PICTURE",
- prior.level, prior.name);
- if( yydebug ) yyerror(field_str($data_descr));
- YYERROR;
- }
- }
- }
-
- // Format data.initial per picture
- if( 0 == pristine_values.count(field.data.initial) ) {
- if( field.data.digits > 0 &&
- field.data.value != 0.0 )
- {
- char *initial;
- int rdigits = field.data.rdigits < 0?
- 1 : field.data.rdigits + 1;
-
- if( field.has_attr(scaled_e) ) {
- if( field.data.rdigits > 0 ) {
- rdigits = field.data.digits + field.data.rdigits;
- } else {
- rdigits = 0;
- }
- }
- initial = string_of(field.data.value);
- if( !initial ) {
- yyerror(strerror(errno));
- YYERROR;
- }
- char decimal = symbol_decimal_point();
- std::replace(initial, initial + strlen(initial), '.', decimal);
- free(const_cast<char*>($data_descr->data.initial));
- $data_descr->data.initial = initial;
- if( yydebug ) {
- const char *value_str = string_of(field.data.value);
- warnx("%s::data.initial is (%%%d.%d) %s ==> '%s'",
- field.name,
- field.data.digits,
- rdigits,
- value_str? value_str : "",
- field.data.initial);
- }
- }
- }
- }
+ const auto& field(*$data_descr);
+
+ // If prior field is complete because it's the same level,
+ // make sure it's valid.
+ if( false && !YYRECOVERING() ) {
+ auto e = symbol_at(field_index($data_descr) - 1);
+ if( e->type == SymField ) {
+ const auto& prior = *cbl_field_of(e);
+ if( !is_record_area(&prior) &&
+ prior.type == FldInvalid &&
+ prior.level == field.level )
+ {
+ yyerrorv("error: %02u %s requires PICTURE",
+ prior.level, prior.name);
+ if( yydebug ) yyerror(field_str($data_descr));
+ YYERROR;
+ }
+ }
+ }
+
+ // Format data.initial per picture
+ if( 0 == pristine_values.count(field.data.initial) ) {
+ if( field.data.digits > 0 &&
+ field.data.value != 0.0 )
+ {
+ char *initial;
+ int rdigits = field.data.rdigits < 0?
+ 1 : field.data.rdigits + 1;
+
+ if( field.has_attr(scaled_e) ) {
+ if( field.data.rdigits > 0 ) {
+ rdigits = field.data.digits + field.data.rdigits;
+ } else {
+ rdigits = 0;
+ }
+ }
+ initial = string_of(field.data.value);
+ if( !initial ) {
+ yyerror(strerror(errno));
+ YYERROR;
+ }
+ char decimal = symbol_decimal_point();
+ std::replace(initial, initial + strlen(initial), '.', decimal);
+ free(const_cast<char*>($data_descr->data.initial));
+ $data_descr->data.initial = initial;
+ if( yydebug ) {
+ const char *value_str = string_of(field.data.value);
+ warnx("%s::data.initial is (%%%d.%d) %s ==> '%s'",
+ field.name,
+ field.data.digits,
+ rdigits,
+ value_str? value_str : "",
+ field.data.initial);
+ }
+ }
+ }
+ }
;
occurs_clause: OCCURS cardinal_lb indexed
@@ -2564,7 +2564,7 @@ cardinal_lb: cardinal times {
cardinal: NUMSTR[input]
{
- $$ = numstr2i( $input.string, $input.radix );
+ $$ = numstr2i( $input.string, $input.radix );
}
;
@@ -2627,17 +2627,17 @@ index_fields: index_field1
;
index_field1: ctx_name[name]
{
- static const cbl_field_data_t data { .capacity = 8, .digits = 16 };
- cbl_field_t field = { .type = FldIndex,
- .parent = field_index(current_field()),
- .data = data };
+ static const cbl_field_data_t data { .capacity = 8, .digits = 16 };
+ cbl_field_t field = { .type = FldIndex,
+ .parent = field_index(current_field()),
+ .data = data };
if( !namcpy(field.name, $name) ) YYERROR;
- auto symbol = symbol_field(PROGRAM, 0, $name);
- if( symbol ) {
- auto field( cbl_field_of(symbol) );
+ auto symbol = symbol_field(PROGRAM, 0, $name);
+ if( symbol ) {
+ auto field( cbl_field_of(symbol) );
yyerrorv( "syntax error, %s already defined on line %d",
- field->name, field->line );
+ field->name, field->line );
YYERROR;
}
@@ -2649,8 +2649,8 @@ index_field1: ctx_name[name]
#if 0
symbol_field_index_set($name);
void symbol_map_update_one( size_t program, size_t new_parent, cbl_field_t *field );
- ////symbol_map_update_one(PROGRAM, field_index(current_field()), $name);
- $name->parent = field_index(current_field());
+ ////symbol_map_update_one(PROGRAM, field_index(current_field()), $name);
+ $name->parent = field_index(current_field());
#endif
if( !current_field()->occurs.index_add(index) ) {
yyerror("failed to add index field");
@@ -2661,16 +2661,16 @@ index_field1: ctx_name[name]
level_name: LEVEL ctx_name
{
- switch($LEVEL) {
- case 1 ... 49:
- case 66:
- case 77:
- case 88:
- break;
- default:
- yyerrorv("syntax error: LEVEL %02d not supported", $LEVEL);
- YYERROR;
- }
+ switch($LEVEL) {
+ case 1 ... 49:
+ case 66:
+ case 77:
+ case 88:
+ break;
+ default:
+ yyerrorv("syntax error: LEVEL %02d not supported", $LEVEL);
+ YYERROR;
+ }
struct cbl_field_t field = { 0,
FldInvalid, FldInvalid, 0, 0, 0, $1, nonarray, yylineno, "",
0, { 0,0,0,0, NULL, NULL, { NULL }, { NULL } }, NULL };
@@ -2684,16 +2684,16 @@ level_name: LEVEL ctx_name
}
| LEVEL
{
- switch($LEVEL) {
- case 1 ... 49:
- case 66:
- case 77:
- case 88:
- break;
- default:
- yyerrorv("syntax error: LEVEL %02d not supported", $LEVEL);
- YYERROR;
- }
+ switch($LEVEL) {
+ case 1 ... 49:
+ case 66:
+ case 77:
+ case 88:
+ break;
+ default:
+ yyerrorv("syntax error: LEVEL %02d not supported", $LEVEL);
+ YYERROR;
+ }
struct cbl_field_t field = { 0,
FldInvalid, FldInvalid, 0, 0, 0, $1, nonarray, yylineno, "",
0, { 0,0,0,0, NULL, NULL, { NULL }, { NULL } }, NULL };
@@ -2717,32 +2717,32 @@ data_descr: data_descr1
cbl_field_type_str($$->usage) + 3);
}
}
- | error { static cbl_field_t none = {}; $$ = &none; }
- ;
-
-const_value: cce_expr
- | BYTE_LENGTH of name { $$ = $name->data.capacity; }
- | LENGTH of name { $$ = $name->data.capacity; }
- | LENGTH_OF of name { $$ = $name->data.capacity; }
- ;
-
-value78: literalism
- {
- cbl_field_data_t data = { .capacity = strlen($1.data),
- .initial = $1.data };
- $$ = new cbl_field_data_t(data);
- }
- | const_value
- {
- cbl_field_data_t data = { .value = $1 };
- $$ = new cbl_field_data_t(data);
- }
- | true_false
- {
- yyerror("error: not implemented: Boolean constant");
- YYERROR;
- }
- ;
+ | error { static cbl_field_t none = {}; $$ = &none; }
+ ;
+
+const_value: cce_expr
+ | BYTE_LENGTH of name { $$ = $name->data.capacity; }
+ | LENGTH of name { $$ = $name->data.capacity; }
+ | LENGTH_OF of name { $$ = $name->data.capacity; }
+ ;
+
+value78: literalism
+ {
+ cbl_field_data_t data = { .capacity = strlen($1.data),
+ .initial = $1.data };
+ $$ = new cbl_field_data_t(data);
+ }
+ | const_value
+ {
+ cbl_field_data_t data = { .value = $1 };
+ $$ = new cbl_field_data_t(data);
+ }
+ | true_false
+ {
+ yyerror("error: not implemented: Boolean constant");
+ YYERROR;
+ }
+ ;
data_descr1: level_name
{
@@ -2752,89 +2752,89 @@ data_descr1: level_name
}
}
- | level_name CONSTANT is_global as const_value
- {
- cbl_field_t& field = *$1;
- if( field.level != 1 ) {
- yyerrorv("%s must be an 01-level data item", field.name);
- YYERROR;
- }
-
- field.attr |= constant_e;
- if( $is_global ) field.attr |= global_e;
- field.type = FldLiteralN;
- field.data.value = $const_value;
- field.data.initial = string_of($const_value);
-
- if( !cdf_value(field.name, static_cast<int64_t>($const_value)) ) {
- yyerrorv("warning: %s defined by CDF", field.name);
- }
- }
- | level_name CONSTANT is_global as literalism[lit]
- {
- cbl_field_t& field = *$1;
- field.attr |= constant_e;
- if( $is_global ) field.attr |= global_e;
- field.type = FldLiteralA;
- field.data.capacity = $lit.len;
- field.data.initial = $lit.data;
- field.attr |= literal_attr($lit.prefix);
- if( field.level != 1 ) {
- yyerrorv("%s must be an 01-level data item", field.name);
- YYERROR;
- }
- if( !cdf_value(field.name, $lit.data) ) {
- yyerrorv("warning: %s defined by CDF", field.name);
- }
- value_encoding_check(&field);
- }
- | level_name CONSTANT is_global FROM NAME
+ | level_name CONSTANT is_global as const_value
+ {
+ cbl_field_t& field = *$1;
+ if( field.level != 1 ) {
+ yyerrorv("%s must be an 01-level data item", field.name);
+ YYERROR;
+ }
+
+ field.attr |= constant_e;
+ if( $is_global ) field.attr |= global_e;
+ field.type = FldLiteralN;
+ field.data.value = $const_value;
+ field.data.initial = string_of($const_value);
+
+ if( !cdf_value(field.name, static_cast<int64_t>($const_value)) ) {
+ yyerrorv("warning: %s defined by CDF", field.name);
+ }
+ }
+ | level_name CONSTANT is_global as literalism[lit]
+ {
+ cbl_field_t& field = *$1;
+ field.attr |= constant_e;
+ if( $is_global ) field.attr |= global_e;
+ field.type = FldLiteralA;
+ field.data.capacity = $lit.len;
+ field.data.initial = $lit.data;
+ field.attr |= literal_attr($lit.prefix);
+ if( field.level != 1 ) {
+ yyerrorv("%s must be an 01-level data item", field.name);
+ YYERROR;
+ }
+ if( !cdf_value(field.name, $lit.data) ) {
+ yyerrorv("warning: %s defined by CDF", field.name);
+ }
+ value_encoding_check(&field);
+ }
+ | level_name CONSTANT is_global FROM NAME
{
assert($1 == current_field());
- const cdfval_t *cdfval = cdf_value($NAME);
- if( !cdfval ) {
- yyerrorv("error: %s is not defined by CDF", $NAME);
- YYERROR;
- }
- cbl_field_t& field = *$1;
- field.attr |= ($is_global | constant_e);
- field.data.capacity = cdfval->string ? strlen(cdfval->string)
- : sizeof(field.data.value);
- field.data.initial = cdfval->string;
- field.data.value = cdfval->number;
- if( !cdf_value(field.name, *cdfval) ) {
- yyerrorv("warning: %s defined by CDF", field.name);
- }
- }
-
- | LEVEL78 NAME[name] VALUE is value78[data]
- {
- if( ! dialect_mf() ) {
+ const cdfval_t *cdfval = cdf_value($NAME);
+ if( !cdfval ) {
+ yyerrorv("error: %s is not defined by CDF", $NAME);
+ YYERROR;
+ }
+ cbl_field_t& field = *$1;
+ field.attr |= ($is_global | constant_e);
+ field.data.capacity = cdfval->string ? strlen(cdfval->string)
+ : sizeof(field.data.value);
+ field.data.initial = cdfval->string;
+ field.data.value = cdfval->number;
+ if( !cdf_value(field.name, *cdfval) ) {
+ yyerrorv("warning: %s defined by CDF", field.name);
+ }
+ }
+
+ | LEVEL78 NAME[name] VALUE is value78[data]
+ {
+ if( ! dialect_mf() ) {
yyerror("error: level 78 requires -dialect mf");
YYERROR;
- }
+ }
struct cbl_field_t field = { 0, FldLiteralA, FldInvalid,
constant_e, 0, 0, 78, nonarray,
- yylineno, "", 0, *$data, NULL };
+ yylineno, "", 0, *$data, NULL };
if( !namcpy(field.name, $name) ) YYERROR;
- if( field.data.initial ) {
- field.attr |= quoted_e;
- if( !cdf_value(field.name, field.data.initial) ) {
- yyerrorv("warning: %s defined by CDF", field.name);
- }
- } else {
- field.type = FldLiteralN;
- field.data.initial = string_of(field.data.value);
- if( !cdf_value(field.name,
- static_cast<int64_t>(field.data.value)) ) {
- yyerrorv("warning: %s defined by CDF", field.name);
- }
- }
+ if( field.data.initial ) {
+ field.attr |= quoted_e;
+ if( !cdf_value(field.name, field.data.initial) ) {
+ yyerrorv("warning: %s defined by CDF", field.name);
+ }
+ } else {
+ field.type = FldLiteralN;
+ field.data.initial = string_of(field.data.value);
+ if( !cdf_value(field.name,
+ static_cast<int64_t>(field.data.value)) ) {
+ yyerrorv("warning: %s defined by CDF", field.name);
+ }
+ }
if( ($$ = field_add(&field)) == NULL ) {
yyerror("failed level 78");
YYERROR;
}
- }
+ }
| LEVEL88 NAME /* VALUE */ NULLPTR
{
@@ -2843,10 +2843,10 @@ data_descr1: level_name
0, { 0,0,0,0, NULL, NULL, { NULL }, { NULL } }, NULL };
if( !namcpy(field.name, $2) ) YYERROR;
- auto fig = constant_of(constant_index(NULLS));
+ auto fig = constant_of(constant_index(NULLS));
struct cbl_domain_t *domain = new cbl_domain_t[2];
- domain[0] = fig;
+ domain[0] = fig;
field.data.domain = domain;
@@ -2854,12 +2854,12 @@ data_descr1: level_name
yyerror("failed level 88");
YYERROR;
}
- auto parent = cbl_field_of(symbol_at($$->parent));
- if( parent->type != FldPointer ) {
- yyerrorv("error: LEVEL 88 %s VALUE NULLS invalid for "
- "%02d %s, which is not a POINTER",
- $$->name, parent->level, parent->name);
- }
+ auto parent = cbl_field_of(symbol_at($$->parent));
+ if( parent->type != FldPointer ) {
+ yyerrorv("error: LEVEL 88 %s VALUE NULLS invalid for "
+ "%02d %s, which is not a POINTER",
+ $$->name, parent->level, parent->name);
+ }
}
| LEVEL88 NAME VALUE domains
{
@@ -2885,91 +2885,91 @@ data_descr1: level_name
| name66[alias] RENAMES name[orig]
{
- if( is_literal($orig) ) {
- yyerrorv("error: cannot RENAME '%s'", name_of($orig));
- YYERROR;
- }
- if( !immediately_follows($orig) ) {
- yyerrorv("error: %s must immediately follow %s to RENAME it",
- $alias, name_of($orig));
- YYERROR;
- }
- if( $orig->occurs.ntimes() ) {
- yyerrorv("error: cannot RENAME table %02u %s",
- $orig->level, name_of($orig));
- YYERROR;
- }
- auto table = occurs_in($orig);
- if( table ) {
- yyerrorv("error: cannot RENAME '%s' OF %s",
- name_of($orig), table->name);
- YYERROR;
- }
- if( ! $orig->rename_level_ok() ) {
- yyerrorv("error: cannot RENAME %02u %s",
- $orig->level, name_of($orig));
- YYERROR;
- }
+ if( is_literal($orig) ) {
+ yyerrorv("error: cannot RENAME '%s'", name_of($orig));
+ YYERROR;
+ }
+ if( !immediately_follows($orig) ) {
+ yyerrorv("error: %s must immediately follow %s to RENAME it",
+ $alias, name_of($orig));
+ YYERROR;
+ }
+ if( $orig->occurs.ntimes() ) {
+ yyerrorv("error: cannot RENAME table %02u %s",
+ $orig->level, name_of($orig));
+ YYERROR;
+ }
+ auto table = occurs_in($orig);
+ if( table ) {
+ yyerrorv("error: cannot RENAME '%s' OF %s",
+ name_of($orig), table->name);
+ YYERROR;
+ }
+ if( ! $orig->rename_level_ok() ) {
+ yyerrorv("error: cannot RENAME %02u %s",
+ $orig->level, name_of($orig));
+ YYERROR;
+ }
symbol_elem_t *orig = symbol_at(field_index($orig));
$$ = cbl_field_of(symbol_field_alias(orig, $alias));
}
| name66[alias] RENAMES name[orig] THRU name[thru]
{
- if( !immediately_follows($orig) ) {
- yyerrorv("error: RENAMES: %s must immediately follow %s",
- $alias, name_of($orig));
- YYERROR;
- }
- if( is_literal($orig) ) {
- yyerrorv("error: cannot RENAME '%s'", name_of($orig));
- YYERROR;
- }
- if( is_literal($thru) ) {
- yyerrorv("error: cannot RENAME '%s'", name_of($thru));
- YYERROR;
- }
- auto table = occurs_in($orig);
- if( table ) {
- yyerrorv("error: cannot RENAME '%s' OF %s",
- name_of($orig), table->name);
- YYERROR;
- }
- table = occurs_in($thru);
- if( table ) {
- yyerrorv("error: cannot RENAME '%s' OF %s",
- name_of($thru), table->name);
- YYERROR;
- }
- if( ! $orig->rename_level_ok() ) {
- yyerrorv("error: cannot RENAME %02u %s",
- $orig->level, name_of($orig));
- YYERROR;
- }
- if( $orig->has_subordinate($thru) ) {
- yyerrorv("error: cannot RENAME %02u %s THRU %02u %s "
- "because %s is subordinate to %s",
- $orig->level, name_of($orig),
- $thru->level, name_of($thru),
- name_of($thru), name_of($orig));
- YYERROR;
- }
- auto not_ok = rename_not_ok($orig, $thru);
- if( not_ok ) {
- yyerrorv("error: cannot RENAME %02u %s THRU %02u %s "
- "because %02u %s cannot be renamed",
- $orig->level, name_of($orig),
- $thru->level, name_of($thru),
- not_ok->level, name_of(not_ok));
- YYERROR;
- }
- if( field_index($thru) <= field_index($orig) ) {
- yyerrorv("error: cannot RENAME %02u %s THRU %02u %s "
- "because they're in the wrong order",
- $orig->level, name_of($orig),
- $thru->level, name_of($thru));
- YYERROR;
- }
+ if( !immediately_follows($orig) ) {
+ yyerrorv("error: RENAMES: %s must immediately follow %s",
+ $alias, name_of($orig));
+ YYERROR;
+ }
+ if( is_literal($orig) ) {
+ yyerrorv("error: cannot RENAME '%s'", name_of($orig));
+ YYERROR;
+ }
+ if( is_literal($thru) ) {
+ yyerrorv("error: cannot RENAME '%s'", name_of($thru));
+ YYERROR;
+ }
+ auto table = occurs_in($orig);
+ if( table ) {
+ yyerrorv("error: cannot RENAME '%s' OF %s",
+ name_of($orig), table->name);
+ YYERROR;
+ }
+ table = occurs_in($thru);
+ if( table ) {
+ yyerrorv("error: cannot RENAME '%s' OF %s",
+ name_of($thru), table->name);
+ YYERROR;
+ }
+ if( ! $orig->rename_level_ok() ) {
+ yyerrorv("error: cannot RENAME %02u %s",
+ $orig->level, name_of($orig));
+ YYERROR;
+ }
+ if( $orig->has_subordinate($thru) ) {
+ yyerrorv("error: cannot RENAME %02u %s THRU %02u %s "
+ "because %s is subordinate to %s",
+ $orig->level, name_of($orig),
+ $thru->level, name_of($thru),
+ name_of($thru), name_of($orig));
+ YYERROR;
+ }
+ auto not_ok = rename_not_ok($orig, $thru);
+ if( not_ok ) {
+ yyerrorv("error: cannot RENAME %02u %s THRU %02u %s "
+ "because %02u %s cannot be renamed",
+ $orig->level, name_of($orig),
+ $thru->level, name_of($thru),
+ not_ok->level, name_of(not_ok));
+ YYERROR;
+ }
+ if( field_index($thru) <= field_index($orig) ) {
+ yyerrorv("error: cannot RENAME %02u %s THRU %02u %s "
+ "because they're in the wrong order",
+ $orig->level, name_of($orig),
+ $thru->level, name_of($thru));
+ YYERROR;
+ }
symbol_elem_t *orig = symbol_at(field_index($orig));
symbol_elem_t *last = symbol_at(field_index($thru));
$$ = cbl_field_of(symbol_field_alias2(orig, last, $alias));
@@ -2982,37 +2982,37 @@ data_descr1: level_name
#endif
assert($field == current_field());
if( $data_clauses == value_clause_e ) { // only VALUE, no PIC
- // Error unless VALUE is a figurative constant or (quoted) string.
- if( $field->type != FldPointer &&
- ! $field->has_attr(quoted_e) &&
- normal_value_e == cbl_figconst_of($field->data.initial) )
- {
- yyerrorv("error: %s numeric VALUE %s requires PICTURE",
- $field->name, $field->data.initial);
- }
- if( null_value_e == cbl_figconst_of($field->data.initial) ) {
- // don't change the type
- assert(FldPointer == $field->type);
- } else {
- // alphanumeric VALUE by itself implies alphanumeric type
- assert(FldPointer != $field->type);
+ // Error unless VALUE is a figurative constant or (quoted) string.
+ if( $field->type != FldPointer &&
+ ! $field->has_attr(quoted_e) &&
+ normal_value_e == cbl_figconst_of($field->data.initial) )
+ {
+ yyerrorv("error: %s numeric VALUE %s requires PICTURE",
+ $field->name, $field->data.initial);
+ }
+ if( null_value_e == cbl_figconst_of($field->data.initial) ) {
+ // don't change the type
+ assert(FldPointer == $field->type);
+ } else {
+ // alphanumeric VALUE by itself implies alphanumeric type
+ assert(FldPointer != $field->type);
$field->type = FldAlphanumeric;
- if( $field->data.initial ) {
+ if( $field->data.initial ) {
$field->data.capacity = strlen($field->data.initial);
- }
- }
+ }
+ }
}
// Verify BLANK WHEN ZERO
if( $field->has_attr(blank_zero_e) ) {
- switch($field->type) {
- case FldNumericEdited:
- if( $field->has_attr(signable_e) ) {
- yyerrorv( "%s has 'S' in PICTURE, cannot be BLANK WHEN ZERO",
+ switch($field->type) {
+ case FldNumericEdited:
+ if( $field->has_attr(signable_e) ) {
+ yyerrorv( "%s has 'S' in PICTURE, cannot be BLANK WHEN ZERO",
$field->name, cbl_field_type_str($field->type) );
- }
- break;
- default:
+ }
+ break;
+ default:
yyerrorv( "%s must be "
"NUMERIC DISPLAY or NUMERIC-EDITED, not %s",
$field->name, cbl_field_type_str($field->type) );
@@ -3021,31 +3021,31 @@ data_descr1: level_name
}
#if 0
- if( has_clause ($data_clauses, value_clause_e) &&
- !has_clause ($data_clauses, picture_clause_e) ) {
- if( !$field->has_attr(constant_e) &&
- !$field->has_attr(filler_e) ) {
- if( needs_picture($field->type) ) {
- yyerrorv("syntax error: %s has VALUE but no PICTURE {%s %s}",
- $field->name, cbl_field_type_str($field->type),
- field_str($field));
- }
- }
+ if( has_clause ($data_clauses, value_clause_e) &&
+ !has_clause ($data_clauses, picture_clause_e) ) {
+ if( !$field->has_attr(constant_e) &&
+ !$field->has_attr(filler_e) ) {
+ if( needs_picture($field->type) ) {
+ yyerrorv("syntax error: %s has VALUE but no PICTURE {%s %s}",
+ $field->name, cbl_field_type_str($field->type),
+ field_str($field));
+ }
+ }
}
#endif
// SIGN clause valid only with "S" in picture
if( $field->type == FldNumericDisplay && !is_signable($field) ) {
static const size_t sign_attrs = leading_e | separate_e;
- static_assert(sizeof(sign_attrs) == sizeof($field->attr),
- "size matters");
+ static_assert(sizeof(sign_attrs) == sizeof($field->attr),
+ "size matters");
// remove inapplicable inherited sign attributes
size_t group_sign = group_attr($field) & sign_attrs;
$field->attr &= ~group_sign;
if( $field->attr & sign_attrs ) {
- if( yydebug ) warnx("%s:%d: %s", __func__, __LINE__,
- field_str($field));
+ if( yydebug ) warnx("%s:%d: %s", __func__, __LINE__,
+ field_str($field));
yyerrorv( "error: %s must be signed for SIGN IS",
$field->name );
YYERROR;
@@ -3061,122 +3061,122 @@ data_descr1: level_name
// Set Packed-Decimal capacity
if( $field->type == FldPacked ) {
- $field->data.capacity = type_capacity($field->type,
- $field->data.digits);
+ $field->data.capacity = type_capacity($field->type,
+ $field->data.digits);
}
// Check COMP-5 capacity
if( $field->type == FldNumericBin5 && $field->data.capacity == 0 ) {
- if( has_clause ($data_clauses, usage_clause_e) &&
- !has_clause ($data_clauses, picture_clause_e) ) {
+ if( has_clause ($data_clauses, usage_clause_e) &&
+ !has_clause ($data_clauses, picture_clause_e) ) {
yyerrorv( "error: %s: COMP-5 requires PICTURE",
$field->name );
- }
+ }
}
- // Ensure a string-valued VALUE fits in the defined size
- if( $field->type == FldAlphanumeric && $field->data.initial ) {
- if( $field->data.capacity < strlen($field->data.initial) &&
- $field->data.value == 0 ) {
- auto p = $field->data.initial+ strlen($field->data.initial);
- if( ! ($field->data.capacity + 1 == strlen($field->data.initial) &&
- p[-1] == '!') ) {
- char *msg;
+ // Ensure a string-valued VALUE fits in the defined size
+ if( $field->type == FldAlphanumeric && $field->data.initial ) {
+ if( $field->data.capacity < strlen($field->data.initial) &&
+ $field->data.value == 0 ) {
+ auto p = $field->data.initial+ strlen($field->data.initial);
+ if( ! ($field->data.capacity + 1 == strlen($field->data.initial) &&
+ p[-1] == '!') ) {
+ char *msg;
//// This message pops up when there are multi-byte UTF-8 characters in the
//// VALUE, which makes it not very useful
- if( -1 == asprintf(&msg, "warning: VALUE of %s "
- "has length %zu, exceeding its size (%u)",
- $field->name, strlen($field->data.initial),
- $field->data.capacity) ) {
- yyerror("could not allocate VALUE size error message");
- YYNOMEM;
- }
-//// yywarn(msg);
- }
+ if( -1 == asprintf(&msg, "warning: VALUE of %s "
+ "has length %zu, exceeding its size (%u)",
+ $field->name, strlen($field->data.initial),
+ $field->data.capacity) ) {
+ yyerror("could not allocate VALUE size error message");
+ YYNOMEM;
+ }
+//// yywarn(msg);
+ }
+ }
+ }
+ // Ensure signed initial VALUE is for signed numeric type
+ if( is_numeric($field) && $field->data.initial && $field->type != FldFloat) {
+ switch( $field->data.initial[0] ) {
+ case '-': case '+':
+ if( !$field->has_attr(signable_e) ) {
+ yyerrorv("error: %s is unsigned but has signed VALUE '%s'",
+ $field->name, $field->data.initial);
+ }
}
- }
- // Ensure signed initial VALUE is for signed numeric type
- if( is_numeric($field) && $field->data.initial && $field->type != FldFloat) {
- switch( $field->data.initial[0] ) {
- case '-': case '+':
- if( !$field->has_attr(signable_e) ) {
- yyerrorv("error: %s is unsigned but has signed VALUE '%s'",
- $field->name, $field->data.initial);
- }
- }
- }
-
- // Verify VALUE
- $field->report_invalid_initial_value();
-
- // verify REDEFINES
- auto parent = parent_of($field);
- if( parent && $field->level == parent->level ) {
- valid_redefine($field, parent); // calls yyerror
- }
+ }
+
+ // Verify VALUE
+ $field->report_invalid_initial_value();
+
+ // verify REDEFINES
+ auto parent = parent_of($field);
+ if( parent && $field->level == parent->level ) {
+ valid_redefine($field, parent); // calls yyerror
+ }
#if 0
- // NC116A:45: 004400 01 TEST-17-DATA SIGN TRAILING.
- // Ensure SIGN IS applies to numeric type
- if( !is_numeric($field) && is_signable($field) ) {
- yyerrorv("error: %s is nonnumeric but specifies SIGN",
- $field->name);
- }
+ // NC116A:45: 004400 01 TEST-17-DATA SIGN TRAILING.
+ // Ensure SIGN IS applies to numeric type
+ if( !is_numeric($field) && is_signable($field) ) {
+ yyerrorv("error: %s is nonnumeric but specifies SIGN",
+ $field->name);
+ }
#endif
- }
- ;
-
-literalism: literal_part { $$ = $1; }
- | literalism[first] '&' literal_part[second]
- {
- $$ = $first;
- literal_t& output($$);
-
- output.len += $second.len;
- output.data = reinterpret_cast<char*>(realloc(output.data,
- output.len + 1));
- if( output.data == NULL ) {
- yyerrorv("system error: %s", strerror(errno));
- YYERROR;
- }
- memcpy( output.data + $first.len, $second.data, $second.len );
- output.data[output.len] = '\0';
-
- if( $second.prefix[0] ) { strcpy(output.prefix, $second.prefix); }
- if( 0 != strcmp($first.prefix, $second.prefix) ) {
- warnx("warning: dissimilar literals, '%s' prevails",
- output.prefix);
- }
- }
- ;
-literal_part: LITERAL
- | ctx_name
- {
- auto e = symbol_field(PROGRAM, 0, $ctx_name);
- if( ! e ) {
- yyerrorv("syntax error: data item not found: %s",
- $ctx_name);
- YYERROR;
- }
- auto& field = *cbl_field_of(e);
- if( ! is_constant(&field) ) {
- yyerrorv("syntax error: %s does not refer to CONSTANT",
- $ctx_name);
- YYERROR;
- }
- literal_t output;
- output.set(0, const_cast<char*>(field.data.initial), "");
- if( !output.data ) {
- output.data = string_of(field.data.value);
- if( !output.data ) {
- yyerror(strerror(errno));
- YYERROR;
- }
- }
- assert(output.data);
- output.len = strlen(output.data);
- $$ = output;
- }
- ;
+ }
+ ;
+
+literalism: literal_part { $$ = $1; }
+ | literalism[first] '&' literal_part[second]
+ {
+ $$ = $first;
+ literal_t& output($$);
+
+ output.len += $second.len;
+ output.data = reinterpret_cast<char*>(realloc(output.data,
+ output.len + 1));
+ if( output.data == NULL ) {
+ yyerrorv("system error: %s", strerror(errno));
+ YYERROR;
+ }
+ memcpy( output.data + $first.len, $second.data, $second.len );
+ output.data[output.len] = '\0';
+
+ if( $second.prefix[0] ) { strcpy(output.prefix, $second.prefix); }
+ if( 0 != strcmp($first.prefix, $second.prefix) ) {
+ warnx("warning: dissimilar literals, '%s' prevails",
+ output.prefix);
+ }
+ }
+ ;
+literal_part: LITERAL
+ | ctx_name
+ {
+ auto e = symbol_field(PROGRAM, 0, $ctx_name);
+ if( ! e ) {
+ yyerrorv("syntax error: data item not found: %s",
+ $ctx_name);
+ YYERROR;
+ }
+ auto& field = *cbl_field_of(e);
+ if( ! is_constant(&field) ) {
+ yyerrorv("syntax error: %s does not refer to CONSTANT",
+ $ctx_name);
+ YYERROR;
+ }
+ literal_t output;
+ output.set(0, const_cast<char*>(field.data.initial), "");
+ if( !output.data ) {
+ output.data = string_of(field.data.value);
+ if( !output.data ) {
+ yyerror(strerror(errno));
+ YYERROR;
+ }
+ }
+ assert(output.data);
+ output.len = strlen(output.data);
+ $$ = output;
+ }
+ ;
name66: LEVEL66 NAME[alias]
{
@@ -3189,11 +3189,11 @@ data_clauses: data_clause
{
if( $data_clause == redefines_clause_e ) {
auto parent = parent_of(current_field());
- if( !parent ) {
+ if( !parent ) {
yyerrorv("error: %s invalid REDEFINES",
current_field()->name);
YYERROR;
- }
+ }
if( parent->occurs.ntimes() > 0 ) {
yyerrorv("error: %s cannot REDEFINE table %s",
current_field()->name,
@@ -3215,13 +3215,13 @@ data_clauses: data_clause
case redefines_clause_e: clause = "REDEFINES"; break;
case blank_zero_clause_e: clause = "BLANK WHEN ZERO"; break;
case synched_clause_e: clause = "SYNCHRONIZED"; break;
- case sign_clause_e: clause = "SIGN"; break;
- case based_clause_e: clause = "BASED"; break;
- case same_clause_e: clause = "SAME AS"; break;
- case volatile_clause_e: clause = "VOLATILE"; break;
- case type_clause_e: clause = "TYPE"; break;
- case typedef_clause_e: clause = "TYPEDEF"; break;
- }
+ case sign_clause_e: clause = "SIGN"; break;
+ case based_clause_e: clause = "BASED"; break;
+ case same_clause_e: clause = "SAME AS"; break;
+ case volatile_clause_e: clause = "VOLATILE"; break;
+ case type_clause_e: clause = "TYPE"; break;
+ case typedef_clause_e: clause = "TYPEDEF"; break;
+ }
if( ($$ & $2) == $2 ) {
yyerrorv("%s clause repeated", clause);
YYERROR;
@@ -3241,87 +3241,87 @@ data_clauses: data_clause
$$ |= $2;
- // If any implied TYPE bits are on in addition to
- // type_clause_e, they're in conflict.
- static const size_t type_implies =
- // ALIGNED clause not implemented
- blank_zero_clause_e | justified_clause_e | picture_clause_e
- | sign_clause_e | synched_clause_e | usage_clause_e;
-
- if( type_clause_e < ($$ & (type_clause_e | type_implies)) ) {
- if( $2 == type_clause_e ) {
- yyerror("error: TYPE TO incompatible with ALIGNED, "
- "BLANK WHEN ZERO, JUSTIFIED, PICTURE, SIGN, "
- "SYNCHRONIZED, and USAGE");
- } else {
- yyerrorv("error: %s incompatible with TYPE TO", clause);
- }
- YYERROR;
- }
-
- if( ($$ & same_clause_e) == same_clause_e ) {
- if( 0 < ($$ & ~same_clause_e) ) {
- yyerrorv("error: %02u %s SAME AS "
- "precludes other DATA DIVISION clauses",
- field->level, field->name);
- YYERROR;
- }
- }
-
- if( is_numeric(field->type) && field->type != FldNumericDisplay ) {
- if( $$ & sign_clause_e ) {
- yyerrorv("error: %s is binary NUMERIC type, "
- "incompatible with SIGN IS", field->name);
- }
- }
-
- if( gcobol_feature_embiggen() ) {
- if( field->is_binary_integer() && field->data.capacity == 4) {
- auto redefined = symbol_redefines(field);
- if( redefined && redefined->type == FldPointer ) {
- if( yydebug ) {
- warnx("expanding %s size from %u bytes to %zu "
- "because it redefines %s with USAGE POINTER",
- field->name, field->size(), sizeof(void*),
- redefined->name);
- }
- field->embiggen();
- }
- }
- }
-
- switch( field->type ) {
- case FldFloat:
+ // If any implied TYPE bits are on in addition to
+ // type_clause_e, they're in conflict.
+ static const size_t type_implies =
+ // ALIGNED clause not implemented
+ blank_zero_clause_e | justified_clause_e | picture_clause_e
+ | sign_clause_e | synched_clause_e | usage_clause_e;
+
+ if( type_clause_e < ($$ & (type_clause_e | type_implies)) ) {
+ if( $2 == type_clause_e ) {
+ yyerror("error: TYPE TO incompatible with ALIGNED, "
+ "BLANK WHEN ZERO, JUSTIFIED, PICTURE, SIGN, "
+ "SYNCHRONIZED, and USAGE");
+ } else {
+ yyerrorv("error: %s incompatible with TYPE TO", clause);
+ }
+ YYERROR;
+ }
+
+ if( ($$ & same_clause_e) == same_clause_e ) {
+ if( 0 < ($$ & ~same_clause_e) ) {
+ yyerrorv("error: %02u %s SAME AS "
+ "precludes other DATA DIVISION clauses",
+ field->level, field->name);
+ YYERROR;
+ }
+ }
+
+ if( is_numeric(field->type) && field->type != FldNumericDisplay ) {
+ if( $$ & sign_clause_e ) {
+ yyerrorv("error: %s is binary NUMERIC type, "
+ "incompatible with SIGN IS", field->name);
+ }
+ }
+
+ if( gcobol_feature_embiggen() ) {
+ if( field->is_binary_integer() && field->data.capacity == 4) {
+ auto redefined = symbol_redefines(field);
+ if( redefined && redefined->type == FldPointer ) {
+ if( yydebug ) {
+ warnx("expanding %s size from %u bytes to %zu "
+ "because it redefines %s with USAGE POINTER",
+ field->name, field->size(), sizeof(void*),
+ redefined->name);
+ }
+ field->embiggen();
+ }
+ }
+ }
+
+ switch( field->type ) {
+ case FldFloat:
if( ($$ & picture_clause_e) == picture_clause_e ) {
- yyerrorv("error: %s: FLOAT types do not allow PICTURE",
- field->name);
- }
- break;
- default:
- break;
- }
- }
+ yyerrorv("error: %s: FLOAT types do not allow PICTURE",
+ field->name);
+ }
+ break;
+ default:
+ break;
+ }
+ }
;
data_clause: any_length { $$ = any_length_e; }
- | based_clause { $$ = based_clause_e; }
+ | based_clause { $$ = based_clause_e; }
| blank_zero_clause { $$ = blank_zero_clause_e; }
| external_clause { $$ = external_clause_e; }
| global_clause { $$ = global_clause_e; }
| justified_clause { $$ = justified_clause_e; }
| occurs_clause { $$ = occurs_clause_e;
cbl_field_t *field = current_field();
- switch( field->level ) {
- case 1:
- case 77:
- case 88:
- yyerrorv( "syntax error: %02u %s: invalid LEVEL for OCCURS",
- field->level, field->name );
- break;
- default:
- assert( field->parent > 0 );
- }
- }
+ switch( field->level ) {
+ case 1:
+ case 77:
+ case 88:
+ yyerrorv( "syntax error: %02u %s: invalid LEVEL for OCCURS",
+ field->level, field->name );
+ break;
+ default:
+ assert( field->parent > 0 );
+ }
+ }
| picture_clause { $$ = picture_clause_e; }
| redefines_clause { $$ = redefines_clause_e; }
| same_clause { $$ = same_clause_e; }
@@ -3333,19 +3333,19 @@ data_clause: any_length { $$ = any_length_e; }
| value_clause { $$ = value_clause_e;
cbl_field_t *field = current_field();
- if( field->type != FldAlphanumeric &&
- field->data.initial && field->data.initial[0] )
- {
- // Embedded NULs are valid only in FldAlphanumeric, and are
- // already handled.
- if( strlen(field->data.initial) < field->data.capacity ) {
- auto p = blank_pad_initial( field->data.initial,
- strlen(field->data.initial),
- field->data.capacity );
+ if( field->type != FldAlphanumeric &&
+ field->data.initial && field->data.initial[0] )
+ {
+ // Embedded NULs are valid only in FldAlphanumeric, and are
+ // already handled.
+ if( strlen(field->data.initial) < field->data.capacity ) {
+ auto p = blank_pad_initial( field->data.initial,
+ strlen(field->data.initial),
+ field->data.capacity );
if( !p ) YYERROR;
- field->data.initial = p;
- }
- }
+ field->data.initial = p;
+ }
+ }
}
| volatile_clause { $$ = volatile_clause_e; }
;
@@ -3356,15 +3356,15 @@ picture_clause: PIC signed nps[fore] NINES nps[aft]
if( !field_type_update(field, FldNumericDisplay) ) {
YYERROR;
}
- ERROR_IF_CAPACITY(field);
+ ERROR_IF_CAPACITY(field);
field->attr |= $signed;
field->data.capacity = type_capacity(field->type, $4);
field->data.digits = $4;
- if( long(field->data.digits) != $4 ) {
- yyerrorv("error: indicated size would be %ld bytes, "
- "maximum data item size is %u",
- $4, UINT32_MAX);
- }
+ if( long(field->data.digits) != $4 ) {
+ yyerrorv("error: indicated size would be %ld bytes, "
+ "maximum data item size is %u",
+ $4, UINT32_MAX);
+ }
if( $fore && $aft ) { // leading and trailing P's
yyerror("PIC cannot have both leading and trailing P");
@@ -3374,34 +3374,34 @@ picture_clause: PIC signed nps[fore] NINES nps[aft]
field->attr |= scaled_e;
field->data.rdigits = $fore? $fore : -$aft;
}
- if( ! field->reasonable_capacity() ) {
- yyerrorv("error: %s limited to capacity of %d",
- field->name, MAX_FIXED_POINT_DIGITS);
- }
+ if( ! field->reasonable_capacity() ) {
+ yyerrorv("error: %s limited to capacity of %d",
+ field->name, MAX_FIXED_POINT_DIGITS);
+ }
}
| PIC signed NINEV[left] nine[rdigits]
{
cbl_field_t *field = current_field();
- field->data.digits = $left + $rdigits;
+ field->data.digits = $left + $rdigits;
- if( field->is_binary_integer() ) {
- field->data.capacity = type_capacity(field->type,
- field->data.digits);
- } else {
+ if( field->is_binary_integer() ) {
+ field->data.capacity = type_capacity(field->type,
+ field->data.digits);
+ } else {
if( !field_type_update(field, FldNumericDisplay) ) {
YYERROR;
}
- ERROR_IF_CAPACITY(field);
+ ERROR_IF_CAPACITY(field);
field->attr |= $signed;
- field->data.capacity = field->data.digits;
+ field->data.capacity = field->data.digits;
field->data.rdigits = $rdigits;
}
- if( ! field->reasonable_capacity() ) {
- yyerrorv("error: %s limited to capacity of %d",
- field->name, MAX_FIXED_POINT_DIGITS);
- }
- }
+ if( ! field->reasonable_capacity() ) {
+ yyerrorv("error: %s limited to capacity of %d",
+ field->name, MAX_FIXED_POINT_DIGITS);
+ }
+ }
| PIC signed NINEDOT[left] nine[rdigits]
{
uint32_t size = $left + $rdigits;
@@ -3410,16 +3410,16 @@ picture_clause: PIC signed nps[fore] NINES nps[aft]
if( !field_type_update(field, FldNumericEdited) ) {
YYERROR;
}
- ERROR_IF_CAPACITY(field);
+ ERROR_IF_CAPACITY(field);
field->attr |= $signed;
field->data.digits = size;
field->data.capacity = ++size;
field->data.rdigits = $rdigits;
- if( ! field->reasonable_capacity() ) {
- yyerrorv("error: %s limited to capacity of %d",
- field->name, MAX_FIXED_POINT_DIGITS);
- }
+ if( ! field->reasonable_capacity() ) {
+ yyerrorv("error: %s limited to capacity of %d",
+ field->name, MAX_FIXED_POINT_DIGITS);
+ }
}
| PIC alphanum_pic[size]
@@ -3428,16 +3428,16 @@ picture_clause: PIC signed nps[fore] NINES nps[aft]
if( !field_type_update(field, FldAlphanumeric) ) {
YYERROR;
}
- assert(0 < $size);
- if( field->data.initial != NULL ) {
- if( 0 < field->data.capacity &&
- field->data.capacity < uint32_t($size) ) {
- auto p = blank_pad_initial( field->data.initial,
- field->data.capacity, $size );
+ assert(0 < $size);
+ if( field->data.initial != NULL ) {
+ if( 0 < field->data.capacity &&
+ field->data.capacity < uint32_t($size) ) {
+ auto p = blank_pad_initial( field->data.initial,
+ field->data.capacity, $size );
if( !p ) YYERROR;
- field->data.initial = p;
- }
- }
+ field->data.initial = p;
+ }
+ }
field->data.capacity = field->data.digits = $size;
field->data.picture = NULL;
@@ -3452,7 +3452,7 @@ picture_clause: PIC signed nps[fore] NINES nps[aft]
if( !field_type_update(field, FldNumericEdited) ) {
YYERROR;
}
- ERROR_IF_CAPACITY(field);
+ ERROR_IF_CAPACITY(field);
if( !is_numeric_edited($picture) ) {
yyerror(numed_message);
YYERROR;
@@ -3469,7 +3469,7 @@ picture_clause: PIC signed nps[fore] NINES nps[aft]
bool is_alpha_edited( const char picture[] );
cbl_field_t *field = current_field();
- ERROR_IF_CAPACITY(field);
+ ERROR_IF_CAPACITY(field);
field->data.capacity = length_of_picture($picture);
field->data.picture = $picture;
@@ -3480,21 +3480,21 @@ picture_clause: PIC signed nps[fore] NINES nps[aft]
YYERROR;
}
- switch( type ) {
- case FldNumericEdited:
- field->data.digits = digits_of_picture($picture, false);
- field->data.rdigits = rdigits_of_picture($picture);
- if( is_picture_scaled($picture) ) field->attr |= scaled_e;
- break;
- case FldAlphaEdited:
- if( !is_alpha_edited(field->data.picture) ) {
- yyerror("invalid picture for Alphanumeric-edited");
- YYERROR;
- }
- break;
- default:
- assert(false);
- }
+ switch( type ) {
+ case FldNumericEdited:
+ field->data.digits = digits_of_picture($picture, false);
+ field->data.rdigits = rdigits_of_picture($picture);
+ if( is_picture_scaled($picture) ) field->attr |= scaled_e;
+ break;
+ case FldAlphaEdited:
+ if( !is_alpha_edited(field->data.picture) ) {
+ yyerror("invalid picture for Alphanumeric-edited");
+ YYERROR;
+ }
+ break;
+ default:
+ assert(false);
+ }
}
;
@@ -3505,7 +3505,7 @@ alphanum_pic: alphanum_part {
| alphanum_pic alphanum_part
{
if( $2.attr != all_alpha_e ) {
- current_field()->attr &= ~size_t(all_alpha_e);
+ current_field()->attr &= ~size_t(all_alpha_e);
}
$$ += $2.nbyte;
}
@@ -3536,7 +3536,7 @@ nine: %empty { $$ = 0; }
count: %empty { $$ = 0; }
| '(' NUMSTR ')'
{
- $$ = numstr2i( $NUMSTR.string, $NUMSTR.radix );
+ $$ = numstr2i( $NUMSTR.string, $NUMSTR.radix );
}
;
@@ -3556,139 +3556,139 @@ usage_clause: usage_clause1[type]
;
usage_clause1: usage COMPUTATIONAL[comp] native
{
- bool infer = true;
- cbl_field_t *field = current_field();
-
- // 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( field->type == FldNumericDisplay ) {
- infer = false;
- // PICTURE before USAGE
- assert(field->data.capacity > 0);
- assert(field->data.capacity == field->data.digits);
- field->type = $comp.type;
- field->data.capacity = type_capacity(field->type,
- field->data.digits);
- }
- break;
+ bool infer = true;
+ cbl_field_t *field = current_field();
+
+ // 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( field->type == FldNumericDisplay ) {
+ infer = false;
+ // PICTURE before USAGE
+ assert(field->data.capacity > 0);
+ assert(field->data.capacity == field->data.digits);
+ 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 ) {
- yyerrorv("%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;
+ break;
+ }
+
+ if( infer ) {
+ if( $comp.capacity > 0 ) {
+ if( field->data.capacity > 0 ) {
+ yyerrorv("%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 DISPLAY native { $$ = FldDisplay; }
| usage PACKED_DECIMAL native { $$ = FldPacked; }
| usage INDEX {
$$ = symbol_field_index_set( current_field() )->type;
- }
- // We should enforce data/code pointers with a different type.
+ }
+ // We should enforce data/code pointers with a different type.
| usage POINTER
- {
- $$ = FldPointer;
- auto field = current_field();
- auto redefined = symbol_redefines(field);
-
- if( gcobol_feature_embiggen() && redefined &&
- is_numeric(redefined->type) && redefined->size() == 4) {
- // For now, we allow POINTER to expand a 32-bit item to 64 bits.
- field->data.capacity = sizeof(void *);
- if( yydebug ) {
- warnx("%s: expanding #%zu %s capacity %u => %u", __func__,
- field_index(redefined), redefined->name,
- redefined->data.capacity, field->data.capacity);
- }
-
- redefined->embiggen();
-
- if( redefined->data.initial ) {
- char *s = new char[1 + redefined->data.capacity];
- if( !s ) {
- yyerrorv("error: could not expand initial value of %s", field->name);
- YYERROR;
- }
- (void)! snprintf(s, 1 + redefined->data.capacity,
- "%s ", redefined->data.initial);
- std::replace(s, s + strlen(s), '!', char(0x20));
- redefined->data.initial = s;
- }
- }
- }
+ {
+ $$ = FldPointer;
+ auto field = current_field();
+ auto redefined = symbol_redefines(field);
+
+ if( gcobol_feature_embiggen() && redefined &&
+ is_numeric(redefined->type) && redefined->size() == 4) {
+ // For now, we allow POINTER to expand a 32-bit item to 64 bits.
+ field->data.capacity = sizeof(void *);
+ if( yydebug ) {
+ warnx("%s: expanding #%zu %s capacity %u => %u", __func__,
+ field_index(redefined), redefined->name,
+ redefined->data.capacity, field->data.capacity);
+ }
+
+ redefined->embiggen();
+
+ if( redefined->data.initial ) {
+ char *s = new char[1 + redefined->data.capacity];
+ if( !s ) {
+ yyerrorv("error: could not expand initial value of %s", field->name);
+ YYERROR;
+ }
+ (void)! snprintf(s, 1 + redefined->data.capacity,
+ "%s ", redefined->data.initial);
+ std::replace(s, s + strlen(s), '!', char(0x20));
+ redefined->data.initial = s;
+ }
+ }
+ }
| usage POINTER TO error
- {
- yyerror("error: unimplemented: TYPEDEF");
- $$ = FldPointer;
- }
+ {
+ yyerror("error: unimplemented: TYPEDEF");
+ $$ = FldPointer;
+ }
;
value_clause: VALUE all LITERAL[lit] {
cbl_field_t *field = current_field();
- field->data.initial = $lit.data;
- field->attr |= literal_attr($lit.prefix);
- // The __gg__initialize_data routine needs to know that VALUE is a
- // quoted literal. This is critical for NumericEdited variables
- field->attr |= quoted_e;
-
- if( field->data.capacity == 0 ) {
- field->data.capacity = $lit.len;
- } else {
+ field->data.initial = $lit.data;
+ field->attr |= literal_attr($lit.prefix);
+ // The __gg__initialize_data routine needs to know that VALUE is a
+ // quoted literal. This is critical for NumericEdited variables
+ field->attr |= quoted_e;
+
+ if( field->data.capacity == 0 ) {
+ field->data.capacity = $lit.len;
+ } else {
if( $all ) {
if( ! field_value_all(field) ) {
yyerrorv("error: could not allocate field %s", field->name);
YYERROR;
- }
+ }
} else {
- if( $lit.len < field->data.capacity ) {
- auto p = blank_pad_initial( $lit.data, $lit.len,
- field->data.capacity );
+ if( $lit.len < field->data.capacity ) {
+ auto p = blank_pad_initial( $lit.data, $lit.len,
+ field->data.capacity );
if( !p ) YYERROR;
- field->data.initial = p;
- }
- }
- }
- value_encoding_check(field);
+ field->data.initial = p;
+ }
+ }
+ }
+ value_encoding_check(field);
}
| VALUE all cce_expr[value] {
cbl_field_t *field = current_field();
- auto orig_str = original_number();
- auto orig_val = numstr2i(orig_str, decimal_e);
- char *initial = NULL;
-
- if( orig_val == $value ) {
- initial = orig_str;
- pristine_values.insert(initial);
- } else {
- initial = string_of($value);
- if( !initial ) {
- yyerrorv("error: could not allocate field %s", field->name);
+ auto orig_str = original_number();
+ auto orig_val = numstr2i(orig_str, decimal_e);
+ char *initial = NULL;
+
+ if( orig_val == $value ) {
+ initial = orig_str;
+ pristine_values.insert(initial);
+ } else {
+ initial = string_of($value);
+ if( !initial ) {
+ yyerrorv("error: could not allocate field %s", field->name);
YYERROR;
}
- }
+ }
- char decimal = symbol_decimal_point();
- std::replace(initial, initial + strlen(initial), '.', decimal);
+ char decimal = symbol_decimal_point();
+ std::replace(initial, initial + strlen(initial), '.', decimal);
field->data.initial = initial;
- field->data.value = $value;
+ field->data.value = $value;
if( $all && ! field_value_all(field) ) {
yyerrorv("error: could not allocate ALL field %s", field->name);
@@ -3696,21 +3696,21 @@ value_clause: VALUE all LITERAL[lit] {
}
}
| VALUE all reserved_value[value]
- {
+ {
if( $value != NULLS ) {
- auto fig = constant_of(constant_index($value));
- current_field()->data.initial = fig->data.initial;
- }
- }
- | /* VALUE is */ NULLPTR
- {
- auto fig = constant_of(constant_index(NULLS));
- current_field()->data.initial = fig->data.initial;
- }
- | VALUE error
- {
- yyerror("error: no valid VALUE supplied");
- }
+ auto fig = constant_of(constant_index($value));
+ current_field()->data.initial = fig->data.initial;
+ }
+ }
+ | /* VALUE is */ NULLPTR
+ {
+ auto fig = constant_of(constant_index(NULLS));
+ current_field()->data.initial = fig->data.initial;
+ }
+ | VALUE error
+ {
+ yyerror("error: no valid VALUE supplied");
+ }
;
global_clause: is GLOBAL
@@ -3740,59 +3740,59 @@ redefines_clause: REDEFINES NAME[orig]
yyerror("syntax error: REDEFINES target not defined");
YYERROR;
}
- cbl_field_t *field = current_field();
- cbl_field_t *orig = cbl_field_of(e);
- cbl_field_t *super = symbol_redefines(orig);
- if( super ) {
- yyerrorv("syntax error: %s may not REDEFINE %s, "
- "which redefines %s",
- field->name, orig->name, super->name);
- }
- if( field->level != orig->level ) {
- yyerrorv("error: cannot redefine %02u %s as %02u %s "
- "because they have different levels",
- orig->level, name_of(orig),
- field->level, name_of(field));
- }
-
- if( valid_redefine(field, orig) ) {
+ cbl_field_t *field = current_field();
+ cbl_field_t *orig = cbl_field_of(e);
+ cbl_field_t *super = symbol_redefines(orig);
+ if( super ) {
+ yyerrorv("syntax error: %s may not REDEFINE %s, "
+ "which redefines %s",
+ field->name, orig->name, super->name);
+ }
+ if( field->level != orig->level ) {
+ yyerrorv("error: cannot redefine %02u %s as %02u %s "
+ "because they have different levels",
+ orig->level, name_of(orig),
+ field->level, name_of(field));
+ }
+
+ if( valid_redefine(field, orig) ) {
/*
* Defer "inheriting" the parent's description until the
* redefine is complete.
*/
current_field()->parent = symbol_index(e);
- }
+ }
}
;
-any_length: ANY LENGTH
+any_length: ANY LENGTH
{ cbl_field_t *field = current_field();
- if( field->attr & any_length_e ) {
- yyerror("ANY LENGTH already set");
- }
- if( ! (field->level == 1 &&
- current_data_section == linkage_datasect_e &&
- 1 < current.program_level()) ) {
- yyerror("ANY LENGTH valid only "
- "for 01 in LINKAGE SECTION of a contained program");
- YYERROR;
- }
+ if( field->attr & any_length_e ) {
+ yyerror("ANY LENGTH already set");
+ }
+ if( ! (field->level == 1 &&
+ current_data_section == linkage_datasect_e &&
+ 1 < current.program_level()) ) {
+ yyerror("ANY LENGTH valid only "
+ "for 01 in LINKAGE SECTION of a contained program");
+ YYERROR;
+ }
field->attr |= any_length_e;
}
- ;
+ ;
-based_clause: BASED
+based_clause: BASED
{ cbl_field_t *field = current_field();
- if( field->attr & based_e ) {
- yyerror("BASED already set");
- }
+ if( field->attr & based_e ) {
+ yyerror("BASED already set");
+ }
field->attr |= based_e;
}
- ;
+ ;
blank_zero_clause: blank_when_zero
{ cbl_field_t *field = current_field();
- // the BLANK WHEN ZERO clause defines the item as numeric-edited.
+ // the BLANK WHEN ZERO clause defines the item as numeric-edited.
if( !field_type_update(field, FldNumericEdited) ) {
YYERROR;
}
@@ -3809,44 +3809,44 @@ synched_clause: SYNCHRONIZED
| SYNCHRONIZED RIGHT
;
-same_clause: SAME AS name
- {
+same_clause: SAME AS name
+ {
cbl_field_t *field = current_field(), *other = $name;
- if( other->occurs.ntimes() > 0 ) {
- yyerrorv("error: SAME AS %s: cannot have OCCURRS",
- other->name); // 13.18.49.2,P5
- YYERROR;
- }
- if( field->level == 77 and !is_elementary(other->type) ) {
- yyerrorv("error: %02u %s SAME AS %s: must be elementary",
- field->level, field->name, other->name); // 13.18.49.2,P8
- YYERROR;
- }
-
- if( (other->attr & (sign_clause_e | usage_clause_e)) > 0 ) {
+ if( other->occurs.ntimes() > 0 ) {
+ yyerrorv("error: SAME AS %s: cannot have OCCURRS",
+ other->name); // 13.18.49.2,P5
+ YYERROR;
+ }
+ if( field->level == 77 and !is_elementary(other->type) ) {
+ yyerrorv("error: %02u %s SAME AS %s: must be elementary",
+ field->level, field->name, other->name); // 13.18.49.2,P8
+ YYERROR;
+ }
+
+ if( (other->attr & (sign_clause_e | usage_clause_e)) > 0 ) {
yyerrorv("error: %s: source of SAME AS cannot have "
- "SIGN or USAGE clause", other->name);
- YYERROR;
- }
- if( other->usage == FldGroup ) {
+ "SIGN or USAGE clause", other->name);
+ YYERROR;
+ }
+ if( other->usage == FldGroup ) {
yyerrorv("error: %s: source of SAME AS cannot have "
- "GROUP-USAGE clause", other->name);
- YYERROR;
- }
- if( other->has_attr(constant_e ) ) {
+ "GROUP-USAGE clause", other->name);
+ YYERROR;
+ }
+ if( other->has_attr(constant_e ) ) {
yyerrorv("error: %s: source of SAME AS cannot "
- "be constant", other->name);
- YYERROR;
- }
- if( field->parent == field_index(other) ) {
+ "be constant", other->name);
+ YYERROR;
+ }
+ if( field->parent == field_index(other) ) {
yyerrorv("error: %s: SAME AS uses "
- "its own parent %s", field->name, other->name);
- YYERROR;
- }
+ "its own parent %s", field->name, other->name);
+ YYERROR;
+ }
- symbol_field_same_as( field, other );
- }
- ;
+ symbol_field_same_as( field, other );
+ }
+ ;
sign_clause: sign_is sign_leading sign_separate
{
@@ -3854,7 +3854,7 @@ sign_clause: sign_is sign_leading sign_separate
if( $sign_leading ) {
field->attr |= leading_e;
} else {
- field->attr &= ~size_t(leading_e); // turn off in case inherited
+ field->attr &= ~size_t(leading_e); // turn off in case inherited
field->attr |= signable_e;
}
if( $sign_separate ) field->attr |= separate_e;
@@ -3889,62 +3889,62 @@ sign_separate: %empty { $$ = false; }
* — USAGE clause
*/
type_clause: TYPE to typename
- {
+ {
cbl_field_t *field = current_field();
- if( $typename ) {
- symbol_field_same_as(field, $typename);
- }
- }
- | USAGE is typename
- {
- if( ! dialect_mf() ) {
- yyerror("error: USAGE TYPENAME requires -dialect mf");
- YYERROR;
- }
+ if( $typename ) {
+ symbol_field_same_as(field, $typename);
+ }
+ }
+ | USAGE is typename
+ {
+ if( ! dialect_mf() ) {
+ yyerror("error: USAGE TYPENAME requires -dialect mf");
+ YYERROR;
+ }
cbl_field_t *field = current_field();
- if( $typename ) {
- symbol_field_same_as(field, $typename);
- }
- }
- ;
+ if( $typename ) {
+ symbol_field_same_as(field, $typename);
+ }
+ }
+ ;
typedef_clause: is TYPEDEF strong
- {
+ {
cbl_field_t *field = current_field();
- switch( field->level ) {
- case 1: case 77: break;
- default:
- yyerrorv("error: %02d %s IS TYPEDEF must be level 01",
- field->level, field->name);
- }
- field->attr |= typedef_e;
- if( $strong ) field->attr |= strongdef_e;
- if( ! current.typedef_add(field) ) {
- auto prior = current.has_typedef(field);
- assert(prior);
- yyerrorv("error: %02d %s IS TYPEDEF is not unique "
- "(see %s, line %d)",
- field->level, field->name,
- prior->name, prior->line);
- }
- }
- ;
+ switch( field->level ) {
+ case 1: case 77: break;
+ default:
+ yyerrorv("error: %02d %s IS TYPEDEF must be level 01",
+ field->level, field->name);
+ }
+ field->attr |= typedef_e;
+ if( $strong ) field->attr |= strongdef_e;
+ if( ! current.typedef_add(field) ) {
+ auto prior = current.has_typedef(field);
+ assert(prior);
+ yyerrorv("error: %02d %s IS TYPEDEF is not unique "
+ "(see %s, line %d)",
+ field->level, field->name,
+ prior->name, prior->line);
+ }
+ }
+ ;
volatile_clause:
- VOLATILE
- {
- if( dialect_ibm() ) {
- yywarn("warning: VOLATILE has no effect");
- } else {
- yyerror("error: VOLATILE requires -dialect IBM");
- }
- }
- ;
+ VOLATILE
+ {
+ if( dialect_ibm() ) {
+ yywarn("warning: VOLATILE has no effect");
+ } else {
+ yyerror("error: VOLATILE requires -dialect IBM");
+ }
+ }
+ ;
procedure_div: %empty {
if( !procedure_division_ready(NULL, NULL) ) YYABORT;
}
- | PROCEDURE_DIV '.' {
+ | PROCEDURE_DIV '.' {
if( !procedure_division_ready(NULL, NULL) ) YYABORT;
} declaratives sentences
| PROCEDURE_DIV procedure_args '.' declaratives sentences
@@ -3958,16 +3958,16 @@ procedure_args: USING procedure_uses[args]
| USING procedure_uses[args] RETURNING name[ret]
{
if( !procedure_division_ready($ret, $args) ) YYABORT;
- if( ! $ret->has_attr(linkage_e) ) {
- yyerrorv("error: RETURNING %s is not defined in LINKAGE SECTION", $ret->name);
- }
+ if( ! $ret->has_attr(linkage_e) ) {
+ yyerrorv("error: RETURNING %s is not defined in LINKAGE SECTION", $ret->name);
+ }
}
| RETURNING name[ret]
{
if( !procedure_division_ready($ret, NULL) ) YYABORT;
- if( ! $ret->has_attr(linkage_e) ) {
- yyerrorv("error: RETURNING %s is not defined in LINKAGE SECTION", $ret->name);
- }
+ if( ! $ret->has_attr(linkage_e) ) {
+ yyerrorv("error: RETURNING %s is not defined in LINKAGE SECTION", $ret->name);
+ }
}
;
procedure_uses: procedure_use { $$ = new ffi_args_t($1); }
@@ -3975,90 +3975,90 @@ procedure_uses: procedure_use { $$ = new ffi_args_t($1); }
;
procedure_use: optional scalar {
$$ = new cbl_ffi_arg_t(by_default_e, $scalar);
- $$->optional = $optional;
- $$->validate(); // produces message
+ $$->optional = $optional;
+ $$->validate(); // produces message
}
| by REFERENCE optional scalar {
$$ = new cbl_ffi_arg_t(by_reference_e, $scalar);
- $$->optional = $optional;
- $$->validate(); // produces message
+ $$->optional = $optional;
+ $$->validate(); // produces message
}
- | by CONTENT error { // no "by content" in procedure definition
- $$ = new cbl_ffi_arg_t(by_content_e,
- new_reference(literally_zero));
+ | by CONTENT error { // no "by content" in procedure definition
+ $$ = new cbl_ffi_arg_t(by_content_e,
+ new_reference(literally_zero));
}
| by VALUE by_value_arg[arg] {
$$ = new cbl_ffi_arg_t(by_value_e, $arg);
- $$->validate(); // produces message
+ $$->validate(); // produces message
}
- ;
-by_value_arg: scalar
- | LITERAL { $$ = new_reference(new_literal($1, quoted_e)); }
- | reserved_value
+ ;
+by_value_arg: scalar
+ | LITERAL { $$ = new_reference(new_literal($1, quoted_e)); }
+ | reserved_value
{
$$ = new_reference(constant_of(constant_index($1)));
}
- ;
+ ;
declaratives: %empty { $$ = NULL; }
| DECLARATIVES '.'
- <label>{
- current.enabled_exception_cache = enabled_exceptions;
- enabled_exceptions.clear();
+ <label>{
+ current.enabled_exception_cache = enabled_exceptions;
+ enabled_exceptions.clear();
current.new_section("DECLARATIVES");
- $$ = label_add(LblString, "_end_declaratives", 0);
+ $$ = label_add(LblString, "_end_declaratives", 0);
assert($$);
parser_label_goto($$);
} [label]
sentences END DECLARATIVES '.'
{
- size_t ndecl = current.declaratives.as_list().size();
- cbl_declarative_t decls[ ndecl ];
- auto decl_list = current.declaratives.as_list();
- std::copy( decl_list.begin(), decl_list.end(), decls );
- std::sort( decls, decls + ndecl );
+ size_t ndecl = current.declaratives.as_list().size();
+ cbl_declarative_t decls[ ndecl ];
+ auto decl_list = current.declaratives.as_list();
+ std::copy( decl_list.begin(), decl_list.end(), decls );
+ std::sort( decls, decls + ndecl );
// turn off current::in_declaratives
current.new_section("END DECLARATIVES");
- /* TODO: if( intradeclarative_reference() ) yyerror;
- * Test also at paragraph_reference, for non-forward
- * reference with good line numbers. See
- * utilcc::procedures_t and ambiguous_reference(). At this
- * point, no reference should pick up anything except a
- * forward reference, because we haven't yet begun to parse
- * nondeclarative procedures.
- */
+ /* TODO: if( intradeclarative_reference() ) yyerror;
+ * Test also at paragraph_reference, for non-forward
+ * reference with good line numbers. See
+ * utilcc::procedures_t and ambiguous_reference(). At this
+ * point, no reference should pick up anything except a
+ * forward reference, because we haven't yet begun to parse
+ * nondeclarative procedures.
+ */
parser_label_label($label);
- enabled_exceptions = current.enabled_exception_cache;
- current.enabled_exception_cache.clear();
+ enabled_exceptions = current.enabled_exception_cache;
+ current.enabled_exception_cache.clear();
} section {
- $$ = $section;
- }
+ $$ = $section;
+ }
;
sentences: sentence {
- if( $1 != PARAGRAPH )
- symbol_temporaries_free();
- }
+ if( $1 != PARAGRAPH )
+ symbol_temporaries_free();
+ }
| sentences sentence {
- if( false && $2 != PARAGRAPH )
- symbol_temporaries_free();
- }
+ if( false && !getenv("STATIC") && $2 != PARAGRAPH )
+ symbol_temporaries_free();
+ }
;
sentence: statements '.'
| statements YYEOF
- {
- if( ! goodnight_gracie() ) {
- YYABORT;
- }
+ {
+ if( ! goodnight_gracie() ) {
+ YYABORT;
+ }
if( nparse_error > 0 ) YYABORT;
- YYACCEPT;
- }
+ YYACCEPT;
+ }
| program END_SUBPROGRAM namestr[name] '.'
{
const cbl_label_t *prog = current.program();
assert(prog);
- const char *name = string_of($name);
+ const char *name = string_of($name);
if( !name || 0 != strcasecmp(prog->name, name) ) {
yyerrorv( "END PROGRAM '%s' does not match PROGRAM-ID '%s'",
name? name : $name.data, prog->name);
@@ -4068,23 +4068,23 @@ sentence: statements '.'
current.end_section();
std::set<std::string> externals = current.end_program();
if( !externals.empty() ) {
- for( const auto& name : externals ) {
- warnx("%s calls external symbol '%s'",
- prog->name, name.c_str());
- }
+ for( const auto& name : externals ) {
+ warnx("%s calls external symbol '%s'",
+ prog->name, name.c_str());
+ }
YYERROR;
}
// pointer still valid because name is in symbol table
ast_end_program(prog->name);
}
- | program YYEOF
- {
- if( nparse_error > 0 ) YYABORT;
- do {
- if( ! close_out_program(NULL) ) YYABORT; // no recovery
- } while( current.program_level() > 0 );
- YYACCEPT;
- }
+ | program YYEOF
+ {
+ if( nparse_error > 0 ) YYABORT;
+ do {
+ if( ! close_out_program(NULL) ) YYABORT; // no recovery
+ } while( current.program_level() > 0 );
+ YYACCEPT;
+ }
;
statements: statement
@@ -4092,67 +4092,67 @@ statements: statement
;
statement: error {
- if( current.declarative_section_name() ) {
- yyerror("error: missing END DECLARATIVES or SECTION name", nparse_error);
- YYABORT;
- }
- if( max_errors_exceeded(nparse_error) ) {
- yyerrorv("max errors %d reached", nparse_error);
- YYABORT;
- }
- }
- | cdf { $$ = CDF_IF; }
- | accept { $$ = ACCEPT; }
- | add { $$ = ADD; }
- | allocate { $$ = ALLOCATE; }
- | alter { $$ = ALTER; }
- | call { $$ = CALL; }
- | cancel { $$ = CANCEL; }
- | close { $$ = CLOSE; }
- | compute { $$ = COMPUTE; }
- | CONTINUE { $$ = CONTINUE; }
- | delete { $$ = DELETE; }
- | display { $$ = DISPLAY; }
- | divide { $$ = DIVIDE; }
- | entry { $$ = ENTRY; }
- | evaluate { $$ = EVALUATE; }
- | exit { $$ = EXIT; }
- | free { $$ = FREE; }
- | go_to { $$ = GOTO; }
- | if_stmt { $$ = IF; }
- | initialize { $$ = INITIALIZE; }
- | inspect { $$ = INSPECT; }
- | merge { $$ = MERGE; }
- | move { $$ = MOVE; }
- | multiply { $$ = MULTIPLY; }
- | open { $$ = OPEN; }
- | return_stmt { $$ = RETURN; }
- | paragraph { $$ = PARAGRAPH; }
- | perform { $$ = PERFORM; }
- | raise { $$ = RAISE; }
- | read { $$ = READ; }
- | release { $$ = RELEASE; }
- | resume { $$ = RESUME; }
- | rewrite { $$ = REWRITE; }
- | search { $$ = SEARCH; }
- | section { $$ = SECTION; }
- | set { $$ = SET; }
- | sort { $$ = SORT; }
- | start { $$ = START; }
- | stop { $$ = STOP; }
- | string { $$ = STRING_kw; }
- | subtract { $$ = SUBTRACT; }
- | unstring { $$ = UNSTRING; }
- | write { $$ = WRITE; }
- ;
-
-accept: accept_body end_accept
- ;
-end_accept: %empty
- | END_ACCEPT
- ;
-
-accept_body: accept_refer
+ if( current.declarative_section_name() ) {
+ yyerror("error: missing END DECLARATIVES or SECTION name", nparse_error);
+ YYABORT;
+ }
+ if( max_errors_exceeded(nparse_error) ) {
+ yyerrorv("max errors %d reached", nparse_error);
+ YYABORT;
+ }
+ }
+ | cdf { $$ = CDF_IF; }
+ | accept { $$ = ACCEPT; }
+ | add { $$ = ADD; }
+ | allocate { $$ = ALLOCATE; }
+ | alter { $$ = ALTER; }
+ | call { $$ = CALL; }
+ | cancel { $$ = CANCEL; }
+ | close { $$ = CLOSE; }
+ | compute { $$ = COMPUTE; }
+ | CONTINUE { $$ = CONTINUE; }
+ | delete { $$ = DELETE; }
+ | display { $$ = DISPLAY; }
+ | divide { $$ = DIVIDE; }
+ | entry { $$ = ENTRY; }
+ | evaluate { $$ = EVALUATE; }
+ | exit { $$ = EXIT; }
+ | free { $$ = FREE; }
+ | go_to { $$ = GOTO; }
+ | if_stmt { $$ = IF; }
+ | initialize { $$ = INITIALIZE; }
+ | inspect { $$ = INSPECT; }
+ | merge { $$ = MERGE; }
+ | move { $$ = MOVE; }
+ | multiply { $$ = MULTIPLY; }
+ | open { $$ = OPEN; }
+ | return_stmt { $$ = RETURN; }
+ | paragraph { $$ = PARAGRAPH; }
+ | perform { $$ = PERFORM; }
+ | raise { $$ = RAISE; }
+ | read { $$ = READ; }
+ | release { $$ = RELEASE; }
+ | resume { $$ = RESUME; }
+ | rewrite { $$ = REWRITE; }
+ | search { $$ = SEARCH; }
+ | section { $$ = SECTION; }
+ | set { $$ = SET; }
+ | sort { $$ = SORT; }
+ | start { $$ = START; }
+ | stop { $$ = STOP; }
+ | string { $$ = STRING_kw; }
+ | subtract { $$ = SUBTRACT; }
+ | unstring { $$ = UNSTRING; }
+ | write { $$ = WRITE; }
+ ;
+
+accept: accept_body end_accept
+ ;
+end_accept: %empty
+ | END_ACCEPT
+ ;
+
+accept_body: accept_refer
{
parser_accept(*$1, CONSOLE_e);
}
@@ -4320,21 +4320,21 @@ add_body: sum TO rnames
rounded: %empty { $$ = truncation_e; }
| ROUNDED { $$ = current_rounded_mode(); }
- | ROUNDED rounded_mode { $$ = rounded_of($rounded_mode); }
- ;
-rounded_mode: MODE is rounded_type { $$ = $rounded_type; }
- ;
-rounded_type: AWAY_FROM_ZERO { $$ = AWAY_FROM_ZERO; }
- | NEAREST_TOWARD_ZERO { $$ = NEAREST_TOWARD_ZERO; }
- | TOWARD_GREATER { $$ = TOWARD_GREATER; }
- | TOWARD_LESSER { $$ = TOWARD_LESSER; }
- | round_between
- ;
-round_between: NEAREST_AWAY_FROM_ZERO { $$ = NEAREST_AWAY_FROM_ZERO; }
- | NEAREST_EVEN { $$ = NEAREST_EVEN; }
- | PROHIBITED { $$ = PROHIBITED; }
- | TRUNCATION { $$ = TRUNCATION; }
- ;
+ | ROUNDED rounded_mode { $$ = rounded_of($rounded_mode); }
+ ;
+rounded_mode: MODE is rounded_type { $$ = $rounded_type; }
+ ;
+rounded_type: AWAY_FROM_ZERO { $$ = AWAY_FROM_ZERO; }
+ | NEAREST_TOWARD_ZERO { $$ = NEAREST_TOWARD_ZERO; }
+ | TOWARD_GREATER { $$ = TOWARD_GREATER; }
+ | TOWARD_LESSER { $$ = TOWARD_LESSER; }
+ | round_between
+ ;
+round_between: NEAREST_AWAY_FROM_ZERO { $$ = NEAREST_AWAY_FROM_ZERO; }
+ | NEAREST_EVEN { $$ = NEAREST_EVEN; }
+ | PROHIBITED { $$ = PROHIBITED; }
+ | TRUNCATION { $$ = TRUNCATION; }
+ ;
might_be: %empty { $$ = IS; }
| MIGHT_BE
@@ -4381,9 +4381,9 @@ name88: NAME88 subscripts[subs] refmod[ref]
cbl_field_t *name = cbl_field_of(symbol_find($1));
$$ = new cbl_refer_t(name);
- if( $subs->refers.size() != $$->subscripts_set($subs->refers) ) {
- subscript_dimension_error($subs->refers.size(), $$);
- }
+ if( $subs->refers.size() != $$->subscripts_set($subs->refers) ) {
+ subscript_dimension_error($subs->refers.size(), $$);
+ }
}
| NAME88 inof name subscripts[subs]
{
@@ -4393,9 +4393,9 @@ name88: NAME88 subscripts[subs] refmod[ref]
YYERROR;
}
$$ = new cbl_refer_t(name);
- if( $subs->refers.size() != $$->subscripts_set($subs->refers) ) {
- subscript_dimension_error($subs->refers.size(), $$);
- }
+ if( $subs->refers.size() != $$->subscripts_set($subs->refers) ) {
+ subscript_dimension_error($subs->refers.size(), $$);
+ }
}
| NAME88 inof name
{
@@ -4417,63 +4417,63 @@ name88: NAME88 subscripts[subs] refmod[ref]
}
;
-allocate: ALLOCATE cce_expr[size] CHARACTERS initialized RETURNING name
- {
- statement_begin(@1, ALLOCATE);
- if( $size == 0 ) {
- yyerror("error: size cannot be zero");
- YYERROR;
- }
- parser_allocate( $size, $name, $initialized );
- }
- | ALLOCATE name initialized alloc_ret[ret]
- {
- statement_begin(@1, ALLOCATE);
- parser_allocate( 0, $ret? $ret : $name, $initialized );
- }
- ;
-initialized: %empty { $$ = false; }
- | INITIALIZED { $$ = true; }
- ;
-alloc_ret: %empty { $$ = NULL; }
- | RETURNING name { $$ = $name; }
- ;
+allocate: ALLOCATE cce_expr[size] CHARACTERS initialized RETURNING name
+ {
+ statement_begin(@1, ALLOCATE);
+ if( $size == 0 ) {
+ yyerror("error: size cannot be zero");
+ YYERROR;
+ }
+ parser_allocate( $size, $name, $initialized );
+ }
+ | ALLOCATE name initialized alloc_ret[ret]
+ {
+ statement_begin(@1, ALLOCATE);
+ parser_allocate( 0, $ret? $ret : $name, $initialized );
+ }
+ ;
+initialized: %empty { $$ = false; }
+ | INITIALIZED { $$ = true; }
+ ;
+alloc_ret: %empty { $$ = NULL; }
+ | RETURNING name { $$ = $name; }
+ ;
compute: compute_impl end_compute { current.compute_end(); }
- | compute_cond end_compute { current.compute_end(); }
- ;
-compute_impl: COMPUTE compute_body[body]
- {
- parser_assign( $body.ntgt, $body.tgts, *$body.expr,
- NULL, NULL, current.compute_label() );
- current.declaratives_evaluate(ec_none_e);
- }
- ;
-compute_cond: COMPUTE compute_body[body] arith_errs[err]
- {
- parser_assign( $body.ntgt, $body.tgts, *$body.expr,
- $err.on_error, $err.not_error,
- current.compute_label() );
- current.declaratives_evaluate(ec_size_e);
- }
- ;
+ | compute_cond end_compute { current.compute_end(); }
+ ;
+compute_impl: COMPUTE compute_body[body]
+ {
+ parser_assign( $body.ntgt, $body.tgts, *$body.expr,
+ NULL, NULL, current.compute_label() );
+ current.declaratives_evaluate(ec_none_e);
+ }
+ ;
+compute_cond: COMPUTE compute_body[body] arith_errs[err]
+ {
+ parser_assign( $body.ntgt, $body.tgts, *$body.expr,
+ $err.on_error, $err.not_error,
+ current.compute_label() );
+ current.declaratives_evaluate(ec_size_e);
+ }
+ ;
end_compute: %empty %prec COMPUTE
| END_COMPUTE
;
-compute_body: rnames { statement_begin(@$, COMPUTE); } compute_expr[expr] {
- $$.ntgt = rhs.size();
- auto C = new cbl_num_result_t[$$.ntgt];
- $$.tgts = use_any(rhs, C);
- $$.expr = $expr;
- }
+compute_body: rnames { statement_begin(@$, COMPUTE); } compute_expr[expr] {
+ $$.ntgt = rhs.size();
+ auto C = new cbl_num_result_t[$$.ntgt];
+ $$.tgts = use_any(rhs, C);
+ $$.expr = $expr;
+ }
+ ;
+compute_expr: '=' {
+ current.compute_begin();
+ } expr {
+ $$ = $expr;
+ }
;
-compute_expr: '=' {
- current.compute_begin();
- } expr {
- $$ = $expr;
- }
- ;
display: disp_body end_display
{
@@ -4482,7 +4482,7 @@ display: disp_body end_display
parser_display($1.special, use_vargs($1.vargs, args), len,
DISPLAY_ADVANCE);
- current.declaratives_evaluate(ec_none_e);
+ current.declaratives_evaluate(ec_none_e);
}
| disp_body NO ADVANCING end_display
{
@@ -4491,12 +4491,12 @@ display: disp_body end_display
parser_display($1.special, use_vargs($1.vargs, args), len,
DISPLAY_NO_ADVANCE);
- current.declaratives_evaluate(ec_none_e);
+ current.declaratives_evaluate(ec_none_e);
}
;
-end_display: %empty
- | END_DISPLAY
- ;
+end_display: %empty
+ | END_DISPLAY
+ ;
disp_body: disp_vargs[vargs]
{
$$.special = NULL;
@@ -4508,11 +4508,11 @@ disp_body: disp_vargs[vargs]
$$.vargs = $vargs;
}
;
-disp_vargs: DISPLAY vargs {
- statement_begin(@1, DISPLAY);
- $$ = $vargs;
- }
- ;
+disp_vargs: DISPLAY vargs {
+ statement_begin(@1, DISPLAY);
+ $$ = $vargs;
+ }
+ ;
disp_target: env_name1 {
$$ = symbol_special($1.id);
@@ -4607,22 +4607,22 @@ end_program: end_program1[end] '.'
{
const cbl_label_t *prog = current.program();
assert(prog);
- const char *name = string_of($end.name);
-
- bool matches = false;
- const char *token_name = keyword_str($end.token) + 4;
- switch($end.token) {
- case END_PROGRAM:
- matches = prog->type == LblProgram;
- break;
- case END_FUNCTION:
- matches = prog->type == LblFunction;
- break;
- default:
+ const char *name = string_of($end.name);
+
+ bool matches = false;
+ const char *token_name = keyword_str($end.token) + 4;
+ switch($end.token) {
+ case END_PROGRAM:
+ matches = prog->type == LblProgram;
+ break;
+ case END_FUNCTION:
+ matches = prog->type == LblFunction;
+ break;
+ default:
yyerrorv( "logic error: END token invalid '%s'", name);
- assert(false);
- }
- if( !matches ) {
+ assert(false);
+ }
+ if( !matches ) {
yyerrorv( "END %s %s' does not match IDENTIFICATION DIVISION '%s'",
token_name, name, prog->name);
YYERROR;
@@ -4646,17 +4646,17 @@ end_program: end_program1[end] '.'
ast_end_program(prog->name);
}
;
-end_program1: END_PROGRAM namestr[name]
- {
- $$.token = END_PROGRAM;
- $$.name = $name;
- }
- | END_FUNCTION namestr[name]
- {
- $$.token = END_FUNCTION;
- $$.name = $name;
- }
- ;
+end_program1: END_PROGRAM namestr[name]
+ {
+ $$.token = END_PROGRAM;
+ $$.name = $name;
+ }
+ | END_FUNCTION namestr[name]
+ {
+ $$.token = END_FUNCTION;
+ $$.name = $name;
+ }
+ ;
exit: EXIT PROGRAM_kw
{
@@ -4680,32 +4680,32 @@ exit_proc: PARAGRAPH { parser_exit_paragraph(); }
}
parser_exit_perform(&perform_current()->tgt, $1);
}
- | error
- {
- yyerror( "warning: invalid simple EXIT, assuming SECTION" );
- nparse_error -= 2; // for actual error + "warning"
- parser_exit_section();
- }
- ;
-
-free: FREE free_tgts
- {
- size_t n = $free_tgts->size();
- assert( n > 0 );
- auto tgts = new cbl_refer_t[n];
- parser_free( n, $free_tgts->use_list(tgts) );
- }
- ;
-free_tgts: free_tgt { $$ = new refer_list_t($1); }
- | free_tgts free_tgt { $$->push_back($2); }
- ;
-free_tgt: name { $$ = new_reference($1); }
- | ADDRESS OF name
- {
- $$ = new_reference($name);
- $$->addr_of = true;
- }
- ;
+ | error
+ {
+ yyerror( "warning: invalid simple EXIT, assuming SECTION" );
+ nparse_error -= 2; // for actual error + "warning"
+ parser_exit_section();
+ }
+ ;
+
+free: FREE free_tgts
+ {
+ size_t n = $free_tgts->size();
+ assert( n > 0 );
+ auto tgts = new cbl_refer_t[n];
+ parser_free( n, $free_tgts->use_list(tgts) );
+ }
+ ;
+free_tgts: free_tgt { $$ = new refer_list_t($1); }
+ | free_tgts free_tgt { $$->push_back($2); }
+ ;
+free_tgt: name { $$ = new_reference($1); }
+ | ADDRESS OF name
+ {
+ $$ = new_reference($name);
+ $$->addr_of = true;
+ }
+ ;
/*
* Conditional Expressions
@@ -4739,22 +4739,22 @@ simple_cond: kind_of_name
parser_setop($$->cond(), $1->field, is_op, cbl_field_of(e));
parser_logop($$->cond(), NULL, not_op, $$->cond());
}
- | expr is OMITTED
- {
- auto lhs = cbl_refer_t($expr->field);
- lhs.addr_of = true;
- auto rhs = cbl_field_of(symbol_field(0,0, "NULLS"));
- $$ = new_reference(new_temporary(FldConditional));
- parser_relop($$->field, lhs, eq_op, rhs);
- }
- | expr NOT OMITTED
- {
- auto lhs = cbl_refer_t($expr->field);
- lhs.addr_of = true;
- auto rhs = cbl_field_of(symbol_field(0,0, "NULLS"));
- $$ = new_reference(new_temporary(FldConditional));
- parser_relop($$->field, lhs, ne_op, rhs);
- }
+ | expr is OMITTED
+ {
+ auto lhs = cbl_refer_t($expr->field);
+ lhs.addr_of = true;
+ auto rhs = cbl_field_of(symbol_field(0,0, "NULLS"));
+ $$ = new_reference(new_temporary(FldConditional));
+ parser_relop($$->field, lhs, eq_op, rhs);
+ }
+ | expr NOT OMITTED
+ {
+ auto lhs = cbl_refer_t($expr->field);
+ lhs.addr_of = true;
+ auto rhs = cbl_field_of(symbol_field(0,0, "NULLS"));
+ $$ = new_reference(new_temporary(FldConditional));
+ parser_relop($$->field, lhs, ne_op, rhs);
+ }
| expr posneg[op] {
$$ = new_reference(new_temporary(FldConditional));
relop_t op = static_cast<relop_t>($op);
@@ -4778,7 +4778,7 @@ simple_cond: kind_of_name
}
}
$$ = new_reference(new_temporary(FldConditional));
- $$->field->parent = field_index($name88->field);
+ $$->field->parent = field_index($name88->field);
parser_relop($$->cond(), parent, eq_op, *$name88);
}
| rel_operand
@@ -4799,261 +4799,261 @@ kind_of_name: expr might_be variable_type
bool_expr: bool_expr[lhs] OR and_term[rhs]
{
- // cond cond: reduce
- // cond value: reduce
- // value value: error
- // value cond: error
-
- if( !is_conditional($rhs.cond)) {
- if( is_conditional($lhs.cond) && !$lhs.ante.term ) {
- yyerrorv( "error: %s OR %s invalid because "
- "LHS is not a relation condition",
- $lhs.cond->field->name,
- $rhs.cond->field->name );
- YYERROR;
- }
- if( !is_conditional($lhs.cond) ) {
- yyerrorv( "error: '%s' OR '%s' invalid because "
- "'%s' is not a condition",
- name_of($lhs.cond->field),
- name_of($rhs.cond->field),
- name_of($lhs.cond->field) );
- YYERROR;
- }
- } else {
- if( !is_conditional($lhs.cond) ) {
- yyerrorv( "logic error: %s OR %s invalid because "
- "LHS is not a condition and RHS is",
- $lhs.cond->field->name,
- $rhs.cond->field->name );
- YYERROR;
- }
- }
- assert( ! (!is_conditional($lhs.cond) &&
- is_conditional($rhs.cond)) );
-
- if( yydebug ) {
- YYSTYPE::relop_term_t terms[2] = { $lhs, $rhs };
- for( int i=0; i < 2; i++ ) {
- for( const auto& abbr : *terms[i].abbrs ) {
- warnx("\tacrc: (%s) %s: %c%s %s",
- i==0? "lhs" : "rhs",
- terms[i].cond->name(),
- abbr.invert? '!' : ' ',
- relop_str(abbr.op), abbr.term->name());
- }
- }
- }
-
- $$ = $lhs;
- $rhs.ante = acrc_t::make($rhs.cond, relop_t(-1), $rhs.ante.invert);
- auto rhs = apply_acrcs($$.cond, $$.ante, *$$.abbrs, or_op, $rhs.ante);
- if( rhs ) {
- parser_logop($$.cond->cond(),
- $$.cond->cond(), or_op, rhs->term->cond());
- }
- }
+ // cond cond: reduce
+ // cond value: reduce
+ // value value: error
+ // value cond: error
+
+ if( !is_conditional($rhs.cond)) {
+ if( is_conditional($lhs.cond) && !$lhs.ante.term ) {
+ yyerrorv( "error: %s OR %s invalid because "
+ "LHS is not a relation condition",
+ $lhs.cond->field->name,
+ $rhs.cond->field->name );
+ YYERROR;
+ }
+ if( !is_conditional($lhs.cond) ) {
+ yyerrorv( "error: '%s' OR '%s' invalid because "
+ "'%s' is not a condition",
+ name_of($lhs.cond->field),
+ name_of($rhs.cond->field),
+ name_of($lhs.cond->field) );
+ YYERROR;
+ }
+ } else {
+ if( !is_conditional($lhs.cond) ) {
+ yyerrorv( "logic error: %s OR %s invalid because "
+ "LHS is not a condition and RHS is",
+ $lhs.cond->field->name,
+ $rhs.cond->field->name );
+ YYERROR;
+ }
+ }
+ assert( ! (!is_conditional($lhs.cond) &&
+ is_conditional($rhs.cond)) );
+
+ if( yydebug ) {
+ YYSTYPE::relop_term_t terms[2] = { $lhs, $rhs };
+ for( int i=0; i < 2; i++ ) {
+ for( const auto& abbr : *terms[i].abbrs ) {
+ warnx("\tacrc: (%s) %s: %c%s %s",
+ i==0? "lhs" : "rhs",
+ terms[i].cond->name(),
+ abbr.invert? '!' : ' ',
+ relop_str(abbr.op), abbr.term->name());
+ }
+ }
+ }
+
+ $$ = $lhs;
+ $rhs.ante = acrc_t::make($rhs.cond, relop_t(-1), $rhs.ante.invert);
+ auto rhs = apply_acrcs($$.cond, $$.ante, *$$.abbrs, or_op, $rhs.ante);
+ if( rhs ) {
+ parser_logop($$.cond->cond(),
+ $$.cond->cond(), or_op, rhs->term->cond());
+ }
+ }
| bool_expr[lhs] OR MIGHT_BE and_term[rhs]
{
assert(NOT == $MIGHT_BE);
- if( is_conditional($lhs.cond) && !$lhs.ante.term ) {
- yyerrorv( "error: %s OR NOT %s invalid because "
- "LHS is not a relation condition",
- $lhs.cond->field->name,
- $rhs.cond->field->name );
- YYERROR;
- }
- if( is_conditional($rhs.cond) ) {
- yyerrorv( "error: %s OR NOT %s invalid because RHS is not a value",
- $lhs.cond->field->name,
- $rhs.cond->field->name );
- YYERROR;
- }
-
- $$ = $lhs;
- $rhs.ante.invert = !$rhs.ante.invert;
- $rhs.ante.term = $rhs.cond;
- auto rhs = apply_acrcs($$.cond, $$.ante, *$$.abbrs, or_op, $rhs.ante);
- if( rhs ) {
- parser_logop(rhs->term->cond(),
- NULL, not_op, rhs->term->cond());
- parser_logop($$.cond->cond(),
- $$.cond->cond(), or_op, rhs->term->cond());
- }
+ if( is_conditional($lhs.cond) && !$lhs.ante.term ) {
+ yyerrorv( "error: %s OR NOT %s invalid because "
+ "LHS is not a relation condition",
+ $lhs.cond->field->name,
+ $rhs.cond->field->name );
+ YYERROR;
+ }
+ if( is_conditional($rhs.cond) ) {
+ yyerrorv( "error: %s OR NOT %s invalid because RHS is not a value",
+ $lhs.cond->field->name,
+ $rhs.cond->field->name );
+ YYERROR;
+ }
+
+ $$ = $lhs;
+ $rhs.ante.invert = !$rhs.ante.invert;
+ $rhs.ante.term = $rhs.cond;
+ auto rhs = apply_acrcs($$.cond, $$.ante, *$$.abbrs, or_op, $rhs.ante);
+ if( rhs ) {
+ parser_logop(rhs->term->cond(),
+ NULL, not_op, rhs->term->cond());
+ parser_logop($$.cond->cond(),
+ $$.cond->cond(), or_op, rhs->term->cond());
+ }
}
| bool_expr[lhs] OR relop and_term[rhs]
{
- if( is_conditional($lhs.cond) && !$lhs.ante.term ) {
- yyerrorv( "error: %s OR %s %s invalid because "
- "LHS is not a relation condition",
- $lhs.cond->field->name, keyword_str($relop),
- $rhs.cond->field->name );
- YYERROR;
- }
- if( is_conditional($rhs.cond) ) {
- yyerrorv( "error: %s OR %s %s invalid because RHS is not a value",
- $lhs.cond->field->name, keyword_str($relop),
- $rhs.cond->field->name );
- YYERROR;
- }
-
- $$ = $lhs;
- $rhs.ante = acrc_t::make($rhs.cond, relop_of($relop), $rhs.ante.invert);
- auto rhs = apply_acrcs($$.cond, $$.ante, *$$.abbrs, or_op, $rhs.ante);
- if( rhs ) {
- parser_logop($$.cond->cond(),
- $$.cond->cond(), or_op, rhs->term->cond());
- }
+ if( is_conditional($lhs.cond) && !$lhs.ante.term ) {
+ yyerrorv( "error: %s OR %s %s invalid because "
+ "LHS is not a relation condition",
+ $lhs.cond->field->name, keyword_str($relop),
+ $rhs.cond->field->name );
+ YYERROR;
+ }
+ if( is_conditional($rhs.cond) ) {
+ yyerrorv( "error: %s OR %s %s invalid because RHS is not a value",
+ $lhs.cond->field->name, keyword_str($relop),
+ $rhs.cond->field->name );
+ YYERROR;
+ }
+
+ $$ = $lhs;
+ $rhs.ante = acrc_t::make($rhs.cond, relop_of($relop), $rhs.ante.invert);
+ auto rhs = apply_acrcs($$.cond, $$.ante, *$$.abbrs, or_op, $rhs.ante);
+ if( rhs ) {
+ parser_logop($$.cond->cond(),
+ $$.cond->cond(), or_op, rhs->term->cond());
+ }
}
| and_term { $$ = $1; }
;
and_term: and_term[lhs] AND rel_expr[rhs]
{
- // cond cond: reduce
- // cond value: reduce
- // value value: defer
- // value cond: error
-
- if( !is_conditional($rhs.cond)) {
- if( is_conditional($lhs.cond) && !$lhs.ante.term ) {
- yyerrorv( "error: %s AND %s invalid because "
- "LHS is not a relation condition",
- $lhs.cond->field->name,
- $rhs.cond->field->name );
- YYERROR;
- }
- }
-
- $$ = $lhs;
-
- $rhs.ante = acrc_t::make($rhs.cond, relop_t(-1), $rhs.ante.invert);
- auto rhs = apply_acrcs($$.cond, $$.ante, *$$.abbrs, and_op, $rhs.ante);
- if( rhs ) {
- parser_logop($$.cond->cond(),
- $$.cond->cond(), and_op, rhs->term->cond());
- }
+ // cond cond: reduce
+ // cond value: reduce
+ // value value: defer
+ // value cond: error
+
+ if( !is_conditional($rhs.cond)) {
+ if( is_conditional($lhs.cond) && !$lhs.ante.term ) {
+ yyerrorv( "error: %s AND %s invalid because "
+ "LHS is not a relation condition",
+ $lhs.cond->field->name,
+ $rhs.cond->field->name );
+ YYERROR;
+ }
+ }
+
+ $$ = $lhs;
+
+ $rhs.ante = acrc_t::make($rhs.cond, relop_t(-1), $rhs.ante.invert);
+ auto rhs = apply_acrcs($$.cond, $$.ante, *$$.abbrs, and_op, $rhs.ante);
+ if( rhs ) {
+ parser_logop($$.cond->cond(),
+ $$.cond->cond(), and_op, rhs->term->cond());
+ }
}
| and_term[lhs] AND NOT rel_expr[rhs] {
- // cond NOT cond: reduce
- // cond NOT value: reduce if LHS is relation condition
- // value NOT value: defer
- // value NOT cond: defer
-
- if( !is_conditional($rhs.cond)) {
- if( is_conditional($lhs.cond) && !$lhs.ante.term ) {
- yyerrorv( "error: %s AND NOT %s invalid because "
- "LHS is not a relation condition",
- $lhs.cond->field->name,
- $rhs.cond->field->name );
- YYERROR;
- }
- }
-
- $$ = $lhs;
- if( $rhs.ante.is_relation_condition() ) $$.ante = $rhs.ante;
-
- $rhs.ante.invert = !$rhs.ante.invert;
- $rhs.ante.term = $rhs.cond;
- auto rhs = apply_acrcs($$.cond, $$.ante, *$$.abbrs, and_op, $rhs.ante);
- if( rhs ) {
- parser_logop(rhs->term->cond(),
- NULL, not_op, rhs->term->cond());
- parser_logop($$.cond->cond(),
- $$.cond->cond(), and_op, rhs->term->cond());
- }
- if( yydebug && ! $$.abbrs->empty() ) {
- warnx("%s AND NOT %s, %zu acrc left",
- $$.cond->name(), $rhs.ante.term->name(), $$.abbrs->size() );
- }
+ // cond NOT cond: reduce
+ // cond NOT value: reduce if LHS is relation condition
+ // value NOT value: defer
+ // value NOT cond: defer
+
+ if( !is_conditional($rhs.cond)) {
+ if( is_conditional($lhs.cond) && !$lhs.ante.term ) {
+ yyerrorv( "error: %s AND NOT %s invalid because "
+ "LHS is not a relation condition",
+ $lhs.cond->field->name,
+ $rhs.cond->field->name );
+ YYERROR;
+ }
+ }
+
+ $$ = $lhs;
+ if( $rhs.ante.is_relation_condition() ) $$.ante = $rhs.ante;
+
+ $rhs.ante.invert = !$rhs.ante.invert;
+ $rhs.ante.term = $rhs.cond;
+ auto rhs = apply_acrcs($$.cond, $$.ante, *$$.abbrs, and_op, $rhs.ante);
+ if( rhs ) {
+ parser_logop(rhs->term->cond(),
+ NULL, not_op, rhs->term->cond());
+ parser_logop($$.cond->cond(),
+ $$.cond->cond(), and_op, rhs->term->cond());
+ }
+ if( yydebug && ! $$.abbrs->empty() ) {
+ warnx("%s AND NOT %s, %zu acrc left",
+ $$.cond->name(), $rhs.ante.term->name(), $$.abbrs->size() );
+ }
}
| and_term[lhs] AND MIGHT_BE rel_expr[rhs]
{
- // cond NOT cond: reduce
- // cond NOT value: reduce if LHS is relation condition
- // value NOT value: defer
- // value NOT cond: defer
+ // cond NOT cond: reduce
+ // cond NOT value: reduce if LHS is relation condition
+ // value NOT value: defer
+ // value NOT cond: defer
assert(NOT == $MIGHT_BE);
- if( !is_conditional($rhs.cond)) {
- if( is_conditional($lhs.cond) && !$lhs.ante.term ) {
- yyerrorv( "error: %s AND NOT %s invalid because "
- "LHS is not a relation condition",
- $lhs.cond->field->name,
- $rhs.cond->field->name );
- YYERROR;
- }
- }
-
- $$ = $lhs;
-
- $rhs.ante.invert = !$rhs.ante.invert;
- $rhs.ante.term = $rhs.cond;
- auto rhs = apply_acrcs($$.cond, $$.ante, *$$.abbrs, and_op, $rhs.ante);
- if( rhs ) {
- parser_logop(rhs->term->cond(),
- NULL, not_op, rhs->term->cond());
- parser_logop($$.cond->cond(),
- $$.cond->cond(), and_op, rhs->term->cond());
- }
+ if( !is_conditional($rhs.cond)) {
+ if( is_conditional($lhs.cond) && !$lhs.ante.term ) {
+ yyerrorv( "error: %s AND NOT %s invalid because "
+ "LHS is not a relation condition",
+ $lhs.cond->field->name,
+ $rhs.cond->field->name );
+ YYERROR;
+ }
+ }
+
+ $$ = $lhs;
+
+ $rhs.ante.invert = !$rhs.ante.invert;
+ $rhs.ante.term = $rhs.cond;
+ auto rhs = apply_acrcs($$.cond, $$.ante, *$$.abbrs, and_op, $rhs.ante);
+ if( rhs ) {
+ parser_logop(rhs->term->cond(),
+ NULL, not_op, rhs->term->cond());
+ parser_logop($$.cond->cond(),
+ $$.cond->cond(), and_op, rhs->term->cond());
+ }
}
| and_term[lhs] AND relop rel_expr[rhs]
{
- if( is_conditional($lhs.cond) && !$lhs.ante.term ) {
- yyerrorv( "error: %s AND %s %s invalid because "
- "LHS is not a relation condition",
- $lhs.cond->field->name, keyword_str($relop),
- $rhs.cond->field->name );
- YYERROR;
- }
- if( is_conditional($rhs.cond) ) {
- yyerrorv( "error: %s AND %s %s invalid because RHS is not a value",
- $lhs.cond->field->name, keyword_str($relop),
- $rhs.cond->field->name );
- YYERROR;
- }
- assert( !is_conditional($rhs.cond) );
-
- $$ = $lhs;
-
- $rhs.ante = acrc_t::make($rhs.cond, relop_of($relop), $rhs.ante.invert);
- auto rhs = apply_acrcs($$.cond, $$.ante, *$$.abbrs, and_op, $rhs.ante);
- if( rhs ) {
- parser_logop($$.cond->cond(),
- $$.cond->cond(), and_op, rhs->term->cond());
- }
- }
- | rel_expr
- {
- $$.cond = $rel_expr.cond;
- $$.ante = $rel_expr.ante;
- $$.abbrs = new acrcs_t;
- }
+ if( is_conditional($lhs.cond) && !$lhs.ante.term ) {
+ yyerrorv( "error: %s AND %s %s invalid because "
+ "LHS is not a relation condition",
+ $lhs.cond->field->name, keyword_str($relop),
+ $rhs.cond->field->name );
+ YYERROR;
+ }
+ if( is_conditional($rhs.cond) ) {
+ yyerrorv( "error: %s AND %s %s invalid because RHS is not a value",
+ $lhs.cond->field->name, keyword_str($relop),
+ $rhs.cond->field->name );
+ YYERROR;
+ }
+ assert( !is_conditional($rhs.cond) );
+
+ $$ = $lhs;
+
+ $rhs.ante = acrc_t::make($rhs.cond, relop_of($relop), $rhs.ante.invert);
+ auto rhs = apply_acrcs($$.cond, $$.ante, *$$.abbrs, and_op, $rhs.ante);
+ if( rhs ) {
+ parser_logop($$.cond->cond(),
+ $$.cond->cond(), and_op, rhs->term->cond());
+ }
+ }
+ | rel_expr
+ {
+ $$.cond = $rel_expr.cond;
+ $$.ante = $rel_expr.ante;
+ $$.abbrs = new acrcs_t;
+ }
| NOT rel_expr
- {
- $$.cond = $rel_expr.cond;
- $$.ante = $rel_expr.ante;
- $$.abbrs = new acrcs_t;
- cbl_refer_t *term($$.cond);
- if( is_conditional(term) ) {
- parser_logop( term->cond(), NULL, not_op, term->cond() );
- } else {
- $$.ante.invert = true;
- }
- }
- ;
+ {
+ $$.cond = $rel_expr.cond;
+ $$.ante = $rel_expr.ante;
+ $$.abbrs = new acrcs_t;
+ cbl_refer_t *term($$.cond);
+ if( is_conditional(term) ) {
+ parser_logop( term->cond(), NULL, not_op, term->cond() );
+ } else {
+ $$.ante.invert = true;
+ }
+ }
+ ;
rel_expr: rel_operand[lhs] relop rel_operand[rhs]
{
- $$.ante = acrc_t::make($lhs, relop_of($relop));
- $$.cond = new_reference(new_temporary(FldConditional));
- parser_relop($$.cond->cond(), *$lhs, relop_of($relop), *$rhs);
+ $$.ante = acrc_t::make($lhs, relop_of($relop));
+ $$.cond = new_reference(new_temporary(FldConditional));
+ parser_relop($$.cond->cond(), *$lhs, relop_of($relop), *$rhs);
}
| simple_cond
- {
- $$.ante = {};
- $$.cond = $1;
- }
+ {
+ $$.ante = {};
+ $$.cond = $1;
+ }
;
rel_operand: all LITERAL
@@ -5072,16 +5072,16 @@ rel_operand: all LITERAL
$$->all = $all;
}
| ALL ZERO
- { // ZERO without ALL comes from expr, from num_term.
+ { // ZERO without ALL comes from expr, from num_term.
$$ = new_reference(constant_of(constant_index(ZERO)));
$$->all = true;
}
- | expr
+ | expr
;
-expr: expr_term
- ;
-expr_term: expr_term '+' num_term
+expr: expr_term
+ ;
+expr_term: expr_term '+' num_term
{
if( ($$ = ast_op($1, '+', $3)) == NULL ) YYERROR;
}
@@ -5107,7 +5107,7 @@ value: value POW factor
{
if( ($$ = ast_op($1, '^', $3)) == NULL ) YYERROR;
}
- | '-' value %prec NEG { $$ = negate( $2 );}
+ | '-' value %prec NEG { $$ = negate( $2 );}
| factor[rhs]
;
@@ -5127,11 +5127,11 @@ if_verb: IF { statement_begin(@1, IF); }
;
if_test: bool_expr then
{
- if( ! is_conditional($bool_expr.cond) ) {
- yyerrorv("syntax error: %s is not a Boolean expression",
- name_of($bool_expr.cond->field) );
- YYERROR;
- }
+ if( ! is_conditional($bool_expr.cond) ) {
+ yyerrorv("syntax error: %s is not a Boolean expression",
+ name_of($bool_expr.cond->field) );
+ YYERROR;
+ }
parser_if( $bool_expr.cond->cond() );
}
;
@@ -5205,10 +5205,10 @@ eval_case: eval_whens statements %prec ADD
;
eval_whens: eval_whens1 {
- auto f = evaluate_when();
- if( !f ) YYERROR;
- parser_if(f);
- }
+ auto f = evaluate_when();
+ if( !f ) YYERROR;
+ parser_if(f);
+ }
;
eval_whens1: eval_when
| eval_whens1 eval_when
@@ -5268,74 +5268,74 @@ eval_object1: ANY
parser_relop($$.field, src, eq_op, src);
$$.field->attr |= otherhow_e;
}
- ;
+ ;
-eval_thru: bool_expr
- {
- $$.tf = true;
- $$.field = $1.cond->field;
+eval_thru: bool_expr
+ {
+ $$.tf = true;
+ $$.field = $1.cond->field;
if( $1.cond->is_reference() ) {
yyerror("error: subscripts are unsupported here");
YYERROR;
}
- }
- | relop bool_expr[expr]
- {
- $$.tf = true;
- auto relop = relop_of($relop);
+ }
+ | relop bool_expr[expr]
+ {
+ $$.tf = true;
+ auto relop = relop_of($relop);
if( $expr.cond->is_reference() ) {
yyerror("error: subscripts are unsupported here");
YYERROR;
}
- if( is_conditional($expr.cond) ) {
- yyerrorv("error: %s %s is invalid",
- relop_str(relop), $expr.cond->name());
+ if( is_conditional($expr.cond) ) {
+ yyerrorv("error: %s %s is invalid",
+ relop_str(relop), $expr.cond->name());
YYERROR;
- }
- $$.field = new_temporary(FldConditional);
+ }
+ $$.field = new_temporary(FldConditional);
parser_relop( $$.field, evaluate_subject(), relop, *$expr.cond );
- }
- | MIGHT_BE bool_expr[a] THRU bool_expr[b] %prec THRU
+ }
+ | MIGHT_BE bool_expr[a] THRU bool_expr[b] %prec THRU
{
- if( is_conditional($a.cond) || is_conditional($b.cond) ) {
- yyerror("error: THRU with boolean operand");
- YYERROR;
- }
+ if( is_conditional($a.cond) || is_conditional($b.cond) ) {
+ yyerror("error: THRU with boolean operand");
+ YYERROR;
+ }
cbl_field_t * gte = new_temporary(FldConditional);
parser_relop( gte, *$a.cond, le_op, evaluate_subject() );
cbl_field_t * lte = new_temporary(FldConditional);
parser_relop( lte, evaluate_subject(), le_op, *$b.cond );
- $$.tf = $MIGHT_BE == IS;
+ $$.tf = $MIGHT_BE == IS;
$$.field = new_temporary(FldConditional);
$$.field->attr |= thru_fact_e;
parser_logop($$.field, gte, and_op, lte);
}
- | bool_expr[a] THRU bool_expr[b] %prec THRU
+ | bool_expr[a] THRU bool_expr[b] %prec THRU
{
- if( is_conditional($a.cond) || is_conditional($b.cond) ) {
- yyerror("syntax error: THRU with boolean operand");
- YYERROR;
- }
+ if( is_conditional($a.cond) || is_conditional($b.cond) ) {
+ yyerror("syntax error: THRU with boolean operand");
+ YYERROR;
+ }
cbl_field_t * gte = new_temporary(FldConditional);
parser_relop( gte, *$a.cond, le_op, evaluate_subject() );
cbl_field_t * lte = new_temporary(FldConditional);
parser_relop( lte, evaluate_subject(), le_op, *$b.cond );
- $$.tf = true;
+ $$.tf = true;
$$.field = new_temporary(FldConditional);
$$.field->attr |= thru_fact_e;
parser_logop($$.field, gte, and_op, lte);
}
- | bool_expr[a] ELSE
- {
- yyerror("ELSE not valid in WHEN");
- YYERROR;
- }
- ;
+ | bool_expr[a] ELSE
+ {
+ yyerror("ELSE not valid in WHEN");
+ YYERROR;
+ }
+ ;
end_evaluate: %empty %prec EVALUATE
| END_EVALUATE
@@ -5347,30 +5347,30 @@ true_false: TRUE_kw { $$ = TRUE_kw; }
scalar: name subscripts[subs] refmod[ref] %prec NAME
{
- $$ = new cbl_refer_t($name);
- if( $subs->refers.size() != $$->subscripts_set($subs->refers) ) {
- subscript_dimension_error($subs->refers.size(), $$);
- }
+ $$ = new cbl_refer_t($name);
+ if( $subs->refers.size() != $$->subscripts_set($subs->refers) ) {
+ subscript_dimension_error($subs->refers.size(), $$);
+ }
- literal_subscripts_valid( *$$ );
+ literal_subscripts_valid( *$$ );
$$->refmod = cbl_span_t( $ref.from->field,
- $ref.len->field );
+ $ref.len->field );
}
| name refmod[ref] %prec NAME
{
- $$ = new cbl_refer_t($name);
+ $$ = new cbl_refer_t($name);
$$->refmod = cbl_span_t( $ref.from->field,
- $ref.len->field );
+ $ref.len->field );
}
| name subscripts[subs] %prec NAME
{
- bool ok = true;
- $$ = new cbl_refer_t($name);
- if( $subs->refers.size() != $$->subscripts_set($subs->refers) ) {
- ok = false;
- subscript_dimension_error($subs->refers.size(), $$);
- }
- if( ! (ok && literal_subscripts_valid(*$$)) ) YYERROR;
+ bool ok = true;
+ $$ = new cbl_refer_t($name);
+ if( $subs->refers.size() != $$->subscripts_set($subs->refers) ) {
+ ok = false;
+ subscript_dimension_error($subs->refers.size(), $$);
+ }
+ if( ! (ok && literal_subscripts_valid(*$$)) ) YYERROR;
}
| name { $$ = new cbl_refer_t($name); } %prec NAME
;
@@ -5385,18 +5385,18 @@ refmod: LPAREN expr[from] ':' expr[len] ')' %prec NAME
$$.from = $from;
$$.len = cbl_refer_t::empty();
}
- ;
+ ;
-typename: NAME
- {
- auto e = symbol_typedef(PROGRAM, $NAME);
- if( ! e ) {
- yyerrorv("error: symbol '%s' not found", $NAME );
- YYERROR;
- }
- $$ = cbl_field_of(e);
- }
- ;
+typename: NAME
+ {
+ auto e = symbol_typedef(PROGRAM, $NAME);
+ if( ! e ) {
+ yyerrorv("error: symbol '%s' not found", $NAME );
+ YYERROR;
+ }
+ $$ = cbl_field_of(e);
+ }
+ ;
name: qname
{
@@ -5421,7 +5421,7 @@ name: qname
auto name = names.front();
names.pop_front();
auto e = symbol_field_forward_add(PROGRAM, parent,
- name, yylineno);
+ name, yylineno);
if( !e ) YYERROR;
parent = symbol_index(e);
$$ = cbl_field_of(e);
@@ -5445,184 +5445,184 @@ inof: IN
| OF
;
-ctx_name: NAME
- | context_word
- ;
-
-context_word: APPLY { static char s[] ="APPLY";
- $$ = s; } // screen description entry
- | ARITHMETIC { static char s[] ="ARITHMETIC";
- $$ = s; } // OPTIONS paragraph
- | ATTRIBUTE { static char s[] ="ATTRIBUTE";
- $$ = s; } // SET statement
- | AUTO { static char s[] ="AUTO";
- $$ = s; } // screen description entry
- | AUTOMATIC { static char s[] ="AUTOMATIC";
- $$ = s; } // LOCK MODE clause
- | AWAY_FROM_ZERO { static char s[] ="AWAY-FROM-ZERO";
- $$ = s; } // ROUNDED phrase
- | BACKGROUND_COLOR { static char s[] ="BACKGROUND-COLOR";
- $$ = s; } // screen description entry
- | BELL { static char s[] ="BELL";
- $$ = s; } // screen description entry and SET attribute statement
- | BINARY_ENCODING { static char s[] ="BINARY-ENCODING";
- $$ = s; } // USAGE clause and FLOAT-DECIMAL clause
- | BLINK { static char s[] ="BLINK";
- $$ = s; } // screen description entry and SET attribute statement
- | BYTE_LENGTH { static char s[] ="BYTE-LENGTH";
- $$ = s; } // constant entry
- | CAPACITY { static char s[] ="CAPACITY";
- $$ = s; } // OCCURS clause
- | CENTER { static char s[] ="CENTER";
- $$ = s; } // COLUMN clause
- | CLASSIFICATION { static char s[] ="CLASSIFICATION";
- $$ = s; } // OBJECT-COMPUTER paragraph
- | CYCLE { static char s[] ="CYCLE";
- $$ = s; } // EXIT statement
- | DECIMAL_ENCODING { static char s[] ="DECIMAL-ENCODING";
- $$ = s; } // USAGE clause and FLOAT-DECIMAL clause
- | EOL { static char s[] ="EOL";
- $$ = s; } // ERASE clause in a screen description entry
- | EOS { static char s[] ="EOS";
- $$ = s; } // ERASE clause in a screen description entry
- | ENTRY_CONVENTION { static char s[] ="ENTRY-CONVENTION";
- $$ = s; } // OPTIONS paragraph
- | ERASE { static char s[] ="ERASE";
- $$ = s; } // screen description entry
- | EXPANDS { static char s[] ="EXPANDS";
- $$ = s; } // class-specifier and interface-specifier of the REPOSITORY paragraph
- | FEATURE { static char s[] ="FEATURE";
- $$ = s; } // gcobol CDF token
- | FLOAT_BINARY { static char s[] ="FLOAT-BINARY";
- $$ = s; } // OPTIONS paragraph
- | FLOAT_DECIMAL { static char s[] ="FLOAT-DECIMAL";
- $$ = s; } // OPTIONS paragraph
- | FOREGROUND_COLOR { static char s[] ="FOREGROUND-COLOR";
- $$ = s; } // screen description entry
- | FOREVER { static char s[] ="FOREVER";
- $$ = s; } // RETRY phrase
- | FULL { static char s[] ="FULL";
- $$ = s; } // screen description entry
- | HIGH_ORDER_LEFT { static char s[] ="HIGH-ORDER-LEFT";
- $$ = s; } // FLOAT-BINARY clause, FLOAT-DECIMAL clause, and USAGE clause
- | HIGH_ORDER_RIGHT { static char s[] ="HIGH-ORDER-RIGHT";
- $$ = s; } // FLOAT-BINARY clause, FLOAT-DECIMAL clause, and USAGE clause
- | HIGHLIGHT { static char s[] ="HIGHLIGHT";
- $$ = s; } // screen description entry and SET attribute statement
- | IGNORING { static char s[] ="IGNORING";
- $$ = s; } // READ statement
- | IMPLEMENTS { static char s[] ="IMPLEMENTS";
- $$ = s; } // FACTORY paragraph and OBJECT paragraph
- | INITIALIZED { static char s[] ="INITIALIZED";
- $$ = s; } // ALLOCATE statement and OCCURS clause
- | INTERMEDIATE { static char s[] ="INTERMEDIATE";
- $$ = s; } // OPTIONS paragraph
- | INTRINSIC { static char s[] ="INTRINSIC";
- $$ = s; } // function-specifier of the REPOSITORY paragraph
- | LC_ALL_kw { static char s[] ="LC_ALL";
- $$ = s; } // SET statement
- | LC_COLLATE_kw { static char s[] ="LC_COLLATE";
- $$ = s; } // SET statement
- | LC_CTYPE_kw { static char s[] ="LC_CTYPE";
- $$ = s; } // SET statement
- | LC_MESSAGES_kw { static char s[] ="LC_MESSAGES";
- $$ = s; } // SET statement
- | LC_MONETARY_kw { static char s[] ="LC_MONETARY";
- $$ = s; } // SET statement
- | LC_NUMERIC_kw { static char s[] ="LC_NUMERIC";
- $$ = s; } // SET statement
- | LC_TIME_kw { static char s[] ="LC_TIME";
- $$ = s; } // SET statement
- | LOWLIGHT { static char s[] ="LOWLIGHT";
- $$ = s; } // screen description entry and SET attribute statement
- | MANUAL { static char s[] ="MANUAL";
- $$ = s; } // LOCK MODE clause
- | MULTIPLE { static char s[] ="MULTIPLE";
- $$ = s; } // LOCK ON phrase
- | NEAREST_AWAY_FROM_ZERO { static char s[] ="NEAREST-AWAY-FROM-ZERO";
- $$ = s; } // INTERMEDIATE ROUNDING clause and ROUNDED phrase
- | NEAREST_EVEN { static char s[] ="NEAREST-EVEN";
- $$ = s; } // INTERMEDIATE ROUNDING clause and ROUNDED phrase
- | NEAREST_TOWARD_ZERO { static char s[] ="NEAREST-TOWARD-ZERO";
- $$ = s; } // INTERMEDIATE ROUNDING clause and ROUNDED phrase
- | NONE { static char s[] ="NONE";
- $$ = s; } // DEFAULT clause
- | NORMAL { static char s[] ="NORMAL";
- $$ = s; } // STOP statement
- | NUMBERS { static char s[] ="NUMBERS";
- $$ = s; } // COLUMN clause and LINE clause
- | ONLY { static char s[] ="ONLY";
- $$ = s; } // Object-view, SHARING clause, SHARING phrase, and USAGE clause
- /* | PARAGRAPH { static char s[] ="PARAGRAPH";
- $$ = s; } // EXIT statement */
- | PREFIXED { static char s[] ="PREFIXED";
- $$ = s; } // DYNAMIC LENGTH STRUCTURE clause
- | PREVIOUS { static char s[] ="PREVIOUS";
- $$ = s; } // READ statement
- | PROHIBITED { static char s[] ="PROHIBITED";
- $$ = s; } // INTERMEDIATE ROUNDING clause and ROUNDED phrase
- | RECURSIVE { static char s[] ="RECURSIVE";
- $$ = s; } // PROGRAM-ID paragraph
- | RELATION { static char s[] ="RELATION";
- $$ = s; } // VALIDATE-STATUS clause
- | REQUIRED { static char s[] ="REQUIRED";
- $$ = s; } // screen description entry
- | REVERSE_VIDEO { static char s[] ="REVERSE-VIDEO";
- $$ = s; } // screen description entry and SET attribute statement
- | ROUNDING { static char s[] ="ROUNDING";
- $$ = s; } // OPTIONS paragraph
- | SECONDS { static char s[] ="SECONDS";
- $$ = s; } // RETRY phrase
- | SECURE { static char s[] ="SECURE";
- $$ = s; } // screen description entry
- | SHORT { static char s[] ="SHORT";
- $$ = s; } // DYNAMIC LENGTH STRUCTURE clause
- | SIGNED { static char s[] ="SIGNED";
- $$ = s; } // DYNAMIC LENGTH STRUCTURE clause and USAGE clause
- | STANDARD_BINARY { static char s[] ="STANDARD-BINARY";
- $$ = s; } // ARITHMETIC clause
- | STANDARD_DECIMAL { static char s[] ="STANDARD-DECIMAL";
- $$ = s; } // ARITHMETIC clause
- | STATEMENT { static char s[] ="STATEMENT";
- $$ = s; } // RESUME statement
- | STEP { static char s[] ="STEP";
- $$ = s; } // OCCURS clause
- | STRONG { static char s[] ="STRONG";
- $$ = s; } // TYPEDEF clause
- | STRUCTURE { static char s[] ="STRUCTURE";
- $$ = s; } // DYNAMIC LENGTH STRUCTURE clause
- | SYMBOL { static char s[] ="SYMBOL";
- $$ = s; } // CURRENCY clause
- | TOWARD_GREATER { static char s[] ="TOWARD-GREATER";
- $$ = s; } // ROUNDED phrase
- | TOWARD_LESSER { static char s[] ="TOWARD-LESSER";
- $$ = s; } // ROUNDED phrase
- | TRUNCATION { static char s[] ="TRUNCATION";
- $$ = s; } // INTERMEDIATE ROUNDING clause and ROUNDED phrase
- | UCS_4 { static char s[] ="UCS-4";
- $$ = s; } // ALPHABET clause
- | UNDERLINE { static char s[] ="UNDERLINE";
- $$ = s; } // screen description entry and SET attribute statement
- | UNSIGNED { static char s[] ="UNSIGNED";
- $$ = s; } // USAGE clause
- | UTF_8 { static char s[] ="UTF-8";
- $$ = s; } // ALPHABET clause
- | UTF_16 { static char s[] ="UTF-16";
- $$ = s; } // ALPHABET clause
- | YYYYDDD { static char s[] ="YYYYDDD";
- $$ = s; } // ACCEPT statement
- | YYYYMMDD { static char s[] ="YYYYMMDD";
- $$ = s; } // ACCEPT statement
- ;
+ctx_name: NAME
+ | context_word
+ ;
+
+context_word: APPLY { static char s[] ="APPLY";
+ $$ = s; } // screen description entry
+ | ARITHMETIC { static char s[] ="ARITHMETIC";
+ $$ = s; } // OPTIONS paragraph
+ | ATTRIBUTE { static char s[] ="ATTRIBUTE";
+ $$ = s; } // SET statement
+ | AUTO { static char s[] ="AUTO";
+ $$ = s; } // screen description entry
+ | AUTOMATIC { static char s[] ="AUTOMATIC";
+ $$ = s; } // LOCK MODE clause
+ | AWAY_FROM_ZERO { static char s[] ="AWAY-FROM-ZERO";
+ $$ = s; } // ROUNDED phrase
+ | BACKGROUND_COLOR { static char s[] ="BACKGROUND-COLOR";
+ $$ = s; } // screen description entry
+ | BELL { static char s[] ="BELL";
+ $$ = s; } // screen description entry and SET attribute statement
+ | BINARY_ENCODING { static char s[] ="BINARY-ENCODING";
+ $$ = s; } // USAGE clause and FLOAT-DECIMAL clause
+ | BLINK { static char s[] ="BLINK";
+ $$ = s; } // screen description entry and SET attribute statement
+ | BYTE_LENGTH { static char s[] ="BYTE-LENGTH";
+ $$ = s; } // constant entry
+ | CAPACITY { static char s[] ="CAPACITY";
+ $$ = s; } // OCCURS clause
+ | CENTER { static char s[] ="CENTER";
+ $$ = s; } // COLUMN clause
+ | CLASSIFICATION { static char s[] ="CLASSIFICATION";
+ $$ = s; } // OBJECT-COMPUTER paragraph
+ | CYCLE { static char s[] ="CYCLE";
+ $$ = s; } // EXIT statement
+ | DECIMAL_ENCODING { static char s[] ="DECIMAL-ENCODING";
+ $$ = s; } // USAGE clause and FLOAT-DECIMAL clause
+ | EOL { static char s[] ="EOL";
+ $$ = s; } // ERASE clause in a screen description entry
+ | EOS { static char s[] ="EOS";
+ $$ = s; } // ERASE clause in a screen description entry
+ | ENTRY_CONVENTION { static char s[] ="ENTRY-CONVENTION";
+ $$ = s; } // OPTIONS paragraph
+ | ERASE { static char s[] ="ERASE";
+ $$ = s; } // screen description entry
+ | EXPANDS { static char s[] ="EXPANDS";
+ $$ = s; } // class-specifier and interface-specifier of the REPOSITORY paragraph
+ | FEATURE { static char s[] ="FEATURE";
+ $$ = s; } // gcobol CDF token
+ | FLOAT_BINARY { static char s[] ="FLOAT-BINARY";
+ $$ = s; } // OPTIONS paragraph
+ | FLOAT_DECIMAL { static char s[] ="FLOAT-DECIMAL";
+ $$ = s; } // OPTIONS paragraph
+ | FOREGROUND_COLOR { static char s[] ="FOREGROUND-COLOR";
+ $$ = s; } // screen description entry
+ | FOREVER { static char s[] ="FOREVER";
+ $$ = s; } // RETRY phrase
+ | FULL { static char s[] ="FULL";
+ $$ = s; } // screen description entry
+ | HIGH_ORDER_LEFT { static char s[] ="HIGH-ORDER-LEFT";
+ $$ = s; } // FLOAT-BINARY clause, FLOAT-DECIMAL clause, and USAGE clause
+ | HIGH_ORDER_RIGHT { static char s[] ="HIGH-ORDER-RIGHT";
+ $$ = s; } // FLOAT-BINARY clause, FLOAT-DECIMAL clause, and USAGE clause
+ | HIGHLIGHT { static char s[] ="HIGHLIGHT";
+ $$ = s; } // screen description entry and SET attribute statement
+ | IGNORING { static char s[] ="IGNORING";
+ $$ = s; } // READ statement
+ | IMPLEMENTS { static char s[] ="IMPLEMENTS";
+ $$ = s; } // FACTORY paragraph and OBJECT paragraph
+ | INITIALIZED { static char s[] ="INITIALIZED";
+ $$ = s; } // ALLOCATE statement and OCCURS clause
+ | INTERMEDIATE { static char s[] ="INTERMEDIATE";
+ $$ = s; } // OPTIONS paragraph
+ | INTRINSIC { static char s[] ="INTRINSIC";
+ $$ = s; } // function-specifier of the REPOSITORY paragraph
+ | LC_ALL_kw { static char s[] ="LC_ALL";
+ $$ = s; } // SET statement
+ | LC_COLLATE_kw { static char s[] ="LC_COLLATE";
+ $$ = s; } // SET statement
+ | LC_CTYPE_kw { static char s[] ="LC_CTYPE";
+ $$ = s; } // SET statement
+ | LC_MESSAGES_kw { static char s[] ="LC_MESSAGES";
+ $$ = s; } // SET statement
+ | LC_MONETARY_kw { static char s[] ="LC_MONETARY";
+ $$ = s; } // SET statement
+ | LC_NUMERIC_kw { static char s[] ="LC_NUMERIC";
+ $$ = s; } // SET statement
+ | LC_TIME_kw { static char s[] ="LC_TIME";
+ $$ = s; } // SET statement
+ | LOWLIGHT { static char s[] ="LOWLIGHT";
+ $$ = s; } // screen description entry and SET attribute statement
+ | MANUAL { static char s[] ="MANUAL";
+ $$ = s; } // LOCK MODE clause
+ | MULTIPLE { static char s[] ="MULTIPLE";
+ $$ = s; } // LOCK ON phrase
+ | NEAREST_AWAY_FROM_ZERO { static char s[] ="NEAREST-AWAY-FROM-ZERO";
+ $$ = s; } // INTERMEDIATE ROUNDING clause and ROUNDED phrase
+ | NEAREST_EVEN { static char s[] ="NEAREST-EVEN";
+ $$ = s; } // INTERMEDIATE ROUNDING clause and ROUNDED phrase
+ | NEAREST_TOWARD_ZERO { static char s[] ="NEAREST-TOWARD-ZERO";
+ $$ = s; } // INTERMEDIATE ROUNDING clause and ROUNDED phrase
+ | NONE { static char s[] ="NONE";
+ $$ = s; } // DEFAULT clause
+ | NORMAL { static char s[] ="NORMAL";
+ $$ = s; } // STOP statement
+ | NUMBERS { static char s[] ="NUMBERS";
+ $$ = s; } // COLUMN clause and LINE clause
+ | ONLY { static char s[] ="ONLY";
+ $$ = s; } // Object-view, SHARING clause, SHARING phrase, and USAGE clause
+ /* | PARAGRAPH { static char s[] ="PARAGRAPH";
+ $$ = s; } // EXIT statement */
+ | PREFIXED { static char s[] ="PREFIXED";
+ $$ = s; } // DYNAMIC LENGTH STRUCTURE clause
+ | PREVIOUS { static char s[] ="PREVIOUS";
+ $$ = s; } // READ statement
+ | PROHIBITED { static char s[] ="PROHIBITED";
+ $$ = s; } // INTERMEDIATE ROUNDING clause and ROUNDED phrase
+ | RECURSIVE { static char s[] ="RECURSIVE";
+ $$ = s; } // PROGRAM-ID paragraph
+ | RELATION { static char s[] ="RELATION";
+ $$ = s; } // VALIDATE-STATUS clause
+ | REQUIRED { static char s[] ="REQUIRED";
+ $$ = s; } // screen description entry
+ | REVERSE_VIDEO { static char s[] ="REVERSE-VIDEO";
+ $$ = s; } // screen description entry and SET attribute statement
+ | ROUNDING { static char s[] ="ROUNDING";
+ $$ = s; } // OPTIONS paragraph
+ | SECONDS { static char s[] ="SECONDS";
+ $$ = s; } // RETRY phrase
+ | SECURE { static char s[] ="SECURE";
+ $$ = s; } // screen description entry
+ | SHORT { static char s[] ="SHORT";
+ $$ = s; } // DYNAMIC LENGTH STRUCTURE clause
+ | SIGNED { static char s[] ="SIGNED";
+ $$ = s; } // DYNAMIC LENGTH STRUCTURE clause and USAGE clause
+ | STANDARD_BINARY { static char s[] ="STANDARD-BINARY";
+ $$ = s; } // ARITHMETIC clause
+ | STANDARD_DECIMAL { static char s[] ="STANDARD-DECIMAL";
+ $$ = s; } // ARITHMETIC clause
+ | STATEMENT { static char s[] ="STATEMENT";
+ $$ = s; } // RESUME statement
+ | STEP { static char s[] ="STEP";
+ $$ = s; } // OCCURS clause
+ | STRONG { static char s[] ="STRONG";
+ $$ = s; } // TYPEDEF clause
+ | STRUCTURE { static char s[] ="STRUCTURE";
+ $$ = s; } // DYNAMIC LENGTH STRUCTURE clause
+ | SYMBOL { static char s[] ="SYMBOL";
+ $$ = s; } // CURRENCY clause
+ | TOWARD_GREATER { static char s[] ="TOWARD-GREATER";
+ $$ = s; } // ROUNDED phrase
+ | TOWARD_LESSER { static char s[] ="TOWARD-LESSER";
+ $$ = s; } // ROUNDED phrase
+ | TRUNCATION { static char s[] ="TRUNCATION";
+ $$ = s; } // INTERMEDIATE ROUNDING clause and ROUNDED phrase
+ | UCS_4 { static char s[] ="UCS-4";
+ $$ = s; } // ALPHABET clause
+ | UNDERLINE { static char s[] ="UNDERLINE";
+ $$ = s; } // screen description entry and SET attribute statement
+ | UNSIGNED { static char s[] ="UNSIGNED";
+ $$ = s; } // USAGE clause
+ | UTF_8 { static char s[] ="UTF-8";
+ $$ = s; } // ALPHABET clause
+ | UTF_16 { static char s[] ="UTF-16";
+ $$ = s; } // ALPHABET clause
+ | YYYYDDD { static char s[] ="YYYYDDD";
+ $$ = s; } // ACCEPT statement
+ | YYYYMMDD { static char s[] ="YYYYMMDD";
+ $$ = s; } // ACCEPT statement
+ ;
move: MOVE scalar TO move_tgts[tgts]
{
statement_begin(@1, MOVE);
- if( $scalar->field->type == FldIndex ) {
- yyerrorv( "syntax error: '%s' cannot be MOVEd "
- "because it's an INDEX", name_of($scalar->field) );
- YYERROR;
- }
+ if( $scalar->field->type == FldIndex ) {
+ yyerrorv( "syntax error: '%s' cannot be MOVEd "
+ "because it's an INDEX", name_of($scalar->field) );
+ YYERROR;
+ }
if( !parser_move2($tgts, *$scalar) ) { YYERROR; }
}
| MOVE all LITERAL TO move_tgts[tgts]
@@ -5636,22 +5636,22 @@ move: MOVE scalar TO move_tgts[tgts]
| MOVE all spaces_etc[src] TO move_tgts[tgts]
{
statement_begin(@1, MOVE);
- cbl_field_t *field;
- auto p = std::find_if( $tgts->targets.begin(),
- $tgts->targets.end(),
- [&field]( const auto& num_result ) {
- const cbl_refer_t& tgt = num_result.refer;
- field = tgt.field;
- return is_numeric(tgt.field);
- } );
-
- if( p != $tgts->targets.end() ) {
- yyerrorv( "error: cannot MOVE %s "
- "to numeric receiving field %s",
- constant_of(constant_index($src))->name,
- field->name );
- YYERROR;
- }
+ cbl_field_t *field;
+ auto p = std::find_if( $tgts->targets.begin(),
+ $tgts->targets.end(),
+ [&field]( const auto& num_result ) {
+ const cbl_refer_t& tgt = num_result.refer;
+ field = tgt.field;
+ return is_numeric(tgt.field);
+ } );
+
+ if( p != $tgts->targets.end() ) {
+ yyerrorv( "error: cannot MOVE %s "
+ "to numeric receiving field %s",
+ constant_of(constant_index($src))->name,
+ field->name );
+ YYERROR;
+ }
struct cbl_field_t* src = constant_of(constant_index($src));
if( !parser_move2($tgts, src) ) { YYERROR; }
@@ -5659,7 +5659,7 @@ move: MOVE scalar TO move_tgts[tgts]
| MOVE all signed_literal[lit] TO move_tgts[tgts]
{
statement_begin(@1, MOVE);
- cbl_refer_t src( $lit, $all);
+ cbl_refer_t src( $lit, $all);
if( !parser_move2($tgts, src) ) { YYERROR; }
}
@@ -5682,8 +5682,8 @@ move: MOVE scalar TO move_tgts[tgts]
}
if( !move_corresponding(*$to, *$from) ) {
- yywarnv( "warning: %s and %s have no corresponding fields",
- $from->field->name, $to->field->name );
+ yywarnv( "warning: %s and %s have no corresponding fields",
+ $from->field->name, $to->field->name );
}
}
;
@@ -5694,12 +5694,12 @@ move_tgts: scalar {
| move_tgts scalar
{
list_add($1->targets, *$scalar, current_rounded_mode());
- }
- | error
- {
+ }
+ | error
+ {
$$ = new tgt_list_t;
- yyerror("error: invalid MOVE receiving operand");
- }
+ yyerror("error: invalid MOVE receiving operand");
+ }
;
multiply: multiply_impl end_multiply { ast_multiply($1); }
@@ -5731,11 +5731,11 @@ multiply_body: num_operand BY rnames
rhs.end(), back_inserter($$->tgts) );
rhs.clear();
}
- | num_operand BY signed_literal[lit]
- {
- yyerrorv("syntax error: %s is not a receiving field", name_of($lit));
- YYERROR;
- }
+ | num_operand BY signed_literal[lit]
+ {
+ yyerrorv("syntax error: %s is not a receiving field", name_of($lit));
+ YYERROR;
+ }
| num_operand[a] BY num_operand[b] GIVING rnames
{
$$ = new arith_t(giving_e);
@@ -5745,16 +5745,16 @@ multiply_body: num_operand BY rnames
rhs.end(), back_inserter($$->tgts) );
rhs.clear();
}
- | num_operand[a] BY num_operand[b] GIVING signed_literal[lit]
- {
- yyerrorv("syntax error: %s is not a receiving field", name_of($lit));
- YYERROR;
- }
- | LITERAL
- {
- yyerrorv("syntax error: invalid string operand '%s'", $1.data);
- YYERROR;
- }
+ | num_operand[a] BY num_operand[b] GIVING signed_literal[lit]
+ {
+ yyerrorv("syntax error: %s is not a receiving field", name_of($lit));
+ YYERROR;
+ }
+ | LITERAL
+ {
+ yyerrorv("syntax error: invalid string operand '%s'", $1.data);
+ YYERROR;
+ }
;
arith_errs: arith_err[a] statements %prec ADD
@@ -5799,14 +5799,14 @@ arith_err: SIZE_ERROR
assert( $1 == ERROR || $1 == NOT );
$$.on_error = NULL;
$$.not_error = NULL;
- cbl_label_t **ptgt = $1 == NOT? &$$.not_error : &$$.on_error;
- if( current.in_compute() ) {
- *ptgt = $1 == NOT?
- current.compute_not_error() : current.compute_on_error();
- } else {
+ cbl_label_t **ptgt = $1 == NOT? &$$.not_error : &$$.on_error;
+ if( current.in_compute() ) {
+ *ptgt = $1 == NOT?
+ current.compute_not_error() : current.compute_on_error();
+ } else {
*ptgt = label_add(LblArith, uniq_label("arith"), yylineno);
- }
- parser_arith_error( *ptgt );
+ }
+ parser_arith_error( *ptgt );
}
;
@@ -5855,74 +5855,74 @@ num_operand: scalar
num_value: scalar
| intrinsic_call
- | num_literal { $$ = new_reference($1); }
- | ADDRESS OF scalar {$$ = $scalar; $$->addr_of = true; }
- | DETAIL OF scalar {$$ = $scalar; }
- | LENGTH_OF scalar[val] {
+ | num_literal { $$ = new_reference($1); }
+ | ADDRESS OF scalar {$$ = $scalar; $$->addr_of = true; }
+ | DETAIL OF scalar {$$ = $scalar; }
+ | LENGTH_OF scalar[val] {
location_set(@1);
$$ = new cbl_refer_t( new_tempnumeric() );
- auto r1 = $val;
+ auto r1 = $val;
if( ! dialect_ibm() ) {
- yyerrorv("LENGTH OF %s requires '-dialect ibm' option",
- $val->field->name);
- }
+ yyerrorv("LENGTH OF %s requires '-dialect ibm' option",
+ $val->field->name);
+ }
if( ! intrinsic_call_1($$->field, LENGTH, r1) ) YYERROR;
- }
+ }
;
- /*
- * Constant Compile-time Expressions
- */
+ /*
+ * Constant Compile-time Expressions
+ */
/* cce_cond_expr: cce_bool_expr { $$ = $1 == 0? false : true; } */
-/* ; */
-/* cce_bool_expr: cce_and */
-/* | cce_bool_expr OR cce_and { $$ = $1 || $3; } */
-/* ; */
-/* cce_and: cce_reloper */
-/* | cce_and AND cce_reloper { $$ = $1 && $3; } */
-/* ; */
-/* cce_reloper: cce_relexpr */
-/* | NOT cce_relexpr { $$ = $2 != 0; } */
-/* ; */
-/* cce_relexpr: cce_expr */
-/* | cce_relexpr '<' cce_expr { $$ = $1 < $3; } */
-/* | cce_relexpr LE cce_expr { $$ = $1 <= $3; } */
-/* | cce_relexpr '=' cce_expr { $$ = $1 == $3; } */
-/* | cce_relexpr NE cce_expr { $$ = $1 != $3; } */
-/* | cce_relexpr GE cce_expr { $$ = $1 >= $3; } */
-/* | cce_relexpr '>' cce_expr { $$ = $1 > $3; } */
-/* ; */
-
-cce_expr: cce_factor
- | cce_expr '+' cce_expr { $$ = $1 + $3; }
+/* ; */
+/* cce_bool_expr: cce_and */
+/* | cce_bool_expr OR cce_and { $$ = $1 || $3; } */
+/* ; */
+/* cce_and: cce_reloper */
+/* | cce_and AND cce_reloper { $$ = $1 && $3; } */
+/* ; */
+/* cce_reloper: cce_relexpr */
+/* | NOT cce_relexpr { $$ = $2 != 0; } */
+/* ; */
+/* cce_relexpr: cce_expr */
+/* | cce_relexpr '<' cce_expr { $$ = $1 < $3; } */
+/* | cce_relexpr LE cce_expr { $$ = $1 <= $3; } */
+/* | cce_relexpr '=' cce_expr { $$ = $1 == $3; } */
+/* | cce_relexpr NE cce_expr { $$ = $1 != $3; } */
+/* | cce_relexpr GE cce_expr { $$ = $1 >= $3; } */
+/* | cce_relexpr '>' cce_expr { $$ = $1 > $3; } */
+/* ; */
+
+cce_expr: cce_factor
+ | cce_expr '+' cce_expr { $$ = $1 + $3; }
| cce_expr '-' cce_expr { $$ = $1 - $3; }
| cce_expr '*' cce_expr { $$ = $1 * $3; }
| cce_expr '/' cce_expr { $$ = $1 / $3; }
- | '+' cce_expr %prec NEG { $$ = $2; }
- | '-' cce_expr %prec NEG { $$ = -$2; }
- | '(' cce_expr ')' { $$ = $2; }
+ | '+' cce_expr %prec NEG { $$ = $2; }
+ | '-' cce_expr %prec NEG { $$ = -$2; }
+ | '(' cce_expr ')' { $$ = $2; }
;
cce_factor: NUMSTR {
- /*
- * As of March 2023, glibc printf does not deal with
- * __int128_t. The below assertion is not required. It
- * serves only remind us we're far short of the precision
- * required by ISO.
- */
- static_assert( sizeof($$) == sizeof(_Float128),
- "quadmath?" );
- static_assert( sizeof($$) == 16,
- "long doubles?" );
- $$ = numstr2i($1.string, $1.radix);
- }
+ /*
+ * As of March 2023, glibc printf does not deal with
+ * __int128_t. The below assertion is not required. It
+ * serves only remind us we're far short of the precision
+ * required by ISO.
+ */
+ static_assert( sizeof($$) == sizeof(_Float128),
+ "quadmath?" );
+ static_assert( sizeof($$) == 16,
+ "long doubles?" );
+ $$ = numstr2i($1.string, $1.radix);
+ }
;
- /*
- * End Constant Compile-time Expressions
- */
+ /*
+ * End Constant Compile-time Expressions
+ */
@@ -5944,25 +5944,25 @@ section: SECTION_NAME section_kw '.'
apply_declaratives();
} [label]
- cdf_use
- {
- $$ = $label;
- }
+ cdf_use
+ {
+ $$ = $label;
+ }
;
section_kw: SECTION
| SECTION NUMSTR
- {
- if( $NUMSTR.string[0] == '-' ) {
- yyerror("error: negative section segment");
- } else {
- yywarn("warning: section segment ignored");
- }
- }
- | SECTION error
- {
- yyerror("error: unknown section qualifier");
- }
+ {
+ if( $NUMSTR.string[0] == '-' ) {
+ yyerror("error: negative section segment");
+ } else {
+ yywarn("warning: section segment ignored");
+ }
+ }
+ | SECTION error
+ {
+ yyerror("error: unknown section qualifier");
+ }
;
stop: STOP RUN stop_how
@@ -5973,46 +5973,46 @@ stop: STOP RUN stop_how
| STOP NUMSTR[name] // IBM syntax
{
statement_begin(@1, STOP);
- if( ! dialect_ibm() ) {
- yyerror("error: STOP <number> is not ISO syntax, requires -dialect ibm");
- YYERROR;
- }
- cbl_refer_t exit_status( new_literal($name.string, $name.radix) );
- parser_see_stop_run( exit_status, NULL );
+ if( ! dialect_ibm() ) {
+ yyerror("error: STOP <number> is not ISO syntax, requires -dialect ibm");
+ YYERROR;
+ }
+ cbl_refer_t exit_status( new_literal($name.string, $name.radix) );
+ parser_see_stop_run( exit_status, NULL );
}
| STOP LITERAL[name] // CCVS-85 && IBM syntax
{
statement_begin(@1, STOP);
- const char *name = string_of($name);
- if( ! name ) {
- yyerrorv("'%s' has embedded NUL", $name.data);
- YYERROR;
- }
- parser_see_stop_run( literally_zero, $name.data );
- }
- ;
-stop_how: %empty
- {
- $$ = cbl_refer_t::empty();
- }
- | with NORMAL stop_status
- {
- $$ = $stop_status? $stop_status : new_reference(literally_zero);
- }
- | with ERROR stop_status
- {
- $$ = $stop_status? $stop_status : new_reference(literally_one);
- }
- ;
-stop_status: status { $$ = NULL; }
- | status scalar { $$ = $2; }
- | status NUMSTR {
- $$ = new_reference(new_literal($2.string, $2.radix));
- }
- ;
+ const char *name = string_of($name);
+ if( ! name ) {
+ yyerrorv("'%s' has embedded NUL", $name.data);
+ YYERROR;
+ }
+ parser_see_stop_run( literally_zero, $name.data );
+ }
+ ;
+stop_how: %empty
+ {
+ $$ = cbl_refer_t::empty();
+ }
+ | with NORMAL stop_status
+ {
+ $$ = $stop_status? $stop_status : new_reference(literally_zero);
+ }
+ | with ERROR stop_status
+ {
+ $$ = $stop_status? $stop_status : new_reference(literally_one);
+ }
+ ;
+stop_status: status { $$ = NULL; }
+ | status scalar { $$ = $2; }
+ | status NUMSTR {
+ $$ = new_reference(new_literal($2.string, $2.radix));
+ }
+ ;
subscripts: LPAREN expr_list ')' { $$ = $2; }
- ;
+ ;
expr_list: expr { $$ = new refer_list_t($expr); }
| expr_list expr {
if( $1->size() == MAXIMUM_TABLE_DIMENSIONS ) {
@@ -6022,18 +6022,18 @@ expr_list: expr { $$ = new refer_list_t($expr); }
}
$1->push_back($2); $$ = $1;
}
- | ALL {
- auto ref = new_reference(constant_of(constant_index(ZERO)));
- $$ = new refer_list_t(ref);
- }
+ | ALL {
+ auto ref = new_reference(constant_of(constant_index(ZERO)));
+ $$ = new refer_list_t(ref);
+ }
;
arg_list: any_arg { $$ = new refer_list_t($1); }
| arg_list any_arg { $1->push_back($2); $$ = $1; }
;
-any_arg: expr
- | LITERAL {$$ = new_reference(new_literal($1, quoted_e)); }
- ;
+any_arg: expr
+ | LITERAL {$$ = new_reference(new_literal($1, quoted_e)); }
+ ;
/*
* Because num_literal includes ZERO, this grammar
@@ -6047,16 +6047,16 @@ signed_literal: num_literal
struct cbl_field_t *zero = constant_of(constant_index(ZERO));
parser_subtract( $$, zero, $2, current_rounded_mode() );
}
- | LENGTH_OF scalar[val] {
+ | LENGTH_OF scalar[val] {
location_set(@1);
$$ = new_tempnumeric();
- auto r1 = $val;
+ auto r1 = $val;
if( ! dialect_ibm() ) {
- yyerrorv("LENGTH OF %s requires '-dialect ibm' option",
- $val->field->name);
- }
+ yyerrorv("LENGTH OF %s requires '-dialect ibm' option",
+ $val->field->name);
+ }
if( ! intrinsic_call_1($$, LENGTH, r1) ) YYERROR;
- }
+ }
;
num_literal: NUMSTR { $$ = new_literal($1.string, $1.radix); }
@@ -6069,11 +6069,11 @@ open_files: open_file
| open_files open_file
;
open_file: open_io[mode] filenames {
- size_t n = $2->files.size();
- parser_file_open( n, use_list($2->files, false), $mode );
- current.declaratives_evaluate($2->files);
- $2->files.clear();
- }
+ size_t n = $2->files.size();
+ parser_file_open( n, use_list($2->files, false), $mode );
+ current.declaratives_evaluate($2->files);
+ $2->files.clear();
+ }
;
open_io: INPUT { $$ = 'r'; }
| OUTPUT { $$ = 'w'; }
@@ -6093,25 +6093,25 @@ close_file: NAME close_how
yyerrorv("invalid file name '%s'", $1);
YYERROR;
}
- auto how = static_cast<file_close_how_t>($close_how);
- bool reel_unit = (file_close_reel_unit_e & $close_how) > 0;
- auto file = cbl_file_of(e);
- switch( file->org ) {
- case file_disorganized_e:
- assert(false);
- break;
- case file_sequential_e:
- case file_line_sequential_e:
- break;
- case file_indexed_e:;
- case file_relative_e:
- if( $close_how & ~file_close_with_lock_e ) {
- yyerror( "syntax error: INDEXED or RELATIVE file "
- "closed with incompatible qualifier" );
- YYERROR;
- }
- break;
- }
+ auto how = static_cast<file_close_how_t>($close_how);
+ bool reel_unit = (file_close_reel_unit_e & $close_how) > 0;
+ auto file = cbl_file_of(e);
+ switch( file->org ) {
+ case file_disorganized_e:
+ assert(false);
+ break;
+ case file_sequential_e:
+ case file_line_sequential_e:
+ break;
+ case file_indexed_e:;
+ case file_relative_e:
+ if( $close_how & ~file_close_with_lock_e ) {
+ yyerror( "syntax error: INDEXED or RELATIVE file "
+ "closed with incompatible qualifier" );
+ YYERROR;
+ }
+ break;
+ }
if(reel_unit)
{
how = file_close_reel_unit_e;
@@ -6120,23 +6120,23 @@ close_file: NAME close_how
current.declaratives_evaluate( file );
}
;
-close_how: %empty { $$ = file_close_no_how_e; }
- | reel_unit { $$ = file_close_reel_unit_e; }
- | reel_unit for_kw REMOVAL {
- $$ = file_close_reel_unit_e | file_close_removal_e;
- }
- | reel_unit WITH NO REWIND {
- $$ = file_close_reel_unit_e | file_close_no_rewind_e;
- }
- | with NO REWIND { $$ = file_close_no_rewind_e; }
- | with LOCK { $$ = file_close_with_lock_e; }
- ;
-reel_unit: REEL
- | UNIT
- ;
-for_kw: %empty
- | FOR
- ;
+close_how: %empty { $$ = file_close_no_how_e; }
+ | reel_unit { $$ = file_close_reel_unit_e; }
+ | reel_unit for_kw REMOVAL {
+ $$ = file_close_reel_unit_e | file_close_removal_e;
+ }
+ | reel_unit WITH NO REWIND {
+ $$ = file_close_reel_unit_e | file_close_no_rewind_e;
+ }
+ | with NO REWIND { $$ = file_close_no_rewind_e; }
+ | with LOCK { $$ = file_close_with_lock_e; }
+ ;
+reel_unit: REEL
+ | UNIT
+ ;
+for_kw: %empty
+ | FOR
+ ;
perform: perform_verb perform_proc { perform_free(); }
| perform_verb perform_stmts { perform_free(); }
@@ -6211,16 +6211,16 @@ perform_proc: perform_names %prec NAME
perform_names: label_1[para]
{
perform_tgt_set($para);
- if( false /* ! current.valid_perform_target(tgt) */ ) {
- yyerrorv("error: cannot PERFORM current procedure %s", $para->name);
- }
+ if( false /* ! current.valid_perform_target(tgt) */ ) {
+ yyerrorv("error: cannot PERFORM current procedure %s", $para->name);
+ }
}
| label_1[para1] THRU label_1[para2]
{
perform_tgt_set($para1, $para2);
- if( false /* ! current.valid_perform_target(tgt) */ ) {
- yyerror("error: cannot PERFORM current procedure");
- }
+ if( false /* ! current.valid_perform_target(tgt) */ ) {
+ yyerror("error: cannot PERFORM current procedure");
+ }
}
;
@@ -6270,11 +6270,11 @@ perform_cond: UNTIL { parser_perform_conditional( &perform_current()->tgt); }
bool_expr
{
parser_perform_conditional_end( &perform_current()->tgt);
- if( !is_conditional($bool_expr.cond) ) {
- yyerrorv("error: %s is not a condition expression",
- name_of($bool_expr.cond->field));
- YYERROR;
- }
+ if( !is_conditional($bool_expr.cond) ) {
+ yyerrorv("error: %s is not a condition expression",
+ name_of($bool_expr.cond->field));
+ YYERROR;
+ }
$$ = $bool_expr.cond->cond();
}
;
@@ -6283,7 +6283,7 @@ perform_inline: <perf>{ $$ = perform_start(); } statements END_PERFORM
{
$$ = $1;
}
- | <perf>{ $$ = perform_start(); } END_PERFORM
+ | <perf>{ $$ = perform_start(); } END_PERFORM
{
$$ = $1;
}
@@ -6313,9 +6313,9 @@ vary_after: AFTER num_operand[tgt] FROM num_operand[from] vary_by[by]
perform_current()->varys.push_back(vary);
}
;
-vary_by: %empty { $$ = new cbl_refer_t(literally_one); }
- | BY num_operand { $$ = $2; }
- ;
+vary_by: %empty { $$ = new cbl_refer_t(literally_one); }
+ | BY num_operand { $$ = $2; }
+ ;
paragraph: PARAGRAPH
{
@@ -6333,7 +6333,7 @@ paragraph: PARAGRAPH
reserved_value: spaces_etc
| ZERO { $$ = ZERO; }
- | NULLS { warnx("reserved value is NULLS"); $$ = NULLS; }
+ | NULLS { warnx("reserved value is NULLS"); $$ = NULLS; }
;
spaces_etc: SPACES { $$ = SPACES; }
| HIGH_VALUE { $$ = HIGH_VALUE; }
@@ -6428,24 +6428,24 @@ varg1: scalar
{
$$ = new_reference(constant_of(constant_index($1)));
}
- | LENGTH_OF scalar[val] {
+ | LENGTH_OF scalar[val] {
location_set(@1);
$$ = new cbl_refer_t( new_tempnumeric_float() );
- auto r1 = $val;
+ auto r1 = $val;
if( ! dialect_ibm() ) {
- yyerrorv("LENGTH OF %s requires '-dialect ibm' option",
- $val->field->name);
- }
+ yyerrorv("LENGTH OF %s requires '-dialect ibm' option",
+ $val->field->name);
+ }
if( ! intrinsic_call_1($$->field, LENGTH, r1) ) YYERROR;
- }
+ }
;
literal: LITERAL
{
$$ = $1.isymbol()?
- cbl_field_of(symbol_at($1.isymbol()))
- :
- new_literal($1, quoted_e);
+ cbl_field_of(symbol_at($1.isymbol()))
+ :
+ new_literal($1, quoted_e);
}
| NUMSTR
{
@@ -6465,76 +6465,76 @@ literal: LITERAL
}
;
-raise: RAISE EXCEPTION NAME
- {
- auto ec = ec_type_of($NAME);
- if( ec == ec_none_e ) {
- yyerrorv("syntax error: not an "
- "EXCEPTION CONDITION: %s", $NAME);
- YYERROR;
- }
- statement_begin(@$, RAISE);
- parser_exception_raise(ec);
- }
- | RAISE NAME
- {
- auto ec = ec_type_of($NAME);
- if( ec != ec_none_e ) {
- yyerrorv("syntax error: RAISE EXCEPTION required for "
- "EXCEPTION CONDITION: %s", $NAME);
- YYERROR;
- }
- yyerror("error: unimplemented EXCEPTION OBJECT");
- YYERROR;
- }
- ;
+raise: RAISE EXCEPTION NAME
+ {
+ auto ec = ec_type_of($NAME);
+ if( ec == ec_none_e ) {
+ yyerrorv("syntax error: not an "
+ "EXCEPTION CONDITION: %s", $NAME);
+ YYERROR;
+ }
+ statement_begin(@$, RAISE);
+ parser_exception_raise(ec);
+ }
+ | RAISE NAME
+ {
+ auto ec = ec_type_of($NAME);
+ if( ec != ec_none_e ) {
+ yyerrorv("syntax error: RAISE EXCEPTION required for "
+ "EXCEPTION CONDITION: %s", $NAME);
+ YYERROR;
+ }
+ yyerror("error: unimplemented EXCEPTION OBJECT");
+ YYERROR;
+ }
+ ;
read: read_file
{
- current.declaratives_evaluate($1.file, $1.handled);
+ current.declaratives_evaluate($1.file, $1.handled);
}
;
read_file: READ read_body {
- file_read_args.call_parser_file_read();
- $$.file = $2; $$.handled = FsSuccess;
- }
+ file_read_args.call_parser_file_read();
+ $$.file = $2; $$.handled = FsSuccess;
+ }
| READ read_body END_READ {
- file_read_args.call_parser_file_read();
- $$.file = $2; $$.handled = FsSuccess;
- }
+ file_read_args.call_parser_file_read();
+ $$.file = $2; $$.handled = FsSuccess;
+ }
| READ read_body read_eofs[err] {
bool handled = $err.nclause == 2 || !$err.tf;
- $$.file = $2; $$.handled = handled? FsEofSeq : FsSuccess;
- if( $$.file->access == file_access_rnd_e ) {
- // None of ADVANCING, AT END, NEXT, NOT AT END, or PREVIOUS
- // shall be specified if ACCESS MODE RANDOM
+ $$.file = $2; $$.handled = handled? FsEofSeq : FsSuccess;
+ if( $$.file->access == file_access_rnd_e ) {
+ // None of ADVANCING, AT END, NEXT, NOT AT END, or PREVIOUS
+ // shall be specified if ACCESS MODE RANDOM
yyerrorv("syntax error, %s: AT END invalid for "
- "ACCESS MODE RANDOM", $$.file->name);
+ "ACCESS MODE RANDOM", $$.file->name);
YYERROR;
- }
+ }
parser_fi();
- }
+ }
| READ read_body read_eofs[err] END_READ {
bool handled = $err.nclause == 2 || !$err.tf;
- $$.file = $2; $$.handled = handled? FsEofSeq : FsSuccess;
- if( $$.file->access == file_access_rnd_e ) {
+ $$.file = $2; $$.handled = handled? FsEofSeq : FsSuccess;
+ if( $$.file->access == file_access_rnd_e ) {
yyerrorv("syntax error, %s: AT END invalid for "
- "ACCESS MODE RANDOM", $$.file->name);
+ "ACCESS MODE RANDOM", $$.file->name);
YYERROR;
- }
+ }
parser_fi();
- }
+ }
| READ read_body io_invalids[err] {
bool handled = $err.nclause == 2 || !$err.tf;
- $$.file = $2; $$.handled = handled? FsNotFound : FsSuccess;
+ $$.file = $2; $$.handled = handled? FsNotFound : FsSuccess;
parser_fi();
- }
+ }
| READ read_body io_invalids[err] END_READ {
bool handled = $err.nclause == 2 || !$err.tf;
- $$.file = $2; $$.handled = handled? FsNotFound : FsSuccess;
+ $$.file = $2; $$.handled = handled? FsNotFound : FsSuccess;
parser_fi();
- }
+ }
;
read_body: NAME read_next read_into read_key
@@ -6563,7 +6563,7 @@ read_body: NAME read_next read_into read_key
}
if( $$->org == file_line_sequential_e && $read_next == -2 ) {
yyerrorv("LINE SEQUENTIAL file %s cannot READ PREVIOUS",
- $$->name);
+ $$->name);
YYERROR;
}
if( $read_key->field && $read_next < 0 ) {
@@ -6571,10 +6571,10 @@ read_body: NAME read_next read_into read_key
YYERROR;
}
- int ikey = $read_next;
- if( $read_key->field ) {
- ikey = $$->key_one($read_key->field);
- }
+ int ikey = $read_next;
+ if( $read_key->field ) {
+ ikey = $$->key_one($read_key->field);
+ }
file_read_args.init( $$, record, $read_into, ikey );
}
@@ -6592,12 +6592,12 @@ read_into: %empty { $$ = NULL; }
| INTO scalar { $$ = $scalar; }
;
- /*
- * read_eofs may have 1 or 2 clauses, plus a boolean that
- * represents whether the last one is a NOT clause. That is,
- * there's an AT END clause if there are 2 clauses, or if
- * there's one clause that is an AT END clause (tf is false).
- */
+ /*
+ * read_eofs may have 1 or 2 clauses, plus a boolean that
+ * represents whether the last one is a NOT clause. That is,
+ * there's an AT END clause if there are 2 clauses, or if
+ * there's one clause that is an AT END clause (tf is false).
+ */
read_eofs: read_eof { $$.nclause = 1; $$.tf = $1; }
| read_eofs read_eof
{
@@ -6616,28 +6616,28 @@ read_eofs: read_eof { $$.nclause = 1; $$.tf = $1; }
read_eof: END
{
- if( file_read_args.ready() ) {
- file_read_args.default_march(true);
- file_read_args.call_parser_file_read();
- }
-
- static const struct status_t { file_status_t L, U; }
- at_end = { FsEofSeq, FsKeySeq },
- not_at_end = { FsSuccess, FsEofSeq };
- assert( $1 == END || $1 == NOT );
- status_t st = $1 == END? at_end : not_at_end;
- // L <= ec < U
+ if( file_read_args.ready() ) {
+ file_read_args.default_march(true);
+ file_read_args.call_parser_file_read();
+ }
+
+ static const struct status_t { file_status_t L, U; }
+ at_end = { FsEofSeq, FsKeySeq },
+ not_at_end = { FsSuccess, FsEofSeq };
+ assert( $1 == END || $1 == NOT );
+ status_t st = $1 == END? at_end : not_at_end;
+ // L <= ec < U
cbl_field_t *cond = ast_file_status_between(st.L, st.U);
parser_if(cond);
- parser_exception_clear();
+ parser_exception_clear();
} statements {
parser_else();
$$ = $1 == NOT;
}
- ;
+ ;
-write_eops: write_eop { $$.nclause = 1; $$.tf = $1; }
+write_eops: write_eop { $$.nclause = 1; $$.tf = $1; }
| write_eops write_eop
{
$$ = $1;
@@ -6652,78 +6652,78 @@ write_eops: write_eop { $$.nclause = 1; $$.tf = $1; }
}
;
-write_eop: EOP
+write_eop: EOP
{
- // cond represents the _FILE_STATUS of the last WRITE.
- static cbl_field_t *cond = constant_of(constant_index(ZERO));
+ // cond represents the _FILE_STATUS of the last WRITE.
+ static cbl_field_t *cond = constant_of(constant_index(ZERO));
- if( file_write_args.ready() ) {
- file_write_args.call_parser_file_write(true);
- cond = ast_file_status_between(FsEofSeq, FsKeySeq);
- }
- assert( $1 == EOP || $1 == NOT );
+ if( file_write_args.ready() ) {
+ file_write_args.call_parser_file_write(true);
+ cond = ast_file_status_between(FsEofSeq, FsKeySeq);
+ }
+ assert( $1 == EOP || $1 == NOT );
if( $1 == NOT ) {
parser_logop(cond, NULL, not_op, cond);
}
parser_if(cond);
- parser_exception_clear();
+ parser_exception_clear();
} statements {
parser_else();
parser_fi();
$$ = $1 == NOT;
}
- ;
+ ;
read_key: %empty { $$ = new cbl_refer_t(); }
| KEY is name { $$ = new cbl_refer_t($name); }
;
write: write_file
- {
+ {
current.declaratives_evaluate( $1.file, $1.handled );
- }
+ }
;
write_file: WRITE write_body
- {
- $$.file = $2; $$.handled = FsSuccess;
- bool sequentially = $$.file->access == file_access_seq_e;
- file_write_args.call_parser_file_write(sequentially);
- }
+ {
+ $$.file = $2; $$.handled = FsSuccess;
+ bool sequentially = $$.file->access == file_access_seq_e;
+ file_write_args.call_parser_file_write(sequentially);
+ }
| WRITE write_body END_WRITE
- {
- $$.file = $2; $$.handled = FsSuccess;
- bool sequentially = $$.file->access == file_access_seq_e;
- file_write_args.call_parser_file_write(sequentially);
- }
+ {
+ $$.file = $2; $$.handled = FsSuccess;
+ bool sequentially = $$.file->access == file_access_seq_e;
+ file_write_args.call_parser_file_write(sequentially);
+ }
| WRITE write_body write_eops[err] {
bool handled = $err.nclause == 2 || !$err.tf;
- $$.file = $2; $$.handled = handled? FsEofSeq : FsSuccess;
- }
- | WRITE write_body write_eops[err] END_WRITE {
+ $$.file = $2; $$.handled = handled? FsEofSeq : FsSuccess;
+ }
+ | WRITE write_body write_eops[err] END_WRITE {
bool handled = $err.nclause == 2 || !$err.tf;
- $$.file = $2; $$.handled = handled? FsEofSeq : FsSuccess;
- }
+ $$.file = $2; $$.handled = handled? FsEofSeq : FsSuccess;
+ }
| WRITE write_body io_invalids[err] {
bool handled = $err.nclause == 2 || !$err.tf;
- $$.file = $2; $$.handled = handled? FsEofSeq : FsSuccess;
+ $$.file = $2; $$.handled = handled? FsEofSeq : FsSuccess;
parser_fi();
- }
+ }
| WRITE write_body io_invalids[err] END_WRITE {
bool handled = $err.nclause == 2 || !$err.tf;
- $$.file = $2; $$.handled = handled? FsEofSeq : FsSuccess;
+ $$.file = $2; $$.handled = handled? FsEofSeq : FsSuccess;
parser_fi();
- }
+ }
;
write_body: write_what[field] advance_when[when] advancing
{
statement_begin(@$, WRITE);
cbl_file_t *file = symbol_record_file($field);
- if( !file ) {
- yyerrorv("syntax error: no FD record found for %s", $field->name);
- YYERROR;
- }
+ if( !file ) {
+ yyerrorv("syntax error: no FD record found for %s", $field->name);
+ YYERROR;
+ }
$$ = file_write_args.init( file, $field, $when==AFTER, $advancing );
current.declaratives_evaluate( file );
}
@@ -6731,22 +6731,22 @@ write_body: write_what[field] advance_when[when] advancing
{
statement_begin(@$, WRITE);
cbl_file_t *file = symbol_record_file($field);
- if( !file ) {
- yyerrorv("syntax error: no FD record found for %s", $field->name);
- YYERROR;
- }
- cbl_field_t *lines = NULL;
- switch(file->org) {
- case file_sequential_e:
- break;
- case file_line_sequential_e:
- lines = literally_one;
- break;
- case file_disorganized_e:
- case file_indexed_e:
- case file_relative_e:
- break;
- }
+ if( !file ) {
+ yyerrorv("syntax error: no FD record found for %s", $field->name);
+ YYERROR;
+ }
+ cbl_field_t *lines = NULL;
+ switch(file->org) {
+ case file_sequential_e:
+ break;
+ case file_line_sequential_e:
+ lines = literally_one;
+ break;
+ case file_disorganized_e:
+ case file_indexed_e:
+ case file_relative_e:
+ break;
+ }
$$ = file_write_args.init( file, $field, false, lines );
}
;
@@ -6757,7 +6757,7 @@ write_what: file_record FROM alpha_val[input]
}
| file_record
;
-file_record: NAME
+file_record: NAME
{
struct symbol_elem_t *record = symbol_find($NAME);
if( !record ) {
@@ -6767,22 +6767,22 @@ file_record: NAME
$$ = cbl_field_of(record);
}
- | NAME inof filename
- {
- std::list<const char *> names = {$filename->name, $NAME};
- auto record = symbol_find(names);
- if( !record ) {
- yyerrorv("syntax error: %s IN %s not found",
- $NAME, $filename->name);
- YYERROR;
- }
- $$ = cbl_field_of(record);
- }
- | FILE_KW filename
- {
- $$ = cbl_field_of(symbol_at($filename->default_record));
- }
- ;
+ | NAME inof filename
+ {
+ std::list<const char *> names = {$filename->name, $NAME};
+ auto record = symbol_find(names);
+ if( !record ) {
+ yyerrorv("syntax error: %s IN %s not found",
+ $NAME, $filename->name);
+ YYERROR;
+ }
+ $$ = cbl_field_of(record);
+ }
+ | FILE_KW filename
+ {
+ $$ = cbl_field_of(symbol_at($filename->default_record));
+ }
+ ;
advance_when: BEFORE { $$ = BEFORE; }
| AFTER { $$ = AFTER; }
;
@@ -6801,7 +6801,7 @@ advance_by: name lines { $$ = $1; } /* BUG: should accept reference */
*/
$$ = new_literal("-666");
}
- | env_name1 { $$ = literally_one; }
+ | env_name1 { $$ = literally_one; }
;
io_invalids: io_invalid { $$.nclause = 1; $$.tf = $io_invalid; }
@@ -6820,34 +6820,34 @@ io_invalids: io_invalid { $$.nclause = 1; $$.tf = $io_invalid; }
}
;
-io_invalid: INVALID key {
- if( file_delete_args.ready() ) {
- file_delete_args.call_parser_file_delete(false);
- }
- if( file_read_args.ready() ) {
- file_read_args.default_march(false);
- file_read_args.call_parser_file_read();
- }
- if( file_rewrite_args.ready() ) {
- file_rewrite_args.call_parser_file_rewrite(false);
- }
- if( file_start_args.ready() ) {
- file_start_args.call_parser_file_start();
- }
- if( file_write_args.ready() ) {
- file_write_args.call_parser_file_write(false);
- }
-
- static const struct status_t { file_status_t L, U; }
- invalid = { FsKeySeq, FsOsError },
- not_invalid = { FsSuccess, FsEofSeq };
- assert( $1 == INVALID || $1 == NOT );
- status_t st = $1 == INVALID? invalid : not_invalid;
- // L <= ec < U
+io_invalid: INVALID key {
+ if( file_delete_args.ready() ) {
+ file_delete_args.call_parser_file_delete(false);
+ }
+ if( file_read_args.ready() ) {
+ file_read_args.default_march(false);
+ file_read_args.call_parser_file_read();
+ }
+ if( file_rewrite_args.ready() ) {
+ file_rewrite_args.call_parser_file_rewrite(false);
+ }
+ if( file_start_args.ready() ) {
+ file_start_args.call_parser_file_start();
+ }
+ if( file_write_args.ready() ) {
+ file_write_args.call_parser_file_write(false);
+ }
+
+ static const struct status_t { file_status_t L, U; }
+ invalid = { FsKeySeq, FsOsError },
+ not_invalid = { FsSuccess, FsEofSeq };
+ assert( $1 == INVALID || $1 == NOT );
+ status_t st = $1 == INVALID? invalid : not_invalid;
+ // L <= ec < U
cbl_field_t *cond = ast_file_status_between(st.L, st.U);
parser_if(cond);
- parser_exception_clear();
+ parser_exception_clear();
} statements {
parser_else();
$$ = $1 == NOT;
@@ -6858,35 +6858,35 @@ delete: delete_impl end_delete
| delete_cond end_delete
;
delete_impl: DELETE delete_body[file]
- {
- file_delete_args.call_parser_file_delete(true);
+ {
+ file_delete_args.call_parser_file_delete(true);
current.declaratives_evaluate( $file );
- }
- ;
+ }
+ ;
delete_cond: DELETE delete_body[file] io_invalids
- {
- if( is_sequential($file) ) {
- yyerrorv("INVALID KEY phrase invalid for sequential file '%s'",
- $file->name);
- YYERROR;
- }
- if( $file->access == file_access_seq_e ) {
- yyerrorv("INVALID KEY phrase invalid for "
- "sequential access mode on '%s'",
- $file->name);
- YYERROR;
- }
+ {
+ if( is_sequential($file) ) {
+ yyerrorv("INVALID KEY phrase invalid for sequential file '%s'",
+ $file->name);
+ YYERROR;
+ }
+ if( $file->access == file_access_seq_e ) {
+ yyerrorv("INVALID KEY phrase invalid for "
+ "sequential access mode on '%s'",
+ $file->name);
+ YYERROR;
+ }
parser_fi();
- // call happens in io_invalid
+ // call happens in io_invalid
current.declaratives_evaluate( $file );
}
- ;
+ ;
delete_body: filename[file] record
{
statement_begin(@1, DELETE);
- file_delete_args.init( $file );
- $$ = $file;
+ file_delete_args.init( $file );
+ $$ = $file;
}
;
end_delete: %empty %prec DELETE
@@ -6895,45 +6895,45 @@ end_delete: %empty %prec DELETE
rewrite: rewrite1
{
- current.declaratives_evaluate($1.file, $1.handled);
+ current.declaratives_evaluate($1.file, $1.handled);
}
;
rewrite1: REWRITE rewrite_body end_rewrite {
- $$.file = $2.file; $$.handled = FsSuccess;
+ $$.file = $2.file; $$.handled = FsSuccess;
file_rewrite_args.call_parser_file_rewrite( true );
- }
+ }
| REWRITE rewrite_body io_invalids[err] end_rewrite {
bool handled = $err.nclause == 2 || !$err.tf;
- $$.file = $2.file; $$.handled = handled? FsNotFound : FsSuccess;
-
- if( is_sequential($$.file) ) {
- yyerrorv("syntax error: INVALID KEY for sequential file '%s'",
- $$.file->name);
- YYERROR;
- }
- if( $$.file->relative_sequential() ) {
- yyerrorv("syntax error: %s: INVALID KEY may not be specified for "
- "RELATIVE file and SEQUENTIAL access",
- $$.file->name);
- YYERROR;
- }
+ $$.file = $2.file; $$.handled = handled? FsNotFound : FsSuccess;
+
+ if( is_sequential($$.file) ) {
+ yyerrorv("syntax error: INVALID KEY for sequential file '%s'",
+ $$.file->name);
+ YYERROR;
+ }
+ if( $$.file->relative_sequential() ) {
+ yyerrorv("syntax error: %s: INVALID KEY may not be specified for "
+ "RELATIVE file and SEQUENTIAL access",
+ $$.file->name);
+ YYERROR;
+ }
parser_fi();
- }
+ }
;
rewrite_body: write_what record
{
- statement_begin(@$, REWRITE);
+ statement_begin(@$, REWRITE);
symbol_elem_t *e = symbol_file(PROGRAM, $1->name);
- file_rewrite_args.init(cbl_file_of(e), $1);
+ file_rewrite_args.init(cbl_file_of(e), $1);
$$.file = cbl_file_of(e);
- $$.buffer = $1;
+ $$.buffer = $1;
}
;
-end_rewrite: %empty %prec REWRITE
- | END_REWRITE
- ;
+end_rewrite: %empty %prec REWRITE
+ | END_REWRITE
+ ;
start: start_impl end_start
| start_cond end_start
@@ -6942,58 +6942,58 @@ start_impl: START start_body
;
start_cond: START start_body io_invalids {
parser_fi();
- }
+ }
+ ;
+end_start: %empty %prec START
+ | END_START
;
-end_start: %empty %prec START
- | END_START
- ;
start_body: filename[file]
{
statement_begin(@$, START);
- file_start_args.init($file);
+ file_start_args.init($file);
parser_file_start( $file, lt_op, 0 );
}
| filename[file] KEY relop name[key]
{ // lexer swallows IS, although relop allows it.
statement_begin(@$, START);
- int key = $file->key_one($key);
- int size = key == 0 ? 0 : $file->keys[key - 1].size();
- auto ksize = new_tempnumeric();
- parser_set_numeric(ksize, size);
- if( yydebug ) {
- warnx("START: key #%d '%s' has size %d",
- key, $key->name, size);
- }
- file_start_args.init($file);
+ int key = $file->key_one($key);
+ int size = key == 0 ? 0 : $file->keys[key - 1].size();
+ auto ksize = new_tempnumeric();
+ parser_set_numeric(ksize, size);
+ if( yydebug ) {
+ warnx("START: key #%d '%s' has size %d",
+ key, $key->name, size);
+ }
+ file_start_args.init($file);
parser_file_start( $file, relop_of($relop), key, ksize );
}
| filename[file] KEY relop name[key] with LENGTH expr
{ // lexer swallows IS, although relop allows it.
statement_begin(@$, START);
- int key = $file->key_one($key);
- file_start_args.init($file);
+ int key = $file->key_one($key);
+ file_start_args.init($file);
parser_file_start( $file, relop_of($relop), key, *$expr );
}
| filename[file] FIRST
{
statement_begin(@$, START);
- file_start_args.init($file);
+ file_start_args.init($file);
parser_file_start( $file, lt_op, -1 );
}
| filename[file] LAST
{
statement_begin(@$, START);
- file_start_args.init($file);
+ file_start_args.init($file);
parser_file_start( $file, gt_op, -2 );
}
;
merge: MERGE { statement_begin(@1, MERGE); }
- filename[file] sort_keys sort_seq
+ filename[file] sort_keys sort_seq
USING filenames[inputs] sort_output
{
- size_t nkey = $sort_keys->key_list.size();
+ size_t nkey = $sort_keys->key_list.size();
cbl_key_t keys[nkey], *pkey = keys;
for( auto p = $sort_keys->key_list.begin();
@@ -7039,43 +7039,43 @@ set_tgts: set_tgt {
;
set_operand: set_tgt
| signed_literal { $$ = new_reference($1); }
- | ADDRESS of FUNCTION ctx_name[name]
- {
- $$ = NULL;
- auto e = symbol_function(0, $name);
- if( e ) {
- $$ = new cbl_refer_t(cbl_label_of(e));
- } else {
- e = symbol_find($name);
- if( !e ) {
- yyerrorv("error: %s not found", $name);
- YYERROR;
- }
- $$ = new cbl_refer_t(cbl_field_of(e));
- }
- assert($$);
- }
+ | ADDRESS of FUNCTION ctx_name[name]
+ {
+ $$ = NULL;
+ auto e = symbol_function(0, $name);
+ if( e ) {
+ $$ = new cbl_refer_t(cbl_label_of(e));
+ } else {
+ e = symbol_find($name);
+ if( !e ) {
+ yyerrorv("error: %s not found", $name);
+ YYERROR;
+ }
+ $$ = new cbl_refer_t(cbl_field_of(e));
+ }
+ assert($$);
+ }
| ADDRESS of PROGRAM_kw ctx_name[name]
- {
- $$ = NULL;
- auto label = symbol_program(0, $name);
- if( label ) {
- $$ = new cbl_refer_t(label);
- } else {
- auto e = symbol_find($name);
- if( !e ) {
- yyerrorv("error: %s not found", $name);
- YYERROR;
- }
- $$ = new cbl_refer_t(cbl_field_of(e));
- }
- assert($$);
- }
+ {
+ $$ = NULL;
+ auto label = symbol_program(0, $name);
+ if( label ) {
+ $$ = new cbl_refer_t(label);
+ } else {
+ auto e = symbol_find($name);
+ if( !e ) {
+ yyerrorv("error: %s not found", $name);
+ YYERROR;
+ }
+ $$ = new cbl_refer_t(cbl_field_of(e));
+ }
+ assert($$);
+ }
| ADDRESS of PROGRAM_kw LITERAL[lit]
- {
- auto label = symbol_program(0, $lit.data);
- $$ = new cbl_refer_t( label );
- }
+ {
+ auto label = symbol_program(0, $lit.data);
+ $$ = new cbl_refer_t( label );
+ }
;
set_tgt: scalar
| ADDRESS of scalar { $$ = $scalar; $$->addr_of = true; }
@@ -7087,12 +7087,12 @@ set: SET set_tgts[tgts] TO set_operand[src]
switch( set_operand_type(*$src) ) {
case FldInvalid:
- if( ! ($src->prog_func && $src->addr_of) ) {
- yyerrorv("SET source operand '%s' is invalid", $src->name());
+ if( ! ($src->prog_func && $src->addr_of) ) {
+ yyerrorv("SET source operand '%s' is invalid", $src->name());
YYERROR;
break;
- }
- __attribute__((fallthrough));
+ }
+ __attribute__((fallthrough));
case FldPointer:
if( !valid_set_targets(*$tgts, true) ) {
YYERROR;
@@ -7119,31 +7119,31 @@ set: SET set_tgts[tgts] TO set_operand[src]
}
}
}
- | SET set_tgts[tgts] TO NULLS[src]
- {
+ | SET set_tgts[tgts] TO NULLS[src]
+ {
statement_begin(@1, SET);
- if( !valid_set_targets(*$tgts, true) ) {
- YYERROR;
- }
- ast_set_pointers($tgts->targets, constant_of(constant_index(NULLS)));
- }
- | SET set_tgts TO spaces_etc[error]
- {
- yyerror("syntax error: invalid value for SET TO");
- }
- | SET set_tgts[tgts] TO ENTRY scalar[src]
- {
- ast_set_pointers($tgts->targets, *$src);
- }
- | SET set_tgts[tgts] TO ENTRY LITERAL[src]
- {
+ if( !valid_set_targets(*$tgts, true) ) {
+ YYERROR;
+ }
+ ast_set_pointers($tgts->targets, constant_of(constant_index(NULLS)));
+ }
+ | SET set_tgts TO spaces_etc[error]
+ {
+ yyerror("syntax error: invalid value for SET TO");
+ }
+ | SET set_tgts[tgts] TO ENTRY scalar[src]
+ {
+ ast_set_pointers($tgts->targets, *$src);
+ }
+ | SET set_tgts[tgts] TO ENTRY LITERAL[src]
+ {
auto literal = $src.isymbol()?
- cbl_field_of(symbol_at($src.isymbol()))
- :
- new_literal($src, quoted_e);
- ast_set_pointers($tgts->targets, literal);
- }
- | SET set_tgts[tgts] UP BY num_operand[src]
+ cbl_field_of(symbol_at($src.isymbol()))
+ :
+ new_literal($src, quoted_e);
+ ast_set_pointers($tgts->targets, literal);
+ }
+ | SET set_tgts[tgts] UP BY num_operand[src]
{
statement_begin(@1, SET);
list<cbl_num_result_t>& tgts = $tgts->targets;
@@ -7168,7 +7168,7 @@ set: SET set_tgts[tgts] TO set_operand[src]
statement_begin(@1, SET);
parser_set_envar(*$envar, *$scalar);
}
- | SET LAST EXCEPTION TO OFF
+ | SET LAST EXCEPTION TO OFF
{
statement_begin(@1, SET);
// send the signal to clear the stashed exception values
@@ -7188,11 +7188,11 @@ set: SET set_tgts[tgts] TO set_operand[src]
public:
set_conditional( int token ) : tf(token == TRUE_kw) {}
void operator()(cbl_refer_t& refer) {
- if( refer.field->data.false_value == NULL && !tf ) {
- yyerrorv("syntax error: %s has no WHEN SET TO FALSE",
- refer.field->name);
- return;
- }
+ if( refer.field->data.false_value == NULL && !tf ) {
+ yyerrorv("syntax error: %s has no WHEN SET TO FALSE",
+ refer.field->name);
+ return;
+ }
parser_set_conditional88(refer, tf);
}
};
@@ -7256,7 +7256,7 @@ search_1_place: search_1_body
search_1_body: name[table] search_varying[varying]
{
- // YYNOMEM first appears in Bison 3.7
+ // YYNOMEM first appears in Bison 3.7
#ifndef YYNOMEM
# define YYNOMEM YYERROR
#endif
@@ -7327,7 +7327,7 @@ search_binary: SEARCH ALL search_2_body search_2_cases
search_2_body: name[table]
{
- // YYNOMEM first appears in Bison 3.7
+ // YYNOMEM first appears in Bison 3.7
#ifndef YYNOMEM
# define YYNOMEM YYERROR
#endif
@@ -7401,24 +7401,24 @@ sort_table: SORT scalar sort_keys sort_dup sort_seq {
size_t nkey = $sort_keys->key_list.size();
cbl_key_t keys[nkey], *pkey = keys;
- // 23) If data-name-1 is omitted, the data item referenced by
- // data-name-2 is the key data item.
+ // 23) If data-name-1 is omitted, the data item referenced by
+ // data-name-2 is the key data item.
for( auto k : $sort_keys->key_list ) {
- if( k.fields.empty() ) {
- k.fields.push_back($scalar->field);
- }
+ if( k.fields.empty() ) {
+ k.fields.push_back($scalar->field);
+ }
*pkey++ = cbl_key_t(k);
}
parser_sort( *$scalar, $sort_dup, $sort_seq, nkey, keys );
}
- | SORT scalar sort_dup sort_seq {
+ | SORT scalar sort_dup sort_seq {
statement_begin(@1, SORT);
cbl_key_t
- key = cbl_key_t($scalar->field->occurs.keys[0]),
- guess(1, &$scalar->field);
- ;
- if( key.nfield == 0 ) key = guess;
+ key = cbl_key_t($scalar->field->occurs.keys[0]),
+ guess(1, &$scalar->field);
+ ;
+ if( key.nfield == 0 ) key = guess;
parser_sort( *$scalar, $sort_dup, $sort_seq, 1, &key );
}
;
@@ -7465,16 +7465,16 @@ sort_file: SORT FILENAME[file] sort_keys sort_dup sort_seq
parser_file_sort( file,
$sort_dup,
- $sort_seq,
+ $sort_seq,
nkey, keys,
ninput, inputs,
noutput, outputs,
in_proc, out_proc );
}
- | SORT FILENAME[file] sort_keys sort_dup sort_seq error
- {
- yyerror("syntax error: SORT missing INPUT or OUTPUT phrase");
- }
+ | SORT FILENAME[file] sort_keys sort_dup sort_seq error
+ {
+ yyerror("syntax error: SORT missing INPUT or OUTPUT phrase");
+ }
sort_keys: sort_key {
@@ -7488,9 +7488,9 @@ sort_key: on forward_order key field_list %prec NAME
{
$$ = new sort_key_t( $forward_order, *$field_list );
}
- | on forward_order key %prec NAME
+ | on forward_order key %prec NAME
{
- field_list_t flist;
+ field_list_t flist;
$$ = new sort_key_t( $forward_order, flist );
}
;
@@ -7507,14 +7507,14 @@ sort_dup: %empty { $$ = false; }
;
sort_seq: %empty { $$ = NULL; }
| collating SEQUENCE is ctx_name[name]
- {
- symbol_elem_t *e = symbol_alphabet(PROGRAM, $name);
- if( !e ) {
- yyerrorv("syntax error: not an alphabet: '%s'", $name);
- $$ = NULL;
- }
- $$ = cbl_alphabet_of(e);
- }
+ {
+ symbol_elem_t *e = symbol_alphabet(PROGRAM, $name);
+ if( !e ) {
+ yyerrorv("syntax error: not an alphabet: '%s'", $name);
+ $$ = NULL;
+ }
+ $$ = cbl_alphabet_of(e);
+ }
;
sort_input: USING filenames
@@ -7582,17 +7582,17 @@ return_cond: RETURN return_body[body] return_outputs
current_sort_file = $body;
}
;
-return_end: %empty %prec RETURN
- | END_RETURN
- ;
+return_end: %empty %prec RETURN
+ | END_RETURN
+ ;
return_body: return_file
- {
- file_return_args.call_parser_return_start();
- }
- | return_file INTO scalar
{
- file_return_args.call_parser_return_start(*$scalar);
+ file_return_args.call_parser_return_start();
+ }
+ | return_file INTO scalar
+ {
+ file_return_args.call_parser_return_start(*$scalar);
}
;
@@ -7611,10 +7611,10 @@ return_file: filename
file_return_args.init($filename);
}
;
-return_outputs: return_output
+return_outputs: return_output
| return_outputs return_output // TODO: only 2, AT END and/or NOT AT END
;
-return_output: output_atend statements %prec RETURN
+return_output: output_atend statements %prec RETURN
;
output_atend: END {
@@ -7660,12 +7660,12 @@ inspect: INSPECT inspected TALLYING tallies
}
| INSPECT inspected TALLYING tallies REPLACING replacements
{
- if( is_constant($inspected->field) ) {
- auto name = nice_name_of($inspected->field);
- if( !name[0] ) name = "its argument";
- yyerrorv("error: INSPECT cannot write to %s", name);
- YYERROR;
- }
+ if( is_constant($inspected->field) ) {
+ auto name = nice_name_of($inspected->field);
+ if( !name[0] ) name = "its argument";
+ yyerrorv("error: INSPECT cannot write to %s", name);
+ YYERROR;
+ }
statement_begin(@1, INSPECT);
// All tallying is done before any replacing
ast_inspect( *$inspected, *$tallies );
@@ -7673,12 +7673,12 @@ inspect: INSPECT inspected TALLYING tallies
}
| INSPECT inspected REPLACING replacements
{
- if( is_constant($inspected->field) ) {
- auto name = nice_name_of($inspected->field);
- if( !name[0] ) name = "its argument";
- yyerrorv("error: INSPECT cannot write to %s", name);
- YYERROR;
- }
+ if( is_constant($inspected->field) ) {
+ auto name = nice_name_of($inspected->field);
+ if( !name[0] ) name = "its argument";
+ yyerrorv("error: INSPECT cannot write to %s", name);
+ YYERROR;
+ }
statement_begin(@1, INSPECT);
ast_inspect( *$inspected, *$replacements );
}
@@ -7686,12 +7686,12 @@ inspect: INSPECT inspected TALLYING tallies
TO alpha_val[replace_oper]
insp_mtquals[qual]
{
- if( is_constant($inspected->field) ) {
- auto name = nice_name_of($inspected->field);
- if( !name[0] ) name = "its argument";
- yyerrorv("error: INSPECT cannot write to %s", name);
- YYERROR;
- }
+ if( is_constant($inspected->field) ) {
+ auto name = nice_name_of($inspected->field);
+ if( !name[0] ) name = "its argument";
+ yyerrorv("error: INSPECT cannot write to %s", name);
+ YYERROR;
+ }
statement_begin(@1, INSPECT);
// IBM Format 4 does not show the qualifiers as optional, but
// they don't appear in Listing-15-1.
@@ -7936,15 +7936,15 @@ initialize: INITIALIZE vargs
| INITIALIZE vargs init_clause[ini]
{
statement_begin(@1, INITIALIZE);
- initialize_statement( $vargs->args, false, $ini->category,
- $ini->replacement, $ini->to_default );
+ initialize_statement( $vargs->args, false, $ini->category,
+ $ini->replacement, $ini->to_default );
delete $vargs;
}
| INITIALIZE vargs init_clause[ini] with FILLER_kw
{
statement_begin(@1, INITIALIZE);
- initialize_statement( $vargs->args, true, $ini->category,
- $ini->replacement, $ini->to_default );
+ initialize_statement( $vargs->args, true, $ini->category,
+ $ini->replacement, $ini->to_default );
delete $vargs;
}
| INITIALIZE vargs with FILLER_kw init_clause[ini]
@@ -7989,7 +7989,7 @@ init_value: init_replace then to DEFAULT
;
init_categora: init_category
- | ALL { $$ = data_category_all; }
+ | ALL { $$ = data_category_all; }
;
init_category: ALPHABETIC { $$ = data_alphabetic_e; }
| ALPHANUMERIC { $$ = data_alphanumeric_e; }
@@ -8025,18 +8025,18 @@ init_by: init_category data BY init_data
;
init_data: alpha_val
| NUMSTR {
- $$ = new_reference(new_literal($1.string, $1.radix));
- }
+ $$ = new_reference(new_literal($1.string, $1.radix));
+ }
;
call: call_impl end_call
| call_cond end_call
- ;
+ ;
call_impl: CALL call_body[body]
{
ffi_args_t *params = $body.using_params;
- if( yydebug && params ) params->dump();
+ if( yydebug && params ) params->dump();
size_t narg = params? params->elems.size() : 0;
cbl_ffi_arg_t args[1 + narg], *pargs = NULL;
if( narg > 0 ) {
@@ -8044,13 +8044,13 @@ call_impl: CALL call_body[body]
}
parser_call( *$body.ffi_name,
*$body.ffi_returning, narg, pargs, NULL, NULL, false );
- current.declaratives_evaluate();
+ current.declaratives_evaluate();
}
;
call_cond: CALL call_body[body] call_excepts[except]
{
ffi_args_t *params = $body.using_params;
- if( yydebug && params ) params->dump();
+ if( yydebug && params ) params->dump();
size_t narg = params? params->elems.size() : 0;
cbl_ffi_arg_t args[1 + narg], *pargs = NULL;
if( narg > 0 ) {
@@ -8059,14 +8059,14 @@ call_cond: CALL call_body[body] call_excepts[except]
parser_call( *$body.ffi_name,
*$body.ffi_returning, narg, pargs,
$except.on_error, $except.not_error, false );
- auto handled = ec_type_t( static_cast<size_t>(ec_program_e) |
- static_cast<size_t>(ec_external_e));
- current.declaratives_evaluate(handled);
+ auto handled = ec_type_t( static_cast<size_t>(ec_program_e) |
+ static_cast<size_t>(ec_external_e));
+ current.declaratives_evaluate(handled);
}
;
-end_call: %empty %prec CALL
- | END_CALL
- ;
+end_call: %empty %prec CALL
+ | END_CALL
+ ;
call_body: ffi_name
{ statement_begin(@1, CALL);
@@ -8095,39 +8095,39 @@ call_body: ffi_name
}
;
-entry: ENTRY LITERAL
- { statement_begin(@1, ENTRY);
- auto name = new_literal($2, quoted_e);
- parser_entry( name );
- }
+entry: ENTRY LITERAL
+ { statement_begin(@1, ENTRY);
+ auto name = new_literal($2, quoted_e);
+ parser_entry( name );
+ }
| ENTRY LITERAL USING parameters
{ statement_begin(@1, ENTRY);
- auto name = new_literal($2, quoted_e);
- ffi_args_t *params = $parameters;
+ auto name = new_literal($2, quoted_e);
+ ffi_args_t *params = $parameters;
size_t narg = params? params->elems.size() : 0;
cbl_ffi_arg_t args[1 + narg], *pargs = NULL;
if( narg > 0 ) {
pargs = use_list(params, args);
}
- parser_entry( name, narg, pargs );
+ parser_entry( name, narg, pargs );
}
- ;
+ ;
ffi_name: name
- {
- $$ = new cbl_refer_t($name);
- if( ! is_callable($name) ) {
- yyerrorv("error: CALL requires %s to be "
- "PROGRAM-POINTER or alphanumeric", $name->name);
- YYERROR;
- }
- if( $name->type == FldLiteralA ) {
- // Replace repository literal with aliased program's name.
- assert($name->parent > 0);
- auto& L = *cbl_label_of(symbol_at($name->parent));
- $$->field = new_literal(strlen(L.name), L.name, quoted_e);
- }
- }
+ {
+ $$ = new cbl_refer_t($name);
+ if( ! is_callable($name) ) {
+ yyerrorv("error: CALL requires %s to be "
+ "PROGRAM-POINTER or alphanumeric", $name->name);
+ YYERROR;
+ }
+ if( $name->type == FldLiteralA ) {
+ // Replace repository literal with aliased program's name.
+ assert($name->parent > 0);
+ auto& L = *cbl_label_of(symbol_at($name->parent));
+ $$->field = new_literal(strlen(L.name), L.name, quoted_e);
+ }
+ }
| LITERAL { $$ = new_reference(new_literal($1, quoted_e)); }
;
@@ -8160,7 +8160,7 @@ ffi_by_ref: scalar_arg[refer]
ffi_by_con: expr
{
- cbl_refer_t *r = new cbl_refer_t(*$1);
+ cbl_refer_t *r = new cbl_refer_t(*$1);
$$ = new cbl_ffi_arg_t(by_content_e, r);
}
| LITERAL
@@ -8179,11 +8179,11 @@ ffi_by_val: by_value_arg
{
$$ = new cbl_ffi_arg_t(by_value_e, $1);
}
- | cce_expr %prec NAME
- {
- auto r = new_reference(new_literal(string_of($1)));
- $$ = new cbl_ffi_arg_t(by_value_e, r);
- }
+ | cce_expr %prec NAME
+ {
+ auto r = new_reference(new_literal(string_of($1)));
+ $$ = new cbl_ffi_arg_t(by_value_e, r);
+ }
| ADDRESS OF scalar
{
$$ = new cbl_ffi_arg_t(by_value_e, $scalar, address_of_e);
@@ -8213,7 +8213,7 @@ call_excepts: call_excepts[a] call_except[b] statements %prec CALL
yyerror("duplicate NOT ON EXCEPTION clauses");
YYERROR;
}
- $$ = $a;
+ $$ = $a;
if( $b.on_error ) {
$$.on_error = $b.on_error;
assert($a.not_error);
@@ -8228,7 +8228,7 @@ call_excepts: call_excepts[a] call_except[b] statements %prec CALL
}
| call_except[a] statements %prec CALL
{
- $$ = $a;
+ $$ = $a;
assert( $a.on_error || $a.not_error );
assert( ! ($a.on_error && $a.not_error) );
cbl_label_t *tgt = $a.on_error? $a.on_error : $a.not_error;
@@ -8236,7 +8236,7 @@ call_excepts: call_excepts[a] call_except[b] statements %prec CALL
}
;
-call_except: EXCEPTION
+call_except: EXCEPTION
{
$$.not_error = NULL;
$$.on_error = label_add(LblArith,
@@ -8249,7 +8249,7 @@ call_except: EXCEPTION
std::swap($$.on_error, $$.not_error);
}
}
- | OVERFLOW
+ | OVERFLOW
{
$$.not_error = NULL;
$$.on_error = label_add(LblArith,
@@ -8267,14 +8267,14 @@ call_except: EXCEPTION
cancel: CANCEL ffi_names
{
statement_begin(@1, CANCEL);
- auto nprog = $ffi_names->refers.size();
- cbl_refer_t progs[nprog];
- parser_initialize_programs(nprog, $ffi_names->use_list(progs));
+ auto nprog = $ffi_names->refers.size();
+ cbl_refer_t progs[nprog];
+ parser_initialize_programs(nprog, $ffi_names->use_list(progs));
}
- ;
-ffi_names: ffi_name { $$ = new refer_list_t($1); }
- | ffi_names ffi_name { $$ = $1->push_back($2); }
- ;
+ ;
+ffi_names: ffi_name { $$ = new refer_list_t($1); }
+ | ffi_names ffi_name { $$ = $1->push_back($2); }
+ ;
alter: ALTER { statement_begin(@1, ALTER); } alter_tgts
;
@@ -8287,10 +8287,10 @@ 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));
- if( prog->initial ) {
- yyerrorv("unimplemented: %s will not be reinitialized", $old->name);
- }
+ auto prog = cbl_label_of( symbol_at(symbol_elem_of($old)->program));
+ if( prog->initial ) {
+ yyerrorv("unimplemented: %s will not be reinitialized", $old->name);
+ }
}
;
@@ -8327,18 +8327,18 @@ go_to: GOTO labels[args]
}
;
-resume: RESUME NEXT STATEMENT
- {
+resume: RESUME NEXT STATEMENT
+ {
statement_begin(@1, RESUME);
- parser_clear_exception();
- }
- | RESUME label_1[tgt]
+ parser_clear_exception();
+ }
+ | RESUME label_1[tgt]
{
statement_begin(@1, RESUME);
- parser_clear_exception();
+ parser_clear_exception();
parser_goto( cbl_refer_t(), 1, &$tgt );
}
- ;
+ ;
labels: label_1 { $$ = new Label_list_t($1); }
| labels label_1 { $$ = $1->push_back($2); }
@@ -8381,14 +8381,14 @@ string: string_impl end_string
string_impl: STRING_kw string_body[body]
{
stringify($body.inputs, *$body.into.first, *$body.into.second);
- current.declaratives_evaluate(ec_none_e);
+ current.declaratives_evaluate(ec_none_e);
}
;
string_cond: STRING_kw string_body[body] on_overflows[over]
{
stringify($body.inputs, *$body.into.first, *$body.into.second,
$over.on_error, $over.not_error);
- current.declaratives_evaluate(ec_overflow_e);
+ current.declaratives_evaluate(ec_overflow_e);
}
;
end_string: %empty %prec LITERAL
@@ -8410,14 +8410,14 @@ str_delimiteds: str_delimited
}
| str_delimiteds str_delimited[input]
{
- // matching delimiters (or none) adds to the list
- refer_marked_list_t& marked = $1->lists.back();
- if( !marked.marker ) {
- marked.push_on($input.delimiter, $input.input);
- } else { // start a new list
- $1->push_back( refer_marked_list_t($input.delimiter,
- $input.input) );
- }
+ // matching delimiters (or none) adds to the list
+ refer_marked_list_t& marked = $1->lists.back();
+ if( !marked.marker ) {
+ marked.push_on($input.delimiter, $input.input);
+ } else { // start a new list
+ $1->push_back( refer_marked_list_t($input.delimiter,
+ $input.input) );
+ }
}
;
@@ -8426,12 +8426,12 @@ str_delimited: str_input DELIMITED by str_size
$$.input = $str_input;
$$.delimiter = $str_size;
}
- | str_input
+ | str_input
{
$$.input = $str_input;
$$.delimiter = NULL;
}
- ;
+ ;
str_input: scalar
| LITERAL { $$ = new_reference(new_literal($1, quoted_e)); }
@@ -8439,7 +8439,7 @@ str_input: scalar
{
$$ = new_reference(constant_of(constant_index($1)));
}
- | intrinsic_call
+ | intrinsic_call
;
str_size: SIZE { $$ = new_reference(NULL); }
@@ -8527,14 +8527,14 @@ end_unstring: %empty %prec UNSTRING
unstring_impl: UNSTRING unstring_body[body]
{
unstringify( *$body.input, $body.delimited, $body.into );
- current.declaratives_evaluate(ec_none_e);
+ current.declaratives_evaluate(ec_none_e);
}
;
unstring_cond: UNSTRING unstring_body[body] on_overflows[over]
{
unstringify( *$body.input, $body.delimited, $body.into,
$over.on_error, $over.not_error );
- current.declaratives_evaluate(ec_overflow_e);
+ current.declaratives_evaluate(ec_overflow_e);
}
;
@@ -8545,7 +8545,7 @@ unstring_body: unstring_src[src] uns_delimited INTO uns_into[into]
$$.delimited = $uns_delimited;
$$.into = $into;
}
-unstring_src: scalar
+unstring_src: scalar
| intrinsic_call
| LITERAL
{
@@ -8602,35 +8602,35 @@ uns_tgt: scalar[tgt]
}
| scalar[tgt] COUNT in scalar[count]
{
- if( ! $count->field->is_integer() ) {
- yyerrorv("error: COUNT %s must be integer type",
- $count->field->name);
- }
- if( $count->field->has_attr(scaled_e) ) {
- yyerrorv("error: COUNT %s may not be P scaled",
- $count->field->name);
- }
+ if( ! $count->field->is_integer() ) {
+ yyerrorv("error: COUNT %s must be integer type",
+ $count->field->name);
+ }
+ if( $count->field->has_attr(scaled_e) ) {
+ yyerrorv("error: COUNT %s may not be P scaled",
+ $count->field->name);
+ }
$$ = new unstring_tgt_t($tgt, NULL, $count);
}
| scalar[tgt] DELIMITER in scalar[delim] COUNT in scalar[count]
{
- if( ! $count->field->is_integer() ) {
- yyerrorv("error: COUNT %s must be integer type",
- $count->field->name);
- }
- if( $count->field->has_attr(scaled_e) ) {
- yyerrorv("error: COUNT %s may not be P scaled",
- $count->field->name);
- }
+ if( ! $count->field->is_integer() ) {
+ yyerrorv("error: COUNT %s must be integer type",
+ $count->field->name);
+ }
+ if( $count->field->has_attr(scaled_e) ) {
+ yyerrorv("error: COUNT %s may not be P scaled",
+ $count->field->name);
+ }
$$ = new unstring_tgt_t($tgt, $delim, $count);
}
;
/* intrinsics */
intrinsic_call: function intrinsic {
- $$ = new_reference($intrinsic);
- $$->field->attr |= constant_e;
- }
+ $$ = new_reference($intrinsic);
+ $$->field->attr |= constant_e;
+ }
| function intrinsic refmod[ref]
{
if( $ref.from->is_reference() || $ref.len->is_reference() ) {
@@ -8645,100 +8645,100 @@ intrinsic_call: function intrinsic {
}
cbl_span_t span( $ref.from->field, $ref.len->field );
$$ = new cbl_refer_t($intrinsic, span);
- $$->field->attr |= constant_e;
- }
- ;
-function: %empty %prec FUNCTION
- {
- statement_begin(@$, FUNCTION);
- }
- | FUNCTION
- {
- statement_begin(@1, FUNCTION);
- }
- ;
-
-function_udf: FUNCTION_UDF '(' arg_list[args] ')' {
- auto L = cbl_label_of(symbol_at($1));
- cbl_field_t *returning_as = symbol_valid_udf_args( $1, $args->refers );
- if( ! returning_as ) YYERROR;
- $$ = new_temporary_clone(returning_as);
- auto narg = $args->refers.size();
- cbl_ffi_arg_t args[narg];
- std::transform( $args->refers.begin(), $args->refers.end(),
- args, []( cbl_refer_t& arg ) {
- auto ar = new cbl_refer_t(arg);
- return cbl_ffi_arg_t(ar); } );
-
- auto name = new_literal(strlen(L->name), L->name, quoted_e);
- parser_call( name, $$, narg, args, NULL, NULL, true );
- }
- | FUNCTION_UDF_0 {
- static const size_t narg = 0;
- static cbl_ffi_arg_t *args = NULL;
-
- auto L = cbl_label_of(symbol_at($1));
- cbl_field_t *returning_as = symbol_valid_udf_args( $1 );
- if( ! returning_as ) YYERROR;
- $$ = new_temporary_clone(returning_as);
-
- auto name = new_literal(strlen(L->name), L->name, quoted_e);
- parser_call( name, $$, narg, args, NULL, NULL, true );
- }
- ;
-
- /*
- * The scanner returns a function-token (e.g. NUMVAL) if it was
- * preceded by FUNCTION, or if the name is in the program's
- * function repository. Else it returns NAME, because it looks
- * like a user-defined name (possibly a data item). If the user
- * attempts to use an intrinsic function without using
- * REPOSITORY or FUNCTION, the NAME results in a syntax error.
- *
- * Function arguments may be variables or literals or
- * functions, and string-valued functions accept a refmod. In
- * addition to "scalar", we have this inconsistent set:
- * var: [ALL] LITERAL, NUMSTR, instrinsic, or scalar
- * num_operand: signed NUMSTR/ZERO, instrinsic, or scalar
- * alpahaval: LITERAL, reserved_value, instrinsic, or scalar
- * Probably any numeric argument could be an expression.
- */
-intrinsic: function_udf
- | intrinsic0
+ $$->field->attr |= constant_e;
+ }
+ ;
+function: %empty %prec FUNCTION
+ {
+ statement_begin(@$, FUNCTION);
+ }
+ | FUNCTION
+ {
+ statement_begin(@1, FUNCTION);
+ }
+ ;
+
+function_udf: FUNCTION_UDF '(' arg_list[args] ')' {
+ auto L = cbl_label_of(symbol_at($1));
+ cbl_field_t *returning_as = symbol_valid_udf_args( $1, $args->refers );
+ if( ! returning_as ) YYERROR;
+ $$ = new_temporary_clone(returning_as);
+ auto narg = $args->refers.size();
+ cbl_ffi_arg_t args[narg];
+ std::transform( $args->refers.begin(), $args->refers.end(),
+ args, []( cbl_refer_t& arg ) {
+ auto ar = new cbl_refer_t(arg);
+ return cbl_ffi_arg_t(ar); } );
+
+ auto name = new_literal(strlen(L->name), L->name, quoted_e);
+ parser_call( name, $$, narg, args, NULL, NULL, true );
+ }
+ | FUNCTION_UDF_0 {
+ static const size_t narg = 0;
+ static cbl_ffi_arg_t *args = NULL;
+
+ auto L = cbl_label_of(symbol_at($1));
+ cbl_field_t *returning_as = symbol_valid_udf_args( $1 );
+ if( ! returning_as ) YYERROR;
+ $$ = new_temporary_clone(returning_as);
+
+ auto name = new_literal(strlen(L->name), L->name, quoted_e);
+ parser_call( name, $$, narg, args, NULL, NULL, true );
+ }
+ ;
+
+ /*
+ * The scanner returns a function-token (e.g. NUMVAL) if it was
+ * preceded by FUNCTION, or if the name is in the program's
+ * function repository. Else it returns NAME, because it looks
+ * like a user-defined name (possibly a data item). If the user
+ * attempts to use an intrinsic function without using
+ * REPOSITORY or FUNCTION, the NAME results in a syntax error.
+ *
+ * Function arguments may be variables or literals or
+ * functions, and string-valued functions accept a refmod. In
+ * addition to "scalar", we have this inconsistent set:
+ * var: [ALL] LITERAL, NUMSTR, instrinsic, or scalar
+ * num_operand: signed NUMSTR/ZERO, instrinsic, or scalar
+ * alpahaval: LITERAL, reserved_value, instrinsic, or scalar
+ * Probably any numeric argument could be an expression.
+ */
+intrinsic: function_udf
+ | intrinsic0
| intrinsic_v '(' arg_list[args] ')' {
location_set(@1);
size_t n = $args->size();
assert(n > 0);
cbl_refer_t args[n];
- std::copy( $args->begin(), $args->end(), args );
- cbl_refer_t *p = intrinsic_inconsistent_parameter(n, args);
- if( p != NULL ) {
- yyerrorv( "syntax error: FUNCTION %s has "
- "inconsistent parameter type %zu ('%s')",
- keyword_str($1), p - args, name_of(p->field) );
- YYERROR;
- }
- $$ = is_numeric(args[0].field)?
- new_tempnumeric_float() :
- new_alphanumeric(args[0].field->data.capacity);
+ std::copy( $args->begin(), $args->end(), args );
+ cbl_refer_t *p = intrinsic_inconsistent_parameter(n, args);
+ if( p != NULL ) {
+ yyerrorv( "syntax error: FUNCTION %s has "
+ "inconsistent parameter type %zu ('%s')",
+ keyword_str($1), p - args, name_of(p->field) );
+ YYERROR;
+ }
+ $$ = is_numeric(args[0].field)?
+ new_tempnumeric_float() :
+ new_alphanumeric(args[0].field->data.capacity);
parser_intrinsic_callv( $$, intrinsic_cname($1), n, args );
}
| PRESENT_VALUE '(' expr_list[args] ')'
- {
- static char s[] = "__gg__present_value";
+ {
+ static char s[] = "__gg__present_value";
location_set(@1);
$$ = new_tempnumeric_float();
size_t n = $args->size();
assert(n > 0);
- if( n < 2 ) {
- yyerrorv("PRESENT VALUE requires 2 parameters");
- YYERROR;
- }
+ if( n < 2 ) {
+ yyerrorv("PRESENT VALUE requires 2 parameters");
+ YYERROR;
+ }
cbl_refer_t args[n];
parser_intrinsic_callv( $$, s, n, $args->use_list(args) );
- }
+ }
| BIT_OF '(' expr[r1] ')' {
location_set(@1);
@@ -8764,16 +8764,16 @@ intrinsic: function_udf
if( ! intrinsic_call_2($$, DISPLAY_OF, $r1, $r2) ) YYERROR;
}
- | EXCEPTION_FILE filename {
+ | EXCEPTION_FILE filename {
location_set(@1);
$$ = new_alphanumeric(256);
parser_exception_file( $$, $filename );
}
| FORMATTED_DATE '(' DATE_FMT[r1] expr[r2] ')' {
- location_set(@1);
+ location_set(@1);
$$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATE);
- auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
+ auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
if( ! intrinsic_call_2($$, FORMATTED_DATE, r1, $r2) ) YYERROR;
}
@@ -8785,7 +8785,7 @@ intrinsic: function_udf
auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
static cbl_refer_t r3(literally_zero);
if( ! intrinsic_call_4($$, FORMATTED_DATETIME,
- r1, $r2, $r3, &r3) ) YYERROR;
+ r1, $r2, $r3, &r3) ) YYERROR;
}
| FORMATTED_DATETIME '(' DATETIME_FMT[r1] expr[r2]
expr[r3] expr[r4] ')' {
@@ -8796,9 +8796,9 @@ intrinsic: function_udf
r1, $r2, $r3, $r4) ) YYERROR;
}
| FORMATTED_DATETIME '(' error ')' {
- yyerror("error: FORMATTED_DATETIME: invalid parameter value");
- YYERROR;
- }
+ yyerror("error: FORMATTED_DATETIME: invalid parameter value");
+ YYERROR;
+ }
| FORMATTED_TIME '(' TIME_FMT[r1] expr[r2]
expr[r3] ')' {
location_set(@1);
@@ -8888,7 +8888,7 @@ intrinsic: function_udf
location_set(@1);
$$ = new_tempnumeric();
parser_intrinsic_numval_c( $$, *$r1, $r2.is_locale,
- *$r2.arg2, $anycase );
+ *$r2.arg2, $anycase );
}
| ORD '(' alpha_val[r1] ')'
{
@@ -8909,20 +8909,20 @@ intrinsic: function_udf
if( ! intrinsic_call_1($$, RANDOM, $r1) ) YYERROR;
}
- | SUBSTITUTE '(' varg[r1] subst_inputs[inputs] ')' {
+ | SUBSTITUTE '(' varg[r1] subst_inputs[inputs] ')' {
location_set(@1);
$$ = new_alphanumeric(64);
- auto narg = $inputs->size();
- cbl_substitute_t args[narg];
- std::transform( $inputs->begin(), $inputs->end(), args,
- []( const substitution_t& arg ) {
- cbl_substitute_t output( arg.anycase,
- char(arg.first_last),
- arg.orig,
- arg.replacement );
- return output; } );
+ auto narg = $inputs->size();
+ cbl_substitute_t args[narg];
+ std::transform( $inputs->begin(), $inputs->end(), args,
+ []( const substitution_t& arg ) {
+ cbl_substitute_t output( arg.anycase,
+ char(arg.first_last),
+ arg.orig,
+ arg.replacement );
+ return output; } );
- parser_intrinsic_subst($$, *$r1, narg, args);
+ parser_intrinsic_subst($$, *$r1, narg, args);
}
@@ -8930,31 +8930,31 @@ intrinsic: function_udf
location_set(@1);
$$ = new_tempnumeric();
parser_intrinsic_numval_c( $$, *$r1, $r2.is_locale,
- *$r2.arg2, $anycase, true );
+ *$r2.arg2, $anycase, true );
}
| TRIM '(' error ')' {
- yyerrorv("error: invalid TRIM argument");
- YYERROR;
- }
+ yyerrorv("error: invalid TRIM argument");
+ YYERROR;
+ }
| TRIM '(' expr[r1] trim_trailing ')'
{
location_set(@1);
- switch( $r1->field->type ) {
- case FldGroup:
- case FldAlphanumeric:
- case FldLiteralA:
- case FldAlphaEdited:
- case FldNumericEdited:
- break; // alphanumeric OK
- default:
- // BLANK WHEN ZERO implies numeric-edited, so OK
- if( $r1->field->has_attr(blank_zero_e) ) {
- break;
- }
- yyerrorv("error: TRIM argument must be alphanumeric");
- YYERROR;
- break;
- }
+ switch( $r1->field->type ) {
+ case FldGroup:
+ case FldAlphanumeric:
+ case FldLiteralA:
+ case FldAlphaEdited:
+ case FldNumericEdited:
+ break; // alphanumeric OK
+ default:
+ // BLANK WHEN ZERO implies numeric-edited, so OK
+ if( $r1->field->has_attr(blank_zero_e) ) {
+ break;
+ }
+ yyerrorv("error: TRIM argument must be alphanumeric");
+ YYERROR;
+ break;
+ }
$$ = new_alphanumeric($r1->field->data.capacity);
cbl_refer_t * how = new_reference($trim_trailing);
if( ! intrinsic_call_2($$, TRIM, $r1, how) ) YYERROR;
@@ -9001,7 +9001,7 @@ intrinsic: function_udf
}
if( $1 == NUMVAL_F ) {
if( is_literal($r1->field) ) {
- _Float128 output __attribute__ ((__unused__));
+ _Float128 output __attribute__ ((__unused__));
auto input = $r1->field->data.initial;
auto local = strdup(input), pend = local;
if( !local ) { warn("%s: %s", __func__, input); return false; }
@@ -9010,8 +9010,8 @@ intrinsic: function_udf
output = strtof128(local, &pend);
// bad if strtof128 could not convert input
if( *pend != '\0' ) {
- yyerrorv("error: '%s' is not a numeric string", input);
- }
+ yyerrorv("error: '%s' is not a numeric string", input);
+ }
}
}
if( ! intrinsic_call_1($$, $1, $r1) ) YYERROR;
@@ -9025,129 +9025,129 @@ intrinsic: function_udf
}
| DATE_TO_YYYYMMDD '(' expr[r1] ')'
- {
+ {
location_set(@1);
static auto r2 = new_reference(FldNumericDisplay, "50");
- static auto one = new_literal("1");
- static auto four = new_literal("4");
- cbl_span_t year(one, four);
+ static auto one = new_literal("1");
+ static auto four = new_literal("4");
+ cbl_span_t year(one, four);
auto r3 = new_reference(new_alphanumeric(21));
- r3->refmod = year;
+ r3->refmod = year;
- parser_intrinsic_call_0( r3->field, "__gg__current_date" );
+ parser_intrinsic_call_0( r3->field, "__gg__current_date" );
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric();
if( ! intrinsic_call_3($$, DATE_TO_YYYYMMDD,
- $r1, r2, r3) ) YYERROR;
+ $r1, r2, r3) ) YYERROR;
}
| DATE_TO_YYYYMMDD '(' expr[r1] expr[r2] ')'
- {
+ {
location_set(@1);
- static auto one = new_literal("1");
- static auto four = new_literal("4");
- cbl_span_t year(one, four);
+ static auto one = new_literal("1");
+ static auto four = new_literal("4");
+ cbl_span_t year(one, four);
auto r3 = new_reference(new_alphanumeric(21));
- r3->refmod = year;
+ r3->refmod = year;
- parser_intrinsic_call_0( r3->field, "__gg__current_date" );
+ parser_intrinsic_call_0( r3->field, "__gg__current_date" );
$$ = new_tempnumeric();
if( ! intrinsic_call_3($$, DATE_TO_YYYYMMDD,
- $r1, $r2, r3) ) YYERROR;
+ $r1, $r2, r3) ) YYERROR;
}
| DATE_TO_YYYYMMDD '(' expr[r1]
- expr[r2] expr[r3] ')'
- {
+ expr[r2] expr[r3] ')'
+ {
location_set(@1);
$$ = new_tempnumeric();
if( ! intrinsic_call_3($$, DATE_TO_YYYYMMDD,
- $r1, $r2, $r3) ) YYERROR;
+ $r1, $r2, $r3) ) YYERROR;
}
| DAY_TO_YYYYDDD '(' expr[r1] ')'
- {
+ {
location_set(@1);
static auto r2 = new_reference(FldNumericDisplay, "50");
- static auto one = new_literal("1");
- static auto four = new_literal("4");
- cbl_span_t year(one, four);
+ static auto one = new_literal("1");
+ static auto four = new_literal("4");
+ cbl_span_t year(one, four);
auto r3 = new_reference(new_alphanumeric(21));
- r3->refmod = year;
+ r3->refmod = year;
- parser_intrinsic_call_0( r3->field, "__gg__current_date" );
+ parser_intrinsic_call_0( r3->field, "__gg__current_date" );
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric();
if( ! intrinsic_call_3($$, DAY_TO_YYYYDDD,
- $r1, r2, r3) ) YYERROR;
+ $r1, r2, r3) ) YYERROR;
}
| DAY_TO_YYYYDDD '(' expr[r1] expr[r2] ')'
- {
+ {
location_set(@1);
- static auto one = new_literal("1");
- static auto four = new_literal("4");
- cbl_span_t year(one, four);
+ static auto one = new_literal("1");
+ static auto four = new_literal("4");
+ cbl_span_t year(one, four);
auto r3 = new_reference(new_alphanumeric(21));
- r3->refmod = year;
+ r3->refmod = year;
- parser_intrinsic_call_0( r3->field, "__gg__current_date" );
+ parser_intrinsic_call_0( r3->field, "__gg__current_date" );
$$ = new_tempnumeric();
if( ! intrinsic_call_3($$, DAY_TO_YYYYDDD,
- $r1, $r2, r3) ) YYERROR;
+ $r1, $r2, r3) ) YYERROR;
}
| DAY_TO_YYYYDDD '(' expr[r1]
- expr[r2] expr[r3] ')'
- {
+ expr[r2] expr[r3] ')'
+ {
location_set(@1);
$$ = new_tempnumeric();
if( ! intrinsic_call_3($$, DAY_TO_YYYYDDD,
- $r1, $r2, $r3) ) YYERROR;
+ $r1, $r2, $r3) ) YYERROR;
}
| YEAR_TO_YYYY '(' expr[r1] ')'
- {
+ {
location_set(@1);
static auto r2 = new_reference(new_literal("50", decimal_e));
- static auto one = new_literal("1");
- static auto four = new_literal("4");
- cbl_span_t year(one, four);
+ static auto one = new_literal("1");
+ static auto four = new_literal("4");
+ cbl_span_t year(one, four);
auto r3 = new_reference(new_alphanumeric(21));
- r3->refmod = year;
+ r3->refmod = year;
- parser_intrinsic_call_0( r3->field, "__gg__current_date" );
+ parser_intrinsic_call_0( r3->field, "__gg__current_date" );
- $$ = new_tempnumeric();
+ $$ = new_tempnumeric();
if( ! intrinsic_call_3($$, YEAR_TO_YYYY,
- $r1, r2, r3) ) YYERROR;
+ $r1, r2, r3) ) YYERROR;
}
| YEAR_TO_YYYY '(' expr[r1] expr[r2] ')'
- {
+ {
location_set(@1);
- static auto one = new_literal("1");
- static auto four = new_literal("4");
- cbl_span_t year(one, four);
+ static auto one = new_literal("1");
+ static auto four = new_literal("4");
+ cbl_span_t year(one, four);
auto r3 = new_reference(new_alphanumeric(21));
- r3->refmod = year;
+ r3->refmod = year;
- parser_intrinsic_call_0( r3->field, "__gg__current_date" );
+ parser_intrinsic_call_0( r3->field, "__gg__current_date" );
$$ = new_tempnumeric();
if( ! intrinsic_call_3($$, YEAR_TO_YYYY,
- $r1, $r2, r3) ) YYERROR;
+ $r1, $r2, r3) ) YYERROR;
}
| YEAR_TO_YYYY '(' expr[r1]
- expr[r2] expr[r3] ')'
- {
+ expr[r2] expr[r3] ')'
+ {
location_set(@1);
$$ = new_tempnumeric();
if( ! intrinsic_call_3($$, YEAR_TO_YYYY,
- $r1, $r2, $r3) ) YYERROR;
+ $r1, $r2, $r3) ) YYERROR;
}
| intrinsic_N2 '(' expr[r1] expr[r2] ')'
@@ -9174,29 +9174,29 @@ intrinsic: function_udf
$$ = new_alphanumeric($r1->field->data.capacity);
if( ! intrinsic_call_2($$, $1, $r1, $r2) ) YYERROR;
}
- | intrinsic_locale
+ | intrinsic_locale
;
-numval_locale: %empty {
- $$.is_locale = false;
- $$.arg2 = cbl_refer_t::empty();
- }
- | LOCALE NAME { $$.is_locale = true; $$.arg2 = NULL;
- yyerror("unimplemented: NUMVAL_C LOCALE"); YYERROR;
- }
- | varg { $$.is_locale = false; $$.arg2 = $1; }
- ;
+numval_locale: %empty {
+ $$.is_locale = false;
+ $$.arg2 = cbl_refer_t::empty();
+ }
+ | LOCALE NAME { $$.is_locale = true; $$.arg2 = NULL;
+ yyerror("unimplemented: NUMVAL_C LOCALE"); YYERROR;
+ }
+ | varg { $$.is_locale = false; $$.arg2 = $1; }
+ ;
-subst_inputs: subst_input { $$ = new substitutions_t; $$->push_back($1); }
- | subst_inputs subst_input { $$ = $1; $$->push_back($2); }
- ;
-subst_input: anycase first_last varg[v1] varg[v2] {
- $$.init( $anycase, $first_last, $v1, $v2 );
- }
- ;
+subst_inputs: subst_input { $$ = new substitutions_t; $$->push_back($1); }
+ | subst_inputs subst_input { $$ = $1; $$->push_back($2); }
+ ;
+subst_input: anycase first_last varg[v1] varg[v2] {
+ $$.init( $anycase, $first_last, $v1, $v2 );
+ }
+ ;
intrinsic_locale:
- LOCALE_COMPARE '(' varg[r1] varg[r2] ')'
+ LOCALE_COMPARE '(' varg[r1] varg[r2] ')'
{
location_set(@1);
$$ = new_alphanumeric($r1->field->data.capacity);
@@ -9217,7 +9217,7 @@ intrinsic_locale:
cbl_refer_t dummy = {};
if( ! intrinsic_call_2($$, LOCALE_DATE, $r1, &dummy) ) YYERROR;
}
- | LOCALE_DATE '(' varg[r1] varg[r2] ')'
+ | LOCALE_DATE '(' varg[r1] varg[r2] ')'
{
location_set(@1);
$$ = new_alphanumeric($r1->field->data.capacity);
@@ -9230,7 +9230,7 @@ intrinsic_locale:
cbl_refer_t dummy = {};
if( ! intrinsic_call_2($$, LOCALE_TIME, $r1, &dummy) ) YYERROR;
}
- | LOCALE_TIME '(' varg[r1] varg[r2] ')'
+ | LOCALE_TIME '(' varg[r1] varg[r2] ')'
{
location_set(@1);
$$ = new_alphanumeric($r1->field->data.capacity);
@@ -9249,7 +9249,7 @@ intrinsic_locale:
$$ = new_alphanumeric($r1->field->data.capacity);
if( ! intrinsic_call_2($$, LOCALE_TIME_FROM_SECONDS, $r1, $r2) ) YYERROR;
}
- ;
+ ;
lopper_case: LOWER_CASE { $$ = LOWER_CASE; }
| UPPER_CASE { $$ = UPPER_CASE; }
@@ -9271,33 +9271,33 @@ intrinsic0: CURRENT_DATE {
parser_intrinsic_call_0( $$, "__gg__e" );
}
- | EXCEPTION_FILE_N {
+ | EXCEPTION_FILE_N {
location_set(@1);
$$ = new_alphanumeric(256);
intrinsic_call_0( $$, EXCEPTION_FILE_N );
}
- | EXCEPTION_FILE {
+ | EXCEPTION_FILE {
location_set(@1);
$$ = new_alphanumeric(256);
parser_exception_file( $$ );
}
- | EXCEPTION_LOCATION_N {
+ | EXCEPTION_LOCATION_N {
location_set(@1);
$$ = new_alphanumeric(256);
intrinsic_call_0( $$, EXCEPTION_LOCATION_N );
}
- | EXCEPTION_LOCATION {
+ | EXCEPTION_LOCATION {
location_set(@1);
$$ = new_alphanumeric(256);
intrinsic_call_0( $$, EXCEPTION_LOCATION );
}
- | EXCEPTION_STATEMENT {
+ | EXCEPTION_STATEMENT {
location_set(@1);
$$ = new_alphanumeric(63);
intrinsic_call_0( $$, EXCEPTION_STATEMENT );
}
- | EXCEPTION_STATUS {
+ | EXCEPTION_STATUS {
location_set(@1);
$$ = new_alphanumeric(31);
intrinsic_call_0( $$, EXCEPTION_STATUS );
@@ -9399,13 +9399,13 @@ all: %empty { $$ = false; }
| ALL { $$ = true; }
;
-anycase: %empty { $$ = false; }
- | ANYCASE { $$ = true; }
- ;
+anycase: %empty { $$ = false; }
+ | ANYCASE { $$ = true; }
+ ;
as: %empty
| AS
- ;
+ ;
at: %empty
| AT
@@ -9439,18 +9439,18 @@ file: %empty
| FILE_KW
;
-first_last: %empty { $$ = 0; }
- | FIRST { $$ = 'F'; }
- | LAST { $$ = 'L'; }
- ;
+first_last: %empty { $$ = 0; }
+ | FIRST { $$ = 'F'; }
+ | LAST { $$ = 'L'; }
+ ;
-is_global: %empty %prec GLOBAL { $$ = false; }
- | is GLOBAL { $$ = true; }
- ;
+is_global: %empty %prec GLOBAL { $$ = false; }
+ | is GLOBAL { $$ = true; }
+ ;
-global: %empty %prec GLOBAL { $$ = false; }
- | GLOBAL { $$ = true; }
- ;
+global: %empty %prec GLOBAL { $$ = false; }
+ | GLOBAL { $$ = true; }
+ ;
initial: %empty { $$ = 0; }
| INITIAL_kw { $$ = INITIAL_kw; }
@@ -9534,9 +9534,9 @@ with: %empty
/*
* CDF: Compiler-directing Facility
*/
-cdf_empty: %empty
- | cdf
- ;
+cdf_empty: %empty
+ | cdf
+ ;
cdf: cdf_none
| cdf_library
| cdf_listing
@@ -9552,107 +9552,107 @@ cdf_basis: BASIS NAME /* BASIS is never passed to the parser. */
| BASIS LITERAL
;
-cdf_use: %empty
- | USE DEBUGGING on labels
+cdf_use: %empty
+ | USE DEBUGGING on labels
{
- if( ! current.declarative_section_name() ) {
- yyerror("syntax error: USE valid only in DECLARATIVES");
- YYERROR;
- }
+ if( ! current.declarative_section_name() ) {
+ yyerror("syntax error: USE valid only in DECLARATIVES");
+ YYERROR;
+ }
std::for_each($labels->elems.begin(), $labels->elems.end(),
add_debugging_declarative);
}
| USE DEBUGGING on ALL PROCEDURES
{
- if( ! current.declarative_section_name() ) {
- yyerror("syntax error: USE valid only in DECLARATIVES");
- YYERROR;
- }
+ if( ! current.declarative_section_name() ) {
+ yyerror("syntax error: USE valid only in DECLARATIVES");
+ YYERROR;
+ }
static const cbl_label_t all = {
- LblNone, 0,0, false,false,false, 0,0, ":all:" };
+ LblNone, 0,0, false,false,false, 0,0, ":all:" };
add_debugging_declarative(&all);
}
- | USE globally mistake procedure on culprits
- { // Format 1
- if( ! current.declarative_section_name() ) {
- yyerror("syntax error: USE valid only in DECLARATIVES");
- YYERROR;
- }
- bool global = $globally == GLOBAL;
- std::list<size_t> files;
- if( $culprits.fnames ) {
- auto& culprits = $culprits.fnames->files;
- std::transform( culprits.begin(), culprits.end(),
- std::back_inserter(files),
- file_list_t::symbol_index );
- }
- cbl_declarative_t declarative(current.declarative_section(),
- ec_all_e, files,
- $culprits.io_mode, global);
- current.declaratives.add(declarative);
- }
- | USE cdf_use_excepts // Format 3: AFTER swallowed by lexer
- {
- if( ! current.declarative_section_name() ) {
- yyerror("syntax error: USE valid only in DECLARATIVES");
- YYERROR;
- }
- }
- ;
+ | USE globally mistake procedure on culprits
+ { // Format 1
+ if( ! current.declarative_section_name() ) {
+ yyerror("syntax error: USE valid only in DECLARATIVES");
+ YYERROR;
+ }
+ bool global = $globally == GLOBAL;
+ std::list<size_t> files;
+ if( $culprits.fnames ) {
+ auto& culprits = $culprits.fnames->files;
+ std::transform( culprits.begin(), culprits.end(),
+ std::back_inserter(files),
+ file_list_t::symbol_index );
+ }
+ cbl_declarative_t declarative(current.declarative_section(),
+ ec_all_e, files,
+ $culprits.io_mode, global);
+ current.declaratives.add(declarative);
+ }
+ | USE cdf_use_excepts // Format 3: AFTER swallowed by lexer
+ {
+ if( ! current.declarative_section_name() ) {
+ yyerror("syntax error: USE valid only in DECLARATIVES");
+ YYERROR;
+ }
+ }
+ ;
cdf_use_excepts:
- cdf_use_except
- | cdf_use_excepts cdf_use_except
- ;
-cdf_use_except: EC NAME cdf_use_files[files]
- {
- auto ec = ec_type_of($NAME);
- if( ec == ec_none_e ) {
- yyerrorv("syntax error: not an "
- "EXCEPTION CONDITION: %s", $NAME);
- YYERROR;
- }
- std::list<size_t> files;
- if( $files ) {
- if( ec_io_e != (ec_io_e & ec) ) {
- yyerrorv("syntax error: not an "
- "I-O EXCEPTION CONDITION: %s", $NAME);
- YYERROR;
- }
- auto& culprits = $files->files;
- std::transform( culprits.begin(), culprits.end(),
- std::back_inserter(files),
- file_list_t::symbol_index );
- }
-
- cbl_declarative_t declarative(current.declarative_section(),
- ec, files, file_mode_none_e);
- // Check for duplicates, but keep going.
- current.declaratives.add(declarative);
- }
- ;
-cdf_use_files: %empty { $$ = NULL; }
- | FILE_KW filenames { $$ = $2; }
- ;
-
-culprits: filenames { $$.fnames = $1; $$.io_mode = file_mode_none_e; }
- | INPUT { $$.fnames = NULL; $$.io_mode = file_mode_input_e; }
- | OUTPUT { $$.fnames = NULL; $$.io_mode = file_mode_output_e; }
- | IO { $$.fnames = NULL; $$.io_mode = file_mode_io_e; }
- | EXTEND { $$.fnames = NULL; $$.io_mode = file_mode_extend_e; }
- ;
-globally: global { $$ = $1? GLOBAL : 0; }
- | global STANDARD { $$ = $1? GLOBAL : STANDARD; }
- | global AFTER { $$ = $1? GLOBAL : 0; }
- | global AFTER STANDARD { $$ = $1? GLOBAL : STANDARD; }
- ;
-mistake: EXCEPTION { $$ = EXCEPTION; }
- | ERROR { $$ = ERROR; }
- ;
-procedure: %empty
- | PROCEDURE
- ;
+ cdf_use_except
+ | cdf_use_excepts cdf_use_except
+ ;
+cdf_use_except: EC NAME cdf_use_files[files]
+ {
+ auto ec = ec_type_of($NAME);
+ if( ec == ec_none_e ) {
+ yyerrorv("syntax error: not an "
+ "EXCEPTION CONDITION: %s", $NAME);
+ YYERROR;
+ }
+ std::list<size_t> files;
+ if( $files ) {
+ if( ec_io_e != (ec_io_e & ec) ) {
+ yyerrorv("syntax error: not an "
+ "I-O EXCEPTION CONDITION: %s", $NAME);
+ YYERROR;
+ }
+ auto& culprits = $files->files;
+ std::transform( culprits.begin(), culprits.end(),
+ std::back_inserter(files),
+ file_list_t::symbol_index );
+ }
+
+ cbl_declarative_t declarative(current.declarative_section(),
+ ec, files, file_mode_none_e);
+ // Check for duplicates, but keep going.
+ current.declaratives.add(declarative);
+ }
+ ;
+cdf_use_files: %empty { $$ = NULL; }
+ | FILE_KW filenames { $$ = $2; }
+ ;
+
+culprits: filenames { $$.fnames = $1; $$.io_mode = file_mode_none_e; }
+ | INPUT { $$.fnames = NULL; $$.io_mode = file_mode_input_e; }
+ | OUTPUT { $$.fnames = NULL; $$.io_mode = file_mode_output_e; }
+ | IO { $$.fnames = NULL; $$.io_mode = file_mode_io_e; }
+ | EXTEND { $$.fnames = NULL; $$.io_mode = file_mode_extend_e; }
+ ;
+globally: global { $$ = $1? GLOBAL : 0; }
+ | global STANDARD { $$ = $1? GLOBAL : STANDARD; }
+ | global AFTER { $$ = $1? GLOBAL : 0; }
+ | global AFTER STANDARD { $$ = $1? GLOBAL : STANDARD; }
+ ;
+mistake: EXCEPTION { $$ = EXCEPTION; }
+ | ERROR { $$ = ERROR; }
+ ;
+procedure: %empty
+ | PROCEDURE
+ ;
cdf_listing: STAR_CBL star_cbl_opts
;
@@ -9661,8 +9661,8 @@ star_cbl_opts: star_cbl_opt
;
star_cbl_opt: LIST { $$ = $LIST[0] == 'N'? NOLIST : LIST; }
| MAP { $$ = $MAP[0] == 'N'? NOMAP : MAP; }
- /* | SOURCE { $$ = $SOURCE[0] == 'N'? NOSOURCE : SOURCE; } */
- ;
+ /* | SOURCE { $$ = $SOURCE[0] == 'N'? NOSOURCE : SOURCE; } */
+ ;
cdf_option: CBL cbl_options
;
@@ -9681,13 +9681,13 @@ cdf_none: ENTER
;
cdf_call_convention:
- CALL_COBOL {
- current_call_convention(cbl_call_cobol_e);
- }
- | CALL_VERBATIM {
- current_call_convention(cbl_call_verbatim_e);
- }
- ;
+ CALL_COBOL {
+ current_call_convention(cbl_call_cobol_e);
+ }
+ | CALL_VERBATIM {
+ current_call_convention(cbl_call_verbatim_e);
+ }
+ ;
%%
@@ -9700,8 +9700,8 @@ void parser_call2( cbl_refer_t name, cbl_refer_t returning,
{
if( is_literal(name.field) ) {
cbl_field_t called = { 0, FldLiteralA, FldInvalid, quoted_e | constant_e,
- 0, 0, 77, nonarray, 0, "",
- 0, {0,0,0,0, NULL, NULL, {NULL}, {NULL}}, NULL };
+ 0, 0, 77, nonarray, 0, "",
+ 0, {0,0,0,0, NULL, NULL, {NULL}, {NULL}}, NULL };
snprintf(called.name, sizeof(called.name), "_%s", name.field->data.initial);
called.data = name.field->data;
name.field = cbl_field_of(symbol_field_add(PROGRAM, &called));
@@ -9817,26 +9817,26 @@ keyword_tok( const char * text, bool include_intrinsics ) {
bool operator()( const char *candidate ) {
static const cbl_name_t cdf_names[] = {
- "CHECKING", "LOCATION"
+ "CHECKING", "LOCATION"
}, * const eonames = cdf_names + COUNT_OF(cdf_names);
if( eonames != std::find_if(cdf_names, eonames,
- [candidate](const cbl_name_t name) {
- return 0 == strcasecmp(name, candidate)
- && strlen(name) == strlen(candidate);
- } ) ) {
- return false; // CDF names are never ordinary tokens
+ [candidate](const cbl_name_t name) {
+ return 0 == strcasecmp(name, candidate)
+ && strlen(name) == strlen(candidate);
+ } ) ) {
+ return false; // CDF names are never ordinary tokens
}
return 0 == strcasecmp(name, candidate)
- && strlen(name) == strlen(candidate);
+ && strlen(name) == strlen(candidate);
}
};
////static auto last = yytname + YYNTOKENS; // COUNT_OF(yytname);
static auto last = std::find_if(yytname, yytname + COUNT_OF(yytname),
- [] ( const char *name ) {
- return 0 == strcmp(name, "$accept"); });
+ [] ( const char *name ) {
+ return 0 == strcmp(name, "$accept"); });
auto p = std::find_if( yytname + 3, last, cmp(text) );
if( p == last ) return 0;
@@ -10179,7 +10179,7 @@ current_t::repository_add_all() {
assert( !programs.empty() );
auto& repository = programs.top().function_repository;
std::copy( function_descrs, function_descrs_end,
- std::inserter(repository, repository.begin()) );
+ std::inserter(repository, repository.begin()) );
}
/*
@@ -10287,7 +10287,7 @@ ast_op( cbl_refer_t *lhs, char op, cbl_refer_t *rhs ) {
case '-':
// Simple addition OK for table indexes.
if( lhs->field->type == FldIndex || rhs->field->type == FldIndex ) {
- goto ok;
+ goto ok;
}
}
@@ -10479,8 +10479,8 @@ current_data_section_set( data_section_t data_section ) {
// order is mandatory
if( data_section < current_data_section ) {
yyerrorv("%s SECTION must precede %s SECTION",
- data_section_str(data_section),
- data_section_str(current_data_section));
+ data_section_str(data_section),
+ data_section_str(current_data_section));
return false;
}
@@ -10546,7 +10546,7 @@ lang_check_failed (const char* file, int line, const char* function) {}
void ast_inspect( cbl_refer_t& input, ast_inspect_list_t& inspects ) {
if( yydebug ) {
warnx("%s:%d: INSPECT %zu operations on %s, line %d", __func__, __LINE__,
- inspects.size(), input.field->name, yylineno);
+ inspects.size(), input.field->name, yylineno);
}
std::for_each(inspects.begin(), inspects.end(), dump_inspect);
auto array = inspects.as_array();
@@ -10707,16 +10707,16 @@ numstr2i( const char input[], radix_t radix ) {
case boolean_e:
for( const char *p = input; *p != '\0'; p++ ) {
if( ssize_t(8 * sizeof(integer) - 1) < p - input ) {
- yyerrorv("warning: '%s' accepted as %d", input, integer);
- return integer;
+ yyerrorv("warning: '%s' accepted as %d", input, integer);
+ return integer;
}
switch(*p) {
- case '0': bit = 0; break;
- case '1': bit = 1; break;
- break;
+ case '0': bit = 0; break;
+ case '1': bit = 1; break;
+ break;
default:
- yyerrorv("warning: '%s' accepted as %d", input, integer);
- return integer;
+ yyerrorv("warning: '%s' accepted as %d", input, integer);
+ return integer;
}
integer = (integer << (p - input));
integer |= bit;
@@ -10745,7 +10745,7 @@ new_literal( const char initial[], enum radix_t radix ) {
break;
}
return new_literal(strlen(initial), initial,
- cbl_field_attr_t(constant_e | attr));
+ cbl_field_attr_t(constant_e | attr));
}
class is_elementary_type { // for INITIALIZE purposes
@@ -10786,7 +10786,7 @@ symbol_group_data_members( cbl_refer_t refer, bool with_filler ) {
std::copy_if( symbols_begin(igroup), symbols_begin(eogroup),
std::back_inserter(elems), [is_elem]( const symbol_elem_t& elem ) {
- return is_elem(elem) || cbl_field_of(&elem)->occurs.ntimes() > 0; } );
+ return is_elem(elem) || cbl_field_of(&elem)->occurs.ntimes() > 0; } );
std::transform( elems.begin(), elems.end(),
std::back_inserter(refers), refer_of(refer) );
return refers;
@@ -10799,7 +10799,7 @@ close_out_program( const char name[] ) {
if( name ) {
if( 0 != strcasecmp(prog->name, name) ) {
yyerrorv( "END PROGRAM '%s' does not match PROGRAM-ID '%s'",
- name, prog->name);
+ name, prog->name);
return false;
}
}
@@ -10829,20 +10829,20 @@ struct expand_group : public std::list<cbl_refer_t> {
return;
}
std::list<cbl_refer_t> members = symbol_group_data_members( refer,
- with_filler );
+ with_filler );
std::copy( members.begin(), members.end(), back_inserter(*this) );
}
};
static bool
initialize_statement( cbl_refer_t tgt, bool with_filler,
- data_category_t value_category,
+ data_category_t value_category,
const category_map_t& replacements,
bool to_default, bool explicitly = true )
{
if( dimensions(tgt.field) < tgt.nsubscript ) {
yyerrorv( "syntax error: %s has %zu subscripts, but takes only %zu",
- tgt.field->name, tgt.nsubscript, dimensions(tgt.field) );
+ tgt.field->name, tgt.nsubscript, dimensions(tgt.field) );
return false;
}
@@ -10858,7 +10858,7 @@ initialize_statement( cbl_refer_t tgt, bool with_filler,
if( splat && *splat == '1' ) {
warnx("%s: %d: N=%zu %-16s %s", __func__, __LINE__,
- N, tgt.name(), cbl_field_type_str(tgt.field->type));
+ N, tgt.name(), cbl_field_type_str(tgt.field->type));
}
if( 0 < N ) { // add missing dimension(s)
@@ -10873,7 +10873,7 @@ initialize_statement( cbl_refer_t tgt, bool with_filler,
do {
// recurse on each table element, which might itself be a table or group
fOK = fOK && initialize_statement( tgt, with_filler, value_category,
- replacements, to_default, false);
+ replacements, to_default, false);
parser_add(*p, *p, literally_one);
} while( ++i < tgt.field->occurs.ntimes() );
return fOK;
@@ -10889,20 +10889,20 @@ initialize_statement( cbl_refer_t tgt, bool with_filler,
auto eogroup = end_of_group(imember);
bool fOK = true;
while( ++imember < eogroup ) {
- auto e = symbol_at(imember);
- if( e->type != SymField ) continue;
- auto f = cbl_field_of(e);
- if( ! (f->type == FldGroup || is_elementary(f->type)) ) continue;
-
- if( ! symbol_redefines(f) ) {
- tgt.field = f;
- // recurse on each member, which might be a table or group
- fOK = fOK && initialize_statement( tgt, with_filler, value_category,
- replacements, to_default, false );
- }
- if( f->type == FldGroup ) {
- imember = end_of_group(imember) - 1;
- }
+ auto e = symbol_at(imember);
+ if( e->type != SymField ) continue;
+ auto f = cbl_field_of(e);
+ if( ! (f->type == FldGroup || is_elementary(f->type)) ) continue;
+
+ if( ! symbol_redefines(f) ) {
+ tgt.field = f;
+ // recurse on each member, which might be a table or group
+ fOK = fOK && initialize_statement( tgt, with_filler, value_category,
+ replacements, to_default, false );
+ }
+ if( f->type == FldGroup ) {
+ imember = end_of_group(imember) - 1;
+ }
}
return fOK;
}
@@ -10936,16 +10936,16 @@ initialize_statement( cbl_refer_t tgt, bool with_filler,
warnx("%s:%-5s: %s", __func__, keyword_str(token), field_str(tgt.field));
}
} else if( value_category == data_category_all ||
- value_category == data_category_of(tgt) ) {
+ value_category == data_category_of(tgt) ) {
// apply any applicable VALUE
if( explicitly || tgt.field->data.initial ) {
assert( with_filler || !tgt.field->has_attr(filler_e) );
if( tgt.field->data.initial ) {
- if( ! tgt.field->data.initial ) {
- yyerrorv("error: %s defined without VALUE", name_of(tgt.field));
- return false;
- }
- parser_initialize(tgt);
+ if( ! tgt.field->data.initial ) {
+ yyerrorv("error: %s defined without VALUE", name_of(tgt.field));
+ return false;
+ }
+ parser_initialize(tgt);
}
}
to_default = false;
@@ -10965,8 +10965,8 @@ initialize_statement( cbl_refer_t tgt, bool with_filler,
char from_str[128]; // copy static buffer from field_str
strcpy( from_str, field_str(from) );
warnx("%s: move: %-18s %s \n\t from %-18s %s", __func__,
- cbl_field_type_str(tgt.field->type) + 3, field_str(tgt.field),
- cbl_field_type_str(from->type) + 3, from_str);
+ cbl_field_type_str(tgt.field->type) + 3, field_str(tgt.field),
+ cbl_field_type_str(from->type) + 3, from_str);
}
return true;
}
@@ -11003,26 +11003,26 @@ data_category_str( data_category_t category ) {
static void
initialize_statement( std::list<cbl_refer_t> tgts, bool with_filler,
- data_category_t value_category,
+ data_category_t value_category,
const category_map_t& replacements,
bool to_default ) {
if( yydebug && getenv(__func__) ) {
warnx( "%s: %zu targets, %s filler, %s, to_default=%s",
- __func__, tgts.size(), with_filler? "with" : "no",
- data_category_str(value_category), to_default? "yes" : "no" );
+ __func__, tgts.size(), with_filler? "with" : "no",
+ data_category_str(value_category), to_default? "yes" : "no" );
for( auto tgt : tgts ) {
fprintf( stderr, "%28s: %s\n", __func__, name_of(tgt.field) );
}
for( const auto& elem : replacements ) {
fprintf( stderr, "%28s: %s <-%s\n", __func__,
- data_category_str(elem.first),
- name_of(elem.second->field) );
+ data_category_str(elem.first),
+ name_of(elem.second->field) );
}
}
for( auto tgt : tgts ) {
initialize_statement( tgt, with_filler, value_category,
- replacements, to_default );
+ replacements, to_default );
}
}
@@ -11034,7 +11034,7 @@ initialize_statement( std::list<cbl_refer_t> tgts, bool with_filler,
*/
static acrc_t *
apply_acrcs( cbl_refer_t *cond, const acrc_t& ante, acrcs_t& abbrs,
- logop_t and_or, acrc_t& rhs ) {
+ logop_t and_or, acrc_t& rhs ) {
// resolve RHS by first using LHS.ante, or defer both
acrc_t *output = &rhs;
if( ! is_conditional(rhs.term) ) {
@@ -11048,23 +11048,23 @@ apply_acrcs( cbl_refer_t *cond, const acrc_t& ante, acrcs_t& abbrs,
auto R = is_conditional(abbr.term) ? abbr.term->cond() : rhs_cond;
assert(abbr.term);
if( !is_conditional(abbr.term) ) { // expand using ante
- relop_t op = abbr.relop_from(ante.op);
- if( yydebug )
- warnx("%s:%d: %s %s %s%s %s %s", __func__, __LINE__,
- cond->name(), logop_str(and_or),
- abbr.invert? "NOT " : "",
- ante.term->name(), relop_str(op), abbr.term->name());
- parser_relop(R, *ante.term, op, *abbr.term);
- if( abbr.invert ) {
- parser_logop(R, NULL, not_op, R);
- }
+ relop_t op = abbr.relop_from(ante.op);
+ if( yydebug )
+ warnx("%s:%d: %s %s %s%s %s %s", __func__, __LINE__,
+ cond->name(), logop_str(and_or),
+ abbr.invert? "NOT " : "",
+ ante.term->name(), relop_str(op), abbr.term->name());
+ parser_relop(R, *ante.term, op, *abbr.term);
+ if( abbr.invert ) {
+ parser_logop(R, NULL, not_op, R);
+ }
}
parser_logop(cond->cond(), cond->cond(), and_or, R);
}
if( yydebug && !abbrs.empty() ) {
- warnx("%s:%d: line %d: reduced %zu acrc terms, leaving %s",
- __func__, __LINE__, yylineno, abbrs.size(),
- output? output->term->name() : "none");
+ warnx("%s:%d: line %d: reduced %zu acrc terms, leaving %s",
+ __func__, __LINE__, yylineno, abbrs.size(),
+ output? output->term->name() : "none");
}
abbrs.clear();
return output; // return if not applied
@@ -11080,7 +11080,7 @@ apply_acrcs( cbl_refer_t *cond, const acrc_t& ante, acrcs_t& abbrs,
if( yydebug ) {
warnx("%s:%d: line %d: leaves %zu acrc terms",
- __func__, __LINE__, yylineno, abbrs.size());
+ __func__, __LINE__, yylineno, abbrs.size());
}
return NULL;
}
@@ -11122,7 +11122,7 @@ struct declarative_file_list_t : protected cbl_declarative_t {
: cbl_declarative_t(d)
{
if( nfile > 0 )
- assert(d.files[0] == this->files[0]);
+ assert(d.files[0] == this->files[0]);
}
static std::ostream&
splat( std::ostream& os, const declarative_file_list_t& dcl ) {
@@ -11152,12 +11152,12 @@ operator<<( std::ostream& os, const cbl_declarative_t& dcl ) {
return os <<
"\t{ " << dcl.section << ", "
- << std::boolalpha << dcl.global << ", "
- << ec_type_str(dcl.type) << ", "
- << dcl.nfile << ", "
- << "dcl_file_list_" << i++ << ", "
- << cbl_file_mode_str(dcl.mode) << " }"
- << std::flush;
+ << std::boolalpha << dcl.global << ", "
+ << ec_type_str(dcl.type) << ", "
+ << dcl.nfile << ", "
+ << "dcl_file_list_" << i++ << ", "
+ << cbl_file_mode_str(dcl.mode) << " }"
+ << std::flush;
}
void parser_add_declaratives( size_t n, cbl_declarative_t *declaratives) {
@@ -11180,9 +11180,9 @@ new_literal( const literal_t& lit, enum cbl_field_attr_t attr ) {
bool zstring = lit.prefix[0] == 'Z';
if( !zstring && lit.data[lit.len] != '\0' ) {
warnx("%s:%d: line %d, no NUL terminator '%-*.*s'{%zu/%zu}",
- __func__, __LINE__, yylineno,
- int(lit.len), int(lit.len),
- lit.data, strlen(lit.data), lit.len);
+ __func__, __LINE__, yylineno,
+ int(lit.len), int(lit.len),
+ lit.data, strlen(lit.data), lit.len);
}
assert(zstring || lit.data[lit.len] == '\0');
@@ -11197,8 +11197,8 @@ bool
cbl_file_t::validate_forward( size_t isym ) const {
if( isym > 0 && FldForward == symbol_field_forward(isym)->type ) {
yyerrorv( "error: line %d: %s of %s is not defined",
- this->line, cbl_field_of(symbol_at(isym))->name,
- this->name );
+ this->line, cbl_field_of(symbol_at(isym))->name,
+ this->name );
return false;
}
return true;
@@ -11255,9 +11255,9 @@ cbl_figconst_of( const char *value ) {
}, *eovalues = values + COUNT_OF(values);
auto p = std::find_if( values, eovalues,
- [value]( const values_t& elem ) {
- return elem.value == value;
- } );
+ [value]( const values_t& elem ) {
+ return elem.value == value;
+ } );
return p == eovalues? normal_value_e : p->type;
}
@@ -11376,10 +11376,10 @@ literal_subscripts_valid( const cbl_refer_t& name ) {
// X(0): subscript 1 of for out of range for 02 X OCCURS 4 to 6
yyerrorv( "error: %s(%s): subscript %zu out of range "
- "for %02u %s OCCURS %u to %u",
- oob->name, subs, 1 + isub,
- oob->level, oob->name,
- oob->occurs.bounds.lower, oob->occurs.bounds.upper );
+ "for %02u %s OCCURS %u to %u",
+ oob->name, subs, 1 + isub,
+ oob->level, oob->name,
+ oob->occurs.bounds.lower, oob->occurs.bounds.upper );
return false;
}
return true;
@@ -11389,12 +11389,12 @@ static void
subscript_dimension_error( size_t nsub, const cbl_refer_t *name ) {
if( 0 == dimensions(name->field) ) {
yyerrorv( "error: %zu subscripts provided for %s, "
- "which has no dimensions",
- nsub, name->name() );
+ "which has no dimensions",
+ nsub, name->name() );
} else {
yyerrorv( "error: %zu subscripts provided for %s, "
- "which has only %zu dimensions",
- nsub, name->name(), dimensions(name->field) );
+ "which has only %zu dimensions",
+ nsub, name->name(), dimensions(name->field) );
}
}
diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc
index 36e8aa3a0652d372341ead1f732fabcbd11e5880..0134956bdedbd57e0fccb43ba9bfa3460547310f 100644
--- a/gcc/cobol/symbols.cc
+++ b/gcc/cobol/symbols.cc
@@ -3227,6 +3227,7 @@ new_temporary_like( cbl_field_t skel ) {
temporaries.add(field);
}
memcpy(skel.name, field->name, sizeof(field->name));
+ skel.var_decl_node = field->var_decl_node;
*field = skel;
return parser_symbol_add2(field);