diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 3e4f337ed..571c95640 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,23 @@ +2021-12-30 Simon Sobisch + + * parser.y (table_name): check for KEY phrase in SEARCH ALL + * parser.y (end_perform_or_dot): fix terminator cleanup, previously freed the + wrong cb_tree + * parser.y, scanner.l: distinguish between tokens END / AT_END, + ESCAPE / ON_ESCAPE, EXCEPTION / ON_EXCEPTION and + renamed tokens NOT_END -> NOT_AT_END, NOT_ON_EXCEPTION -> NOT_EXCEPTION, + NOT_OVERFLOW -> NOT_ON_OVERFLOW, NOT_ESCAPE -> NOT_ON_ESCAPE + * codegen.c (output_search_all): add WHEN tracing, to keep performance only + done after the actual execution + * codegen.c (output_search_whens): add SEARCH VARYING tracing + * tree.h (struct cb_search), tree.c (cb_build_search), parser.y, + typeck.c (cb_emit_search, cb_emit_search_all), + codegen.c (output_search_whens, output_search_all): renamed end_stmt in + cb_search to at_end, storing pair of AT END (position) and statements + * codegen.c (output_search_whens, output_search_all): adjust output of + source references for better debugging experience and add AT END tracing + 2021-12-14 Simon Sobisch * cobc.c (print_fields), codegen.c (output_field_display): only check for diff --git a/cobc/codegen.c b/cobc/codegen.c index 21da8c718..878e20dc2 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -279,6 +279,7 @@ static void output_param (cb_tree, int); static void output_funcall (cb_tree); static void output_report_summed_field (struct cb_field *); +static void output_trace_info (cb_tree, const char *); static void output_source_reference (cb_tree, const char *); static void codegen_init (struct cb_program *, const char *); @@ -5423,14 +5424,12 @@ output_occurs (struct cb_field *p) } static void -output_search_whens (cb_tree table, struct cb_field *p, cb_tree stmt, +output_search_whens (cb_tree table, struct cb_field *p, cb_tree at_end, cb_tree var, cb_tree whens) { cb_tree l; cb_tree idx = NULL; - COB_UNUSED(table); /* to be handled later */ - /* LCOV_EXCL_START */ if (!p->index_list) { cobc_err_msg (_("call to '%s' with invalid parameter '%s'"), @@ -5452,6 +5451,7 @@ output_search_whens (cb_tree table, struct cb_field *p, cb_tree stmt, } /* Start loop */ + last_line = -1; /* force statement reference output at begin of loop */ output_line ("for (;;) {"); output_indent_level += 2; @@ -5463,20 +5463,40 @@ output_search_whens (cb_tree table, struct cb_field *p, cb_tree stmt, output_occurs (p); output (")"); output_newline (); - output_block_open (); output_line ("/* Table end */"); - if (stmt) { - output_stmt (stmt); + output_block_open (); + if (at_end) { + output_source_reference (CB_PAIR_X (at_end), "AT END"); + output_stmt (CB_PAIR_Y (at_end)); } else { + /* position is best guess here */ + table->source_line++; + output_source_reference (table, "AT END"); + table->source_line--; output_line ("break;"); } output_block_close (); /* WHEN test */ output_stmt (whens); + output_newline (); /* Iteration */ - output_newline (); + { + /* Output source location as code, + especially for tracking adjustment of the index */ + if (var) { + output_source_reference (var, "SEARCH VARYING"); + } else { + /* output_source_reference is correct here but as we don't want + to trace internal code temporary disable source_location + because 3.x includes trace code */ + int sav_fsl = cb_flag_source_location; + cb_flag_source_location = 0; + output_source_reference (table, "SEARCH VARYING internal"); + cb_flag_source_location = sav_fsl; + } + } output_prefix (); output_integer (idx); output ("++;"); @@ -5484,20 +5504,17 @@ output_search_whens (cb_tree table, struct cb_field *p, cb_tree stmt, if (var && var != idx) { output_move (idx, var); } - output_line ("/* Iterate */"); /* End loop */ output_indent_level -= 2; output_line ("}"); } static void -output_search_all (cb_tree table, struct cb_field *p, cb_tree stmt, - cb_tree cond, cb_tree when) +output_search_all (cb_tree table, struct cb_field *p, cb_tree at_end, + cb_tree when_cond, cb_tree when_stmts) { cb_tree idx; - COB_UNUSED(table); /* to be handled later */ - idx = CB_VALUE (p->index_list); /* Header */ output_block_open (); @@ -5515,23 +5532,42 @@ output_search_all (cb_tree table, struct cb_field *p, cb_tree stmt, output_occurs (p); output (" == 0) head = tail;"); output_newline (); + output_newline (); /* Start loop */ + last_line = -1; /* force statement reference output at begin of loop */ output_line ("for (;;)"); output_block_open (); /* End test */ output_line ("if (head >= tail - 1)"); - output_block_open (); output_line ("/* Table end */"); - if (stmt) { - output_stmt (stmt); + output_block_open (); + if (at_end) { + output_source_reference (CB_PAIR_X (at_end), "AT END"); + output_stmt (CB_PAIR_Y (at_end)); } else { + /* position is best guess here */ + table->source_line++; + output_source_reference (table, "AT END"); + table->source_line--; output_line ("break;"); } output_block_close (); + output_newline (); /* Next index */ + { + /* Output source location as code, + especially for tracking adjustment of the index */ + /* output_source_reference is correct here but as we don't want + to trace internal code temporary disable source_location + because 3.x includes trace code */ + int sav_fsl = cb_flag_source_location; + cb_flag_source_location = 0; + output_source_reference (table, "SEARCH VARYING internal"); + cb_flag_source_location = sav_fsl; + } output_prefix (); output_integer (idx); output (" = (head + tail) / 2;"); @@ -5539,16 +5575,33 @@ output_search_all (cb_tree table, struct cb_field *p, cb_tree stmt, output_newline (); /* WHEN test */ - output_line ("/* WHEN */"); + { + /* output_source_reference is correct here but due to 3.x + having source_location including trace code it would + heavily reduce SEARCH ALL performance + --> so temporary disable that here */ + int sav_fsl = cb_flag_source_location; + cb_flag_source_location = 0; + output_source_reference (when_cond, "WHEN"); + cb_flag_source_location = sav_fsl; + } output_prefix (); output ("if ("); - output_cond (cond, 1); + output_cond (when_cond, 1); output (")"); output_newline (); output_block_open (); - output_stmt (when); + if (cb_flag_traceall || cb_old_trace) { + /* Output trace info */ + /* note: this actually belongs only before the condition, but + for the trace code we add it here again */ + output_trace_info (when_cond, "WHEN"); + } + output_stmt (when_stmts); output_block_close (); + output_newline (); + output_line ("/* setup for next binary search position */"); output_line ("if (ret < 0)"); output_prefix (); output (" head = "); @@ -5573,10 +5626,10 @@ output_search (struct cb_search *p) /* TODO: Add run-time checks for the table, including ODO */ if (p->flag_all) { - output_search_all (p->table, fp, p->end_stmt, + output_search_all (p->table, fp, p->at_end, CB_IF (p->whens)->test, CB_IF (p->whens)->stmt1); } else { - output_search_whens (p->table, fp, p->end_stmt, p->var, p->whens); + output_search_whens (p->table, fp, p->at_end, p->var, p->whens); } } @@ -7091,6 +7144,7 @@ output_perform (struct cb_perform *p) output_newline (); loop_counter++; output_block_open (); + last_line = -1; /* force statement reference output at begin of loop */ output_perform_once (p); output_block_close (); break; @@ -7117,6 +7171,7 @@ output_perform (struct cb_perform *p) case CB_PERFORM_FOREVER: output_line ("for (;;)"); output_block_open (); + last_line = -1; /* force statement reference output at begin of loop */ output_perform_once (p); output_block_close (); break; @@ -7494,7 +7549,7 @@ output_cobol_info (cb_tree x) const char *p = x->source_file; output ("#line %d \"", x->source_line); while(*p){ - if( *p == '\\' ){ + if (*p == '\\') { output("%c",'\\'); } output("%c",*p++); @@ -7575,7 +7630,6 @@ output_section_info (struct cb_label *lp) } } - static void output_trace_info (cb_tree x, const char *name) { @@ -7648,10 +7702,10 @@ output_source_reference (cb_tree tree, const char *stmt_name) COB_SET_LINE_FILE(tree->source_line, lookup_source(tree->source_file))); } } - if (last_line != tree->source_line) { - /* Output source location as code */ - output_line_and_trace_info (tree, stmt_name); - } + /* Output source location as code */ + output_line_and_trace_info (tree, stmt_name); + + last_line = tree->source_line; } static void @@ -7922,8 +7976,8 @@ output_stmt (cb_tree x) FIXME: postpone to actual DEBUGGING procedure, using module->module_stmt there */ - if (current_prog->flag_gen_debug && - !p->flag_in_debug) { + if (current_prog->flag_gen_debug + && !p->flag_in_debug) { output_prefix (); output ("memcpy ("); output_data (cb_debug_line); @@ -8247,10 +8301,8 @@ output_stmt (cb_tree x) } } else if (ip->test->source_line) { output_line ("/* Line: %-10d: WHEN */", ip->test->source_line); - if (last_line != ip->test->source_line) { - /* Output source location as code */ - output_line_and_trace_info (ip->test, "WHEN"); - } + /* Output source location as code */ + output_line_and_trace_info (ip->test, "WHEN"); } else { output_line ("/* WHEN */"); } diff --git a/cobc/parser.y b/cobc/parser.y index 8b1364902..300755706 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -2260,6 +2260,7 @@ set_record_size (cb_tree min, cb_tree max) %token ASCII %token ASSIGN %token AT +%token AT_END "AT END" %token ATTRIBUTE %token ATTRIBUTES %token AUTHOR /* remark: not used here */ @@ -2772,13 +2773,13 @@ set_record_size (cb_tree min, cb_tree max) %token NOTIFY_CHANGE "NOTIFY-CHANGE" %token NOTIFY_DBLCLICK "NOTIFY-DBLCLICK" %token NOTIFY_SELCHANGE "NOTIFY-SELCHANGE" -%token NOT_END "NOT END" -%token NOT_EOP "NOT EOP" -%token NOT_ESCAPE "NOT ESCAPE" +%token NOT_AT_END "NOT AT END" +%token NOT_EOP "NOT AT EOP" +%token NOT_ON_ESCAPE "NOT ON ESCAPE" %token NOT_EQUAL "NOT EQUAL" -%token NOT_EXCEPTION "NOT EXCEPTION" +%token NOT_ON_EXCEPTION "NOT ON EXCEPTION" %token NOT_INVALID_KEY "NOT INVALID KEY" -%token NOT_OVERFLOW "NOT OVERFLOW" +%token NOT_ON_OVERFLOW "NOT ON OVERFLOW" %token NOT_SIZE_ERROR "NOT SIZE ERROR" %token NUM_COL_HEADINGS "NUM-COL-HEADINGS" %token NUM_ROWS "NUM-ROWS" @@ -2796,6 +2797,8 @@ set_record_size (cb_tree min, cb_tree max) %token OMITTED %token ON %token ONLY +%token ON_ESCAPE "ON ESCAPE" +%token ON_EXCEPTION "ON EXCEPTION" %token OPEN %token OPTIONAL %token OPTIONS @@ -3237,12 +3240,12 @@ set_record_size (cb_tree min, cb_tree max) %nonassoc WRITE %nonassoc XML -%nonassoc NOT_END END +%nonassoc NOT_AT_END AT_END END %nonassoc NOT_EOP EOP %nonassoc NOT_INVALID_KEY INVALID_KEY -%nonassoc NOT_OVERFLOW TOK_OVERFLOW +%nonassoc NOT_ON_OVERFLOW TOK_OVERFLOW %nonassoc NOT_SIZE_ERROR SIZE_ERROR -%nonassoc NOT_EXCEPTION EXCEPTION NOT_ESCAPE ESCAPE +%nonassoc NOT_ON_EXCEPTION ON_EXCEPTION EXCEPTION NOT_ON_ESCAPE ON_ESCAPE ESCAPE %nonassoc NO_DATA DATA %nonassoc END_ACCEPT @@ -11751,7 +11754,7 @@ _call_on_exception: ; call_on_exception: - EXCEPTION statement_list + on_exception statement_list { $$ = $2; } @@ -11774,7 +11777,7 @@ _call_not_on_exception: ; call_not_on_exception: - NOT_EXCEPTION statement_list + NOT_ON_EXCEPTION statement_list { $$ = $2; } @@ -14239,14 +14242,14 @@ _end_perform: end_perform_or_dot: END_PERFORM { - TERMINATOR_CLEAR ($-3, PERFORM); + TERMINATOR_CLEAR ($-5, PERFORM); } | TOK_DOT { if (cb_relaxed_syntax_checks) { - TERMINATOR_WARNING ($-3, PERFORM); + TERMINATOR_WARNING ($-5, PERFORM); } else { - TERMINATOR_ERROR ($-3, PERFORM); + TERMINATOR_ERROR ($-5, PERFORM); } /* Put the dot token back into the stack for reparse */ cb_unput_dot (); @@ -14547,7 +14550,7 @@ _read_key: read_handler: _invalid_key_phrases -| at_end +| read_at_end ; _end_read: @@ -14759,35 +14762,51 @@ search_statement: } search_body _end_search +| SEARCH ALL + { + begin_statement ("SEARCH ALL", TERM_SEARCH); + } + search_all_body + _end_search ; search_body: - table_name search_varying search_at_end search_whens + table_name _search_varying _search_at_end + search_whens { cb_emit_search ($1, $2, $3, $4); } -| ALL table_name search_at_end WHEN expr +; + +search_all_body: + table_name _search_at_end + WHEN expr statement_list { - current_statement->name = (const char *)"SEARCH ALL"; - cb_emit_search_all ($2, $3, $5, $6); + cb_emit_search_all ($1, $2, $4, $5); } ; -search_varying: +_search_varying: /* empty */ { $$ = NULL; } | VARYING identifier { $$ = $2; } ; -search_at_end: +_search_at_end: /* empty */ { $$ = NULL; } -| END +| at_end end_pos_token statement_list { - $$ = $2; + $$ = CB_BUILD_PAIR ($2, $3); + } +; + +end_pos_token: + { + $$ = cb_build_comment ("AT END"); } ; @@ -15112,7 +15131,8 @@ sort_statement: ; sort_body: - table_identifier _sort_key_list _sort_duplicates _sort_collating + table_identifier /* may reference a file or a table */ + _sort_key_list _sort_duplicates _sort_collating { cb_tree x = cb_ref ($1); @@ -15328,14 +15348,11 @@ start_op: | _flag_not lt { $$ = cb_int ($1 ? COB_GE : COB_LT); } | _flag_not ge { $$ = cb_int ($1 ? COB_LT : COB_GE); } | _flag_not le { $$ = cb_int ($1 ? COB_GT : COB_LE); } -| disallowed_op { $$ = cb_int (COB_NE); } -; - -disallowed_op: - not_equal_op +| not_equal_op { cb_error_x (CB_TREE (current_statement), - _("NOT EQUAL condition not allowed on START statement")); + _("NOT EQUAL condition not allowed on START statement")); + $$ = cb_int (COB_NE); } ; @@ -16540,8 +16557,8 @@ accp_on_exception: ; escape_or_exception: - ESCAPE -| EXCEPTION + on_escape +| on_exception ; _accp_not_on_exception: @@ -16558,8 +16575,8 @@ accp_not_on_exception: ; not_escape_or_not_exception: - NOT_ESCAPE -| NOT_EXCEPTION + NOT_ON_ESCAPE +| NOT_ON_EXCEPTION ; @@ -16587,7 +16604,7 @@ _common_on_exception: ; common_on_exception: - EXCEPTION statement_list + on_exception statement_list { current_statement->handler_type = get_handler_type_from_statement(current_statement); current_statement->ex_handler = $2; @@ -16600,7 +16617,7 @@ _common_not_on_exception: ; common_not_on_exception: - NOT_EXCEPTION statement_list + NOT_ON_EXCEPTION statement_list { current_statement->handler_type = get_handler_type_from_statement (current_statement); current_statement->not_ex_handler = $2; @@ -16692,7 +16709,7 @@ _not_on_overflow: ; not_on_overflow: - NOT_OVERFLOW statement_list + NOT_ON_OVERFLOW statement_list { current_statement->handler_type = OVERFLOW_HANDLER; current_statement->not_ex_handler = $2; @@ -16710,7 +16727,7 @@ return_at_end: } ; -at_end: +read_at_end: %prec SHIFT_PREFER at_end_clause _not_at_end_clause | not_at_end_clause _at_end_clause @@ -16733,7 +16750,7 @@ _at_end_clause: ; at_end_clause: - END statement_list + at_end statement_list { current_statement->handler_type = AT_END_HANDLER; current_statement->ex_handler = $2; @@ -16746,7 +16763,7 @@ _not_at_end_clause: ; not_at_end_clause: - NOT_END statement_list + NOT_AT_END statement_list { current_statement->handler_type = AT_END_HANDLER; current_statement->not_ex_handler = $2; @@ -17220,6 +17237,11 @@ table_name: cb_error_x ($1, _("'%s' not indexed"), cb_name ($1)); cb_note_x (COB_WARNOPT_NONE, x, _("'%s' defined here"), cb_name (x)); $$ = cb_error_node; + } else if (CB_FIELD (x)->nkeys == 0 + && strcmp(current_statement->name, "SEARCH ALL") == 0) { + cb_error_x ($1, _("SEARCH ALL requires KEY phrase")); + cb_note_x (COB_WARNOPT_NONE, x, _("'%s' defined here"), cb_name (x)); + $$ = cb_error_node; } else { $$ = $1; } @@ -18793,6 +18815,9 @@ _exception: %prec SHIFT_PREFER | EXCEPTION ; /* Mandatory selection */ +at_end: AT_END | END ; +on_escape: ON_ESCAPE | ESCAPE; +on_exception: ON_EXCEPTION | EXCEPTION; column_or_col: COLUMN | COL ; columns_or_cols: COLUMNS | COLS ; column_or_cols: column_or_col | columns_or_cols ; diff --git a/cobc/scanner.l b/cobc/scanner.l index 863dd3d91..be0b7c64a 100644 --- a/cobc/scanner.l +++ b/cobc/scanner.l @@ -697,50 +697,57 @@ H#[0-9A-Za-z]+ { "NOT"[ ,;\n]+("ON"[ ,;\n]+)?"ESCAPE"/[ .,;\n] { count_lines (yytext); - RETURN_TOK (NOT_ESCAPE); + RETURN_TOK (NOT_ON_ESCAPE); } "NOT"[ ,;\n]+("ON"[ ,;\n]+)?"EXCEPTION"/[ .,;\n] { count_lines (yytext); - RETURN_TOK (NOT_EXCEPTION); + RETURN_TOK (NOT_ON_EXCEPTION); } "ON"[ ,;\n]+"ESCAPE"/[ .,;\n] { + /* Note: plain ESCAPE is directly matched via registered words */ count_lines (yytext); - RETURN_TOK (ESCAPE); + RETURN_TOK (ON_ESCAPE); } "ON"[ ,;\n]+"EXCEPTION"/[ .,;\n] { + /* Note: plain EXCEPTION is directly matched via registered words */ count_lines (yytext); - RETURN_TOK (EXCEPTION); + RETURN_TOK (ON_EXCEPTION); } "NOT"[ ,;\n]+("ON"[ ,;\n]+)?"OVERFLOW"/[ .,;\n] { count_lines (yytext); - RETURN_TOK (NOT_OVERFLOW); + RETURN_TOK (NOT_ON_OVERFLOW); } "NOT"[ ,;\n]+("AT"[ ,;\n]+)?"END"/[ .,;\n] { count_lines (yytext); - RETURN_TOK (NOT_END); + RETURN_TOK (NOT_AT_END); } "AT"[ ,;\n]+"END"/[ .,;\n] { + /* Note: plain END is directly matched via registered words */ count_lines (yytext); - RETURN_TOK (END); + RETURN_TOK (AT_END); } -("ON"[ ,;\n]+)?"OVERFLOW"/[ .,;\n] { +"ON"[ ,;\n]+"OVERFLOW"/[ .,;\n] { + /* Note: plain OVERFLOW is directly matched via registered words */ count_lines (yytext); RETURN_TOK (TOK_OVERFLOW); } "NOT"[ ,;\n]+("AT"[ ,;\n]+)?("END-OF-PAGE"|"EOP")/[ .,;\n] { + /* TODO: if those words are not reserved -> directly return */ count_lines (yytext); RETURN_TOK (NOT_EOP); } -("AT"[ ,;\n]+)?("END-OF-PAGE"|"EOP")/[ .,;\n] { +"AT"[ ,;\n]+("END-OF-PAGE"|"EOP")/[ .,;\n] { + /* Note: plain END-OF-PAGE / EOP is directly matched via registered words */ + /* TODO: if those words are not reserved -> directly return */ count_lines (yytext); RETURN_TOK (EOP); } diff --git a/cobc/tree.c b/cobc/tree.c index 00935eff8..d75976d1c 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -6006,7 +6006,7 @@ cb_build_initialize (const cb_tree var, const cb_tree val, const cb_tree rep, cb_tree cb_build_search (const int flag_all, const cb_tree table, const cb_tree var, - const cb_tree end_stmt, const cb_tree whens) + const cb_tree at_end, const cb_tree whens) { struct cb_search *p; @@ -6015,7 +6015,7 @@ cb_build_search (const int flag_all, const cb_tree table, const cb_tree var, p->flag_all = flag_all; p->table = table; p->var = var; - p->end_stmt = end_stmt; + p->at_end = at_end; p->whens = whens; return CB_TREE (p); } diff --git a/cobc/tree.h b/cobc/tree.h index dac7720a7..70128f87c 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -1284,10 +1284,11 @@ struct cb_initialize { struct cb_search { struct cb_tree_common common; /* Common values */ - cb_tree table; /* Table name */ - cb_tree var; /* Varying */ - cb_tree end_stmt; /* AT END */ - cb_tree whens; /* WHEN */ + cb_tree table; /* Reference to table name */ + cb_tree var; /* VARYING field */ + cb_tree at_end; /* AT END (pair of position and statements) */ + cb_tree whens; /* WHEN (conditions and statements) + [for not SEARCH ALL: list of those] */ int flag_all; /* SEARCH ALL */ }; diff --git a/cobc/typeck.c b/cobc/typeck.c index ea3537f3c..26b0b2052 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -11912,6 +11912,7 @@ cb_emit_rollback (void) /* SEARCH statement */ +/* SEARCH ALL with the given key */ static unsigned int search_set_keys (struct cb_field *f, cb_tree x) { @@ -12034,8 +12035,10 @@ cb_emit_search (cb_tree table, cb_tree varying, cb_tree at_end, cb_tree whens) return; } whens = cb_list_reverse (whens); - cb_emit (cb_build_search (0, table, varying, - cb_check_needs_break (at_end), whens)); + if (at_end) { + cb_check_needs_break (CB_PAIR_Y (at_end)); + } + cb_emit (cb_build_search (0, table, varying, at_end, whens)); } void @@ -12054,8 +12057,10 @@ cb_emit_search_all (cb_tree table, cb_tree at_end, cb_tree when, cb_tree stmts) } stmt_lis = cb_check_needs_break (stmts); - cb_emit (cb_build_search (1, table, NULL, - cb_check_needs_break (at_end), + if (at_end) { + cb_check_needs_break (CB_PAIR_Y (at_end)); + } + cb_emit (cb_build_search (1, table, NULL, at_end, cb_build_if (x, stmt_lis, NULL, 0))); } diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index d9b292931..a3ae61e33 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -3705,7 +3705,7 @@ AT_CLEANUP AT_SETUP([CALL C with callback, ENTRY-CONVENTION EXTERN]) -AT_KEYWORDS([runmisc CALL-CONVENTION LINKAGE]) +AT_KEYWORDS([runmisc CALL-CONVENTION LINKAGE OPTIONS]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. @@ -6539,13 +6539,21 @@ AT_CLEANUP # and -fsource-location, which is implied by -debug/g AT_SETUP([READY TRACE / RESET TRACE]) AT_KEYWORDS([runmisc -ftrace -ftraceall -fsource-location -CALL RECURSIVE RETURN-CODE +CALL RECURSIVE RETURN-CODE SEARCH COB_PHYSICAL_CANCEL COB_PRE_LOAD]) AT_DATA([caller.cob], [ IDENTIFICATION DIVISION. PROGRAM-ID. caller. - * + *> + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 ttab. + 03 tentries PIC 9 VALUE 0. + 03 tentry OCCURS 0 TO 5 DEPENDING ON tentries + ASCENDING KEY tkey INDEXED BY tidx. + 05 tkey pic x(3). + *> PROCEDURE DIVISION. READY TRACE MOVE 1 TO RETURN-CODE @@ -6560,6 +6568,41 @@ AT_DATA([caller.cob], [ CANCEL "callee1" CALL "callrec" MOVE 0 TO RETURN-CODE + *> + SEARCH ALL tentry + AT END + ADD 1 TO tentries + SET tidx TO tentries + MOVE 'A' TO tkey(tidx) + WHEN tkey(tidx) = 'A' + DISPLAY '*Magic*' + END-SEARCH + *> tidx is still one, expect a direct find + SEARCH tentry + AT END + DISPLAY '*Dark Magic*' + WHEN tkey(tidx) = 'A' + ADD 1 TO tentries + SET tidx TO tentries + MOVE 'B' TO tkey(tidx) + END-SEARCH + *> tidx is still two, expect end + SEARCH tentry + VARYING tidx + AT END + ADD 1 TO tentries + SET tidx TO tentries + MOVE 'C' TO tkey(tidx) + WHEN tkey(tidx) = 'A' + DISPLAY '* Darker Magic *' + END-SEARCH + SEARCH ALL tentry + AT END + DISPLAY 'NO COMMENT' + WHEN tkey(tidx) = 'C' + CONTINUE + END-SEARCH + *> STOP RUN. ]) @@ -6596,7 +6639,7 @@ AT_DATA([callee1.cob], [ END-EVALUATE CALL "callee2" END-CALL CANCEL "callee2" CALL "callee2b" END-CALL CANCEL "callee2b" - SUBTRACT 1 FROM RETURN-CODE END-SUBTRACT + SUBTRACT 1 FROM RETURN-CODE EXIT PROGRAM. ]) @@ -6667,7 +6710,7 @@ AT_DATA([callee2c.cob], [ END-PAR. EXIT PROGRAM. OTHER-SEC SECTION. - COMPUTE RETURN-CODE = 1 + 2 END-COMPUTE. + COMPUTE RETURN-CODE = 1 + 2. EX. EXIT. ]) @@ -6685,10 +6728,10 @@ AT_CHECK([COB_OLD_TRACE=y \ $COBC -x -o prog -ftraceall caller.cob], [0], [], []) AT_CHECK([COB_PHYSICAL_CANCEL=1 COB_PRE_LOAD="preload"$PATHSEP"preload2" $COBCRUN_DIRECT ./prog], [0], [], [Source : 'caller.cob' -Program-Id: caller Statement: MOVE Line: 7 -Program-Id: caller Statement: RESET TRACE Line: 8 -Program-Id: caller Statement: MOVE Line: 12 -Program-Id: caller Statement: CALL Line: 13 +Program-Id: caller Statement: MOVE Line: 15 +Program-Id: caller Statement: RESET TRACE Line: 16 +Program-Id: caller Statement: MOVE Line: 20 +Program-Id: caller Statement: CALL Line: 21 Source: 'callee1.cob' Program-Id: callee1 Entry: callee1 Line: 5 Program-Id: callee1 Section: (None) Line: 5 @@ -6731,7 +6774,7 @@ Program-Id: callee1 Statement: SUBTRACT Line: 34 Program-Id: callee1 Statement: EXIT PROGRAM Line: 35 Program-Id: callee1 Exit: callee1 Source : 'caller.cob' -Program-Id: caller Statement: CALL Line: 15 +Program-Id: caller Statement: CALL Line: 23 Source: 'callee1.cob' Program-Id: callee1 Entry: callee1 Line: 5 Program-Id: callee1 Section: (None) Line: 5 @@ -6774,8 +6817,8 @@ Program-Id: callee1 Statement: SUBTRACT Line: 34 Program-Id: callee1 Statement: EXIT PROGRAM Line: 35 Program-Id: callee1 Exit: callee1 Source : 'caller.cob' -Program-Id: caller Statement: CANCEL Line: 16 -Program-Id: caller Statement: CALL Line: 17 +Program-Id: caller Statement: CANCEL Line: 24 +Program-Id: caller Statement: CALL Line: 25 Source: 'preload2.cob' Program-Id: callrec Entry: callrec Line: 10 Program-Id: callrec Section: SOME-SEC Line: 10 @@ -6792,8 +6835,28 @@ Program-Id: callrec Exit: callrec Program-Id: callrec Statement: GOBACK Line: 15 Program-Id: callrec Exit: callrec Source : 'caller.cob' -Program-Id: caller Statement: MOVE Line: 18 -Program-Id: caller Statement: STOP RUN Line: 19 +Program-Id: caller Statement: MOVE Line: 26 +Program-Id: caller Statement: SEARCH ALL Line: 28 +Program-Id: caller Statement: AT END Line: 29 +Program-Id: caller Statement: ADD Line: 30 +Program-Id: caller Statement: SET Line: 31 +Program-Id: caller Statement: MOVE Line: 32 +Program-Id: caller Statement: SEARCH Line: 37 +Program-Id: caller Statement: WHEN Line: 40 +Program-Id: caller Statement: ADD Line: 41 +Program-Id: caller Statement: SET Line: 42 +Program-Id: caller Statement: MOVE Line: 43 +Program-Id: caller Statement: SEARCH Line: 46 +Program-Id: caller Statement: WHEN Line: 52 +Program-Id: caller Statement: SEARCH VARYING Line: 47 +Program-Id: caller Statement: AT END Line: 48 +Program-Id: caller Statement: ADD Line: 49 +Program-Id: caller Statement: SET Line: 50 +Program-Id: caller Statement: MOVE Line: 51 +Program-Id: caller Statement: SEARCH ALL Line: 55 +Program-Id: caller Statement: WHEN Line: 58 +Program-Id: caller Statement: CONTINUE Line: 59 +Program-Id: caller Statement: STOP RUN Line: 62 ]) AT_CHECK([$COBC -ftraceall callee1.cob], [0], [], []) @@ -6805,10 +6868,10 @@ AT_CHECK([$COBC -x -o prog -ftraceall caller.cob], [0], [], []) AT_CHECK([COB_PHYSICAL_CANCEL=1 COB_PRE_LOAD="preload"$PATHSEP"preload2" $COBCRUN_DIRECT ./prog], [0], [], [Source: 'caller.cob' Program-Id: caller -Program-Id: caller MOVE Line: 7 -Program-Id: caller RESET TRACE Line: 8 -Program-Id: caller MOVE Line: 12 -Program-Id: caller CALL Line: 13 +Program-Id: caller MOVE Line: 15 +Program-Id: caller RESET TRACE Line: 16 +Program-Id: caller MOVE Line: 20 +Program-Id: caller CALL Line: 21 Source: 'callee1.cob' Program-Id: callee1 Program-Id: callee1 Entry: callee1 Line: 5 @@ -6845,7 +6908,7 @@ Program-Id: callee1 EXIT PROGRAM Line: Program-Id: callee1 Exit: callee1 Line: 35 Source: 'caller.cob' Program-Id: caller -Program-Id: caller CALL Line: 15 +Program-Id: caller CALL Line: 23 Source: 'callee1.cob' Program-Id: callee1 Program-Id: callee1 Entry: callee1 Line: 5 @@ -6882,8 +6945,8 @@ Program-Id: callee1 EXIT PROGRAM Line: Program-Id: callee1 Exit: callee1 Line: 35 Source: 'caller.cob' Program-Id: caller -Program-Id: caller CANCEL Line: 16 -Program-Id: caller CALL Line: 17 +Program-Id: caller CANCEL Line: 24 +Program-Id: caller CALL Line: 25 Source: 'preload2.cob' Program-Id: callrec Program-Id: callrec Entry: callrec Line: 10 @@ -6900,15 +6963,35 @@ Program-Id: callrec GOBACK Line: Program-Id: callrec Exit: callrec Line: 15 Source: 'caller.cob' Program-Id: caller -Program-Id: caller MOVE Line: 18 -Program-Id: caller STOP RUN Line: 19 +Program-Id: caller MOVE Line: 26 +Program-Id: caller SEARCH ALL Line: 28 +Program-Id: caller AT END Line: 29 +Program-Id: caller ADD Line: 30 +Program-Id: caller SET Line: 31 +Program-Id: caller MOVE Line: 32 +Program-Id: caller SEARCH Line: 37 +Program-Id: caller WHEN Line: 40 +Program-Id: caller ADD Line: 41 +Program-Id: caller SET Line: 42 +Program-Id: caller MOVE Line: 43 +Program-Id: caller SEARCH Line: 46 +Program-Id: caller WHEN Line: 52 +Program-Id: caller SEARCH VARYING Line: 47 +Program-Id: caller AT END Line: 48 +Program-Id: caller ADD Line: 49 +Program-Id: caller SET Line: 50 +Program-Id: caller MOVE Line: 51 +Program-Id: caller SEARCH ALL Line: 55 +Program-Id: caller WHEN Line: 55 +Program-Id: caller CONTINUE Line: 59 +Program-Id: caller STOP RUN Line: 62 ]) AT_CLEANUP AT_SETUP([Trace feature with subroutine]) -AT_KEYWORDS([Trace]) +#AT_KEYWORDS([Trace]) # FIXME: check if the one above is enough and either # remove this test or exchange by a non-IDX version @@ -10850,7 +10933,7 @@ libcob: warning: cob_put_field_str: attempt to over-write constant field with 'B AT_CLEANUP -AT_SETUP([DEFAULT ROUNDED MODE]) +AT_SETUP([OPTIONS paragraph, DEFAULT ROUNDED MODE]) AT_KEYWORDS([runmisc]) AT_DATA([prog.cob], [