diff --git a/cobc/ChangeLog b/cobc/ChangeLog index ec8b7fc54..83d9c696c 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1028,6 +1028,10 @@ 'memcpy' to speed up the process If size is not known until run time then emit call to cob_init_table +2020-11-21 Simon Sobisch + + * codgen.c (process_command_line): minor cleanup + 2020-11-20 Simon Sobisch * pplex.l (ppinput): fixed processing after "line not terminated" diff --git a/cobc/codegen.c b/cobc/codegen.c index 4f1ddc9f7..257f6d739 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -5251,7 +5251,7 @@ static void propagate_table (cb_tree x, int bgn_idx) { struct cb_field *f = cb_code_field (x); - const unsigned int occ = f->occurs_max; + const unsigned int occ = (unsigned int)f->occurs_max; cob_uli_t len = (cob_uli_t)f->size; cob_uli_t maxlen = len * occ; unsigned int j = 1; @@ -5279,7 +5279,7 @@ propagate_table (cb_tree x, int bgn_idx) /* double the chunks each time */ do { output_prefix (); - output ("memcpy (b_ptr + %6ld, b_ptr, %6ld);", len, len); + output ("memcpy (b_ptr + %6lu, b_ptr, %6lu);", len, len); output ("\t/* %s: %5d thru %d */", f->name, j + bgn_idx, j * 2 + bgn_idx - 1); output_newline (); @@ -5289,7 +5289,7 @@ propagate_table (cb_tree x, int bgn_idx) if (j < occ && maxlen > len) { output_prefix (); - output ("memcpy (b_ptr + %6ld, b_ptr, %6ld);", + output ("memcpy (b_ptr + %6lu, b_ptr, %6lu);", len, maxlen - len); output ("\t/* %s: %5d thru %d */", f->name, j + bgn_idx, occ); @@ -12038,7 +12038,7 @@ set_param_to_null (cb_tree l) /* Pickup parameter knowing the caller is COBOL */ static void -pickup_cob_param (cb_tree l, int i) +pickup_cob_param (cb_tree l, cob_u32_t inc) { char wrk[64]; cb_tree x; @@ -12052,13 +12052,13 @@ pickup_cob_param (cb_tree l, int i) f->flag_data_set = 0; if (is_value_parm) { if (f->flag_any_length) { - sprintf(wrk,"module->next->cob_procedure_params[%d]->size",i); + sprintf(wrk,"module->next->cob_procedure_params[%u]->size",inc); } else { strcpy(wrk,"0"); } - output_line ("if (cob_glob_ptr->cob_call_params > %d) { /* BY VALUE %s */", i, f->name); - output_line (" cob_alloc_move(%s[%d], &%s%d, %s);", - "module->next->cob_procedure_params", i, + output_line ("if (cob_glob_ptr->cob_call_params > %u) { /* BY VALUE %s */", inc, f->name); + output_line (" cob_alloc_move(%s[%u], &%s%d, %s);", + "module->next->cob_procedure_params", inc, CB_PREFIX_FIELD, f->id, wrk); if (!cb_sticky_linkage) { output_line ("} else {"); @@ -12067,28 +12067,28 @@ pickup_cob_param (cb_tree l, int i) output_line ("}"); } else if (f->flag_any_length) { - output_line ("if (cob_glob_ptr->cob_call_params > %d", i); + output_line ("if (cob_glob_ptr->cob_call_params > %u", inc); output_line ("&& module->next"); if (is_any_numeric) { - output_line ("&& %s[%d]) { /* ANY NUMERIC %s */", - "module->next->cob_procedure_params", i, f->name); + output_line ("&& %s[%u]) { /* ANY NUMERIC %s */", + "module->next->cob_procedure_params", inc, f->name); output_indent_level += 2; /* Copy complete structure */ - output_line (" %s%d = *(%s[%d]);", + output_line (" %s%d = *(%s[%u]);", CB_PREFIX_FIELD, f->id, - "module->next->cob_procedure_params", i); + "module->next->cob_procedure_params", inc); } else { - output_line ("&& %s[%d]) { /* BY REFERENCE %s */", - "module->next->cob_procedure_params", i, f->name); + output_line ("&& %s[%u]) { /* BY REFERENCE %s */", + "module->next->cob_procedure_params", inc, f->name); output_indent_level += 2; /* Copy size */ - output_line ("%s%d.size = %s[%d]->size;", + output_line ("%s%d.size = %s[%u]->size;", CB_PREFIX_FIELD, f->id, - "module->next->cob_procedure_params", i); + "module->next->cob_procedure_params", inc); /* Copy data address */ - output_line ("%s%d.data = %s[%d]->data;", + output_line ("%s%d.data = %s[%u]->data;", CB_PREFIX_FIELD, f->id, - "module->next->cob_procedure_params", i); + "module->next->cob_procedure_params", inc); } if (!cb_sticky_linkage) { output_indent_level -= 2; @@ -12099,7 +12099,7 @@ pickup_cob_param (cb_tree l, int i) output_indent_level -= 2; output_line ("}"); } else { - output_line ("if (cob_glob_ptr->cob_call_params > %d)", i); + output_line ("if (cob_glob_ptr->cob_call_params > %u)", inc); output_indent_level += 2; output_prefix (); output ("%s%d.data = (cob_u8_t*)", CB_PREFIX_FIELD, f->id); @@ -12113,7 +12113,7 @@ pickup_cob_param (cb_tree l, int i) /* Pickup parameter size for ANY LENGTH */ static void -pickup_any_length (cb_tree l, int i) +pickup_any_length (cb_tree l, cob_u32_t inc) { struct cb_field *f; int is_value_parm, is_any_numeric; @@ -12122,16 +12122,16 @@ pickup_any_length (cb_tree l, int i) if (f->flag_any_length) { f->flag_data_set = 0; - output_line ("if (module->module_num_params > %d && " + output_line ("if (module->module_num_params > %u && " "module->next && " - "module->next->cob_procedure_params[%d])", - i, i); + "module->next->cob_procedure_params[%u])", + inc, inc); if (f->flag_any_numeric) { /* Copy complete structure */ - output_line (" %s%d = *(module->next->cob_procedure_params[%d]);", - CB_PREFIX_FIELD, f->id, i); + output_line (" %s%d = *(module->next->cob_procedure_params[%u]);", + CB_PREFIX_FIELD, f->id, inc); } else { /* Copy size */ - output_line (" %s%d.size = module->next->cob_procedure_params[%d]->size;", - CB_PREFIX_FIELD, f->id, i); + output_line (" %s%d.size = module->next->cob_procedure_params[%u]->size;", + CB_PREFIX_FIELD, f->id, inc); } output_prefix (); output ("%s%d.data = ", CB_PREFIX_FIELD, f->id); @@ -12144,7 +12144,7 @@ pickup_any_length (cb_tree l, int i) /* Pickup parameter knowing the caller is C */ static void -pickup_c_param (cb_tree l, int i, int is_enter) +pickup_c_param (cb_tree l, cob_u32_t inc, int is_enter) { char wrk[64]; cb_tree x; @@ -12158,7 +12158,7 @@ pickup_c_param (cb_tree l, int i, int is_enter) f->flag_data_set = 0; if (is_value_parm) { if (f->flag_any_length) { - sprintf(wrk,"module->next->cob_procedure_params[%d]->size",i); + sprintf(wrk,"module->next->cob_procedure_params[%u]->size",inc); } else { strcpy(wrk,"0"); } @@ -12200,12 +12200,12 @@ pickup_c_param (cb_tree l, int i, int is_enter) } } else { if (is_enter) { - if(i == 0) { + if(inc == 0) { output_line ("if (cob_glob_ptr->cob_call_params >= 0)"); output_indent_level += 2; - } else if(i > 0) { + } else if(inc > 0) { output_line ("if (cob_glob_ptr->cob_call_params == 0"); - output_line ("|| cob_glob_ptr->cob_call_params > %d)", i); + output_line ("|| cob_glob_ptr->cob_call_params > %u)", inc); output_indent_level += 2; } } @@ -12215,7 +12215,7 @@ pickup_c_param (cb_tree l, int i, int is_enter) output ("; /* %s */", f->name); output_newline (); if (is_enter) { - if(i >= 0) + if(inc >= 0) output_indent_level -= 2; } } @@ -12291,12 +12291,10 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) struct base_list *bl; struct literal_list *m; const char *s; - int i, j; - cob_u32_t inc; + cob_u32_t inc, i, j; unsigned int name_hash; int parmnum; int seen; - int anyseen; recent_prog = prog; /* Program function */ @@ -12349,11 +12347,10 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) output_line ("/* Entry point name_hash values */"); output_line ("static const unsigned int %sname_hash [] = {",CB_PREFIX_STRING); if (cb_list_length (prog->entry_list) > 1) { - for (i = 0, l = prog->entry_list; l; l = CB_CHAIN (l)) { + for (inc = 0, l = prog->entry_list; l; inc++, l = CB_CHAIN (l)) { name_hash = cob_get_name_hash (CB_LABEL (CB_PURPOSE (l))->name); - output_line ("\t0x%X,\t/* %d: %s */", - name_hash, i, CB_LABEL (CB_PURPOSE (l))->name); - i++; + output_line ("\t0x%X,\t/* %u: %s */", + name_hash, inc, CB_LABEL (CB_PURPOSE (l))->name); } } else { name_hash = cob_get_name_hash (prog->orig_program_id); @@ -12381,8 +12378,8 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) /* Decimal structures */ if (prog->decimal_index_max) { output_local ("/* Decimal structures */\n"); - for (i = 0; i < prog->decimal_index_max; i++) { - output_local ("cob_decimal\t*d%d = NULL;\n", i); + for (inc = 0; inc < prog->decimal_index_max; inc++) { + output_local ("cob_decimal\t*d%d = NULL;\n", inc); } output_local ("\n"); } @@ -12430,51 +12427,51 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) /* Allocate files */ if (prog->file_list) { - i = 0; + inc = 0; for (l = prog->file_list; l; l = CB_CHAIN (l)) { - i += output_file_allocation (CB_FILE (CB_VALUE (l))); + inc += output_file_allocation (CB_FILE (CB_VALUE (l))); } - if (i) { + if (inc) { output_local ("\n/* LINAGE pointer */\n"); output_local ("static cob_linage\t\t*lingptr;\n"); } } /* BASED working-storage */ - i = 0; + seen = 0; for (f = prog->working_storage; f; f = f->sister) { if (f->redefines) { continue; } if (f->flag_item_based) { - if (!i) { - i = 1; + if (!seen) { + seen = 1; output_local("\n/* BASED WORKING-STORAGE SECTION */\n"); } output_local ("static unsigned char\t*%s%d = NULL; /* %s */\n", CB_PREFIX_BASE, f->id, f->name); } } - if (i) { + if (seen) { output_local ("\n"); } /* BASED local-storage */ - i = 0; + seen = 0; for (f = prog->local_storage; f; f = f->sister) { if (f->redefines) { continue; } if (f->flag_item_based) { - if (!i) { - i = 1; + if (!seen) { + seen = 1; output_local("\n/* BASED LOCAL-STORAGE */\n"); } output_local ("static unsigned char\t*%s%d = NULL; /* %s */\n", CB_PREFIX_BASE, f->id, f->name); } } - if (i) { + if (seen) { output_local ("\n"); } @@ -12575,13 +12572,8 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) /* Module Parameters */ output_line ("/* Set address of module parameter list */"); if (cb_flag_stack_on_heap || prog->flag_recursive) { - if (prog->max_call_param) { - i = prog->max_call_param; - } else { - i = 1; - } output_line ("cob_procedure_params = cob_malloc (%dU * sizeof(void *));", - i); + prog->max_call_param ? prog->max_call_param : 1); } output_line ("module->cob_procedure_params = cob_procedure_params;"); output_newline (); @@ -12684,8 +12676,8 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) } else { output ("cob_decimal_alloc (%u", prog->decimal_index_max); } - for (i = 0; i < prog->decimal_index_max; i++) { - output (", &d%u", i); + for (inc = 0; inc < prog->decimal_index_max; inc++) { + output (", &d%u", inc); } output (");"); output_newline (); @@ -12791,23 +12783,22 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) /* Set up ANY length items */ if (cb_list_length (prog->entry_list) <= 1 && !prog->flag_chained) { - i = 0; - anyseen = 0; - for (l = parameter_list; l; l = CB_CHAIN (l), i++) { + seen = 0; + for (l = parameter_list, inc = 0; l; l = CB_CHAIN (l), inc++) { f = cb_code_field (CB_VALUE (l)); if (f->flag_any_length) { - if (!anyseen) { - anyseen = 1; + if (!seen) { + seen = 1; name_hash = cob_get_name_hash (prog->orig_program_id); output_line ("if (cob_glob_ptr->cob_call_name_hash == 0x%X) {", name_hash); output_indent_level += 2; output_line ("/* Initialize ANY LENGTH parameters */"); output_line ("module->module_num_params = cob_glob_ptr->cob_call_params;"); } - pickup_any_length (l, i); + pickup_any_length (l, inc); } } - if (anyseen) { + if (seen) { output_indent_level -= 2; output_line ("}"); output_newline (); @@ -12832,16 +12823,16 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) output_line ("if (cob_glob_ptr->cob_call_name_hash != 0x%X) {", name_hash); output_indent_level += 2; output_line ("cob_glob_ptr->cob_call_from_c = 1; /* Called by C */"); - for (i = 0, l = parameter_list; l; l = CB_CHAIN (l), i++) { - pickup_c_param (l, i, !basic_param); + for (inc = 0, l = parameter_list; l; l = CB_CHAIN (l), inc++) { + pickup_c_param (l, inc, !basic_param); } - output_line ("cob_glob_ptr->cob_call_params = %u;", i); + output_line ("cob_glob_ptr->cob_call_params = %u;", inc); output_indent_level -= 2; output_line ("} else {"); output_indent_level += 2; output_line ("cob_glob_ptr->cob_call_from_c = 0; /* Called by COBOL */"); - for (i = 0, l = parameter_list; l; l = CB_CHAIN (l), i++) { - pickup_cob_param (l, i); + for (inc = 0, l = parameter_list; l; l = CB_CHAIN (l), inc++) { + pickup_cob_param (l, inc); } output_indent_level -= 2; output_line ("}"); @@ -12912,11 +12903,11 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) output_newline (); output_line ("switch (entry)"); output_block_open (); - for (i = 0, l = prog->entry_list; l; l = CB_CHAIN (l), i++) { + for (l = prog->entry_list, inc = 0; l; l = CB_CHAIN (l), inc++) { cb_tree lx = CB_PURPOSE (l); using_list = CB_VALUE (CB_VALUE (l)); if (using_list) { - output_line ("case %d: /* Initialize %d parameters for '%s' */",i, + output_line ("case %u: /* Initialize %d parameters for '%s' */",inc, cb_list_length(using_list),CB_LABEL (CB_PURPOSE (l))->name); output_indent_level += 2; for (j=0,l2 = using_list; l2; l2 = CB_CHAIN (l2), j++) { @@ -12924,7 +12915,7 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) } output_indent_level -= 2; } else { - output_line ("case %d: /* No parameters for '%s' */",i, + output_line ("case %u: /* No parameters for '%s' */",inc, CB_LABEL (CB_PURPOSE (l))->name); } if (cb_flag_stack_extended) { @@ -13059,8 +13050,8 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) output_line ("/* Free decimal structures */"); output_prefix (); output ("cob_decimal_pop (%u", prog->decimal_index_max); - for (i = 0; i < prog->decimal_index_max; i++) { - output (", d%u", i); + for (inc = 0; inc < prog->decimal_index_max; inc++) { + output (", d%u", inc); } output (");"); output_newline (); @@ -13228,23 +13219,26 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) } } - i = 1; + seen = 0; for (m = literal_cache; m; m = m->next) { if (CB_TREE_CLASS (m->x) == CB_CLASS_NUMERIC && m->make_decimal) { - if (i) { - i = 0; + if (!seen) { + seen = 1; output_line ("/* Set Decimal Constant values */"); } - output_line ("%s%d = &%s%d;", CB_PREFIX_DEC_CONST,m->id, - CB_PREFIX_DEC_FIELD,m->id); - output_line ("cob_decimal_init(%s%d);",CB_PREFIX_DEC_CONST,m->id); + output_line ("%s%d = &%s%d;", CB_PREFIX_DEC_CONST, m->id, + CB_PREFIX_DEC_FIELD, m->id); + output_line ("cob_decimal_init(%s%d);", CB_PREFIX_DEC_CONST, m->id); output_line ("cob_decimal_set_field (%s%d, (cob_field *)&%s%d);", - CB_PREFIX_DEC_CONST,m->id, - CB_PREFIX_CONST,m->id); + CB_PREFIX_DEC_CONST, m->id, + CB_PREFIX_CONST, m->id); output_newline (); } } + if (seen) { + output_newline (); + } #if 0 /* BWT coerce linkage to picture */ /* Manage linkage section */ @@ -13362,7 +13356,7 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) output_prefix (); output ("(void)%s_%d_ (-1", next_prog->program_id, next_prog->toplev_count); - for (i = 0; i < (int)(next_prog->num_proc_params); ++i) { + for (inc = 0; inc < next_prog->num_proc_params; ++inc) { output (", NULL"); } output (");"); @@ -13442,19 +13436,21 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) output_line ("initialized = 0;"); output_newline (); output_line ("P_clear_decimal:"); - i = 1; + seen = 0; for (m = literal_cache; m; m = m->next) { if (CB_TREE_CLASS (m->x) == CB_CLASS_NUMERIC && m->make_decimal) { - if (i) { - i = 0; + if (!seen) { + seen = 1; output_line ("/* Clear Decimal Constant values */"); } - output_line ("cob_decimal_clear(%s%d);",CB_PREFIX_DEC_CONST,m->id); - output_line ("%s%d = NULL;",CB_PREFIX_DEC_CONST,m->id); + output_line ("cob_decimal_clear(%s%d);", CB_PREFIX_DEC_CONST, m->id); + output_line ("%s%d = NULL;", CB_PREFIX_DEC_CONST, m->id); } } - output_newline (); + if (seen) { + output_newline (); + } output_line ("return 0;"); output_newline (); /* End of CANCEL callback code */ @@ -13492,7 +13488,11 @@ output_function_entry_function (struct cb_program *prog, cb_tree entry, output_newline (); output_line ("cob_field *"); output ("%s (", entry_name); +#if 0 /* TODO for 4.0: set the attributes from the field given outside on the stack */ + output ("cob_field *cob_fret, const int cob_pam"); +#else output ("cob_field **cob_fret, const int cob_pam"); +#endif } else { #if (defined(_WIN32) || defined(__CYGWIN__)) && !defined(__clang__) if (!prog->nested_level) { @@ -13528,12 +13528,16 @@ output_function_entry_function (struct cb_program *prog, cb_tree entry, output_block_open (); output_line ("struct cob_func_loc\t*floc;"); +#if 0 /* TODO for 4.0: set the attributes from the field given outside on the stack */ + output_line ("cob_field*\t*ret_fld;"); +#else output_line ("cob_field\t*ret = NULL;"); +#endif output_newline (); + output_line ("/* Save environment */"); output_prefix (); output ("floc = cob_save_func (cob_fret, cob_pam, %u", parmnum); - for (n = 0; n < parmnum; ++n) { output (", f%u", n); } @@ -13541,7 +13545,11 @@ output_function_entry_function (struct cb_program *prog, cb_tree entry, output_newline (); output_prefix (); +#if 0 /* TODO for 4.0: set the attributes from the field given outside on the stack */ + output ("ret_fld = %s_ (0", prog->program_id); +#else output ("floc->ret_fld = %s_ (0", prog->program_id); +#endif if (parmnum != 0) { output (", "); for (n = 0; n < parmnum; ++n) { @@ -13553,11 +13561,16 @@ output_function_entry_function (struct cb_program *prog, cb_tree entry, } output (");"); output_newline (); +#if 0 /* TODO for 4.0: set the attributes from the field given outside on the stack */ + output_line ("COB_SET_FLD((*cob_fret), ret_fld->size, ret_fld, ret_fld->attr);"); +#else output_line ("if (floc->ret_fld != NULL) {"); output_line (" **cob_fret = *floc->ret_fld;"); output_line (" ret = *cob_fret;"); output_line ("}"); +#endif output_newline (); + output_line ("/* Restore environment */"); output_line ("cob_restore_func (floc);"); output_line ("return ret;"); diff --git a/libcob/ChangeLog b/libcob/ChangeLog index bad60a183..7d918f3b2 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1312,6 +1312,11 @@ * fextfh.c (copy_file_to_fcd): use cob_cache_malloc instead of cob_strdup * fsqlxfd.c: if count_components > 1 then its a composite key +2020-11-22 Simon Sobisch + + * common.c, common.h (cob_save_func): have correct return type + struct cob_func_loc* instead of void* + 2020-11-20 Simon Sobisch * common.c (cob_stack_trace_internal): early exit if no data available diff --git a/libcob/common.h b/libcob/common.h index 216bf14e5..6c94cc156 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -2121,7 +2121,7 @@ COB_EXPIMP void cob_unstring_finish (void); COB_EXPIMP void cob_move (cob_field *, cob_field *); COB_EXPIMP void cob_move_ibm (void *, void *, const int); -COB_EXPIMP void cob_init_table (void *, unsigned long, long); +COB_EXPIMP void cob_init_table (void *, const size_t, const size_t); COB_EXPIMP void cob_set_int (cob_field *, const int); COB_EXPIMP int cob_get_int (cob_field *); COB_EXPIMP void cob_set_llint (cob_field *, cob_s64_t, cob_s64_t); diff --git a/libcob/move.c b/libcob/move.c index 27e49c2c2..6bd092ef3 100644 --- a/libcob/move.c +++ b/libcob/move.c @@ -1243,11 +1243,11 @@ cob_move_ibm (void *dst, void *src, const int len) * (used by INITIALIZE) */ void -cob_init_table (void *tbl, unsigned long len, long occ) +cob_init_table (void *tbl, const size_t len, const size_t occ) { - char *m = ((char*)tbl) + len; - unsigned long i = len; - int j = 1; + char *m = (char*)tbl + len; + size_t i = len; + size_t j = 1; if (occ < 2) return; do { diff --git a/tests/testsuite.src/run_extensions.at b/tests/testsuite.src/run_extensions.at index cdf24f7be..56c4bb21b 100644 --- a/tests/testsuite.src/run_extensions.at +++ b/tests/testsuite.src/run_extensions.at @@ -1125,8 +1125,8 @@ VARTAB(17) = "0000HI MOM 0000" AT_CLEANUP -AT_SETUP([UNBOUNDED DEPENDING ON (3)]) -AT_KEYWORDS([OCCURS]) +AT_SETUP([INITIALIZE OCCURS UNBOUNDED]) +AT_KEYWORDS([extensions runsubscripts subscripts refmod]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. @@ -1136,6 +1136,80 @@ AT_DATA([prog.cob], [ 01 p USAGE POINTER. 01 p2 USAGE POINTER. 01 dlen PIC 9(7). + + LINKAGE SECTION. + 01 a-table. + 03 prefix. + 05 n PIC 9(03) VALUE 123. + 03 table-data value all "ABCDE". + 04 rows OCCURS 0 TO UNBOUNDED TIMES + DEPENDING ON n. + 05 col1 PIC X. + 05 col2 PIC X(02). + + PROCEDURE DIVISION. + ALLOCATE LENGTH OF prefix CHARACTERS + RETURNING p + SET ADDRESS OF a-table TO p + INITIALIZE prefix ALL TO VALUE + IF FUNCTION LENGTH (a-table) NOT = 372 + DISPLAY 'WRONG LENGTH table: ' FUNCTION LENGTH (a-table) + END-DISPLAY + END-IF + ALLOCATE FUNCTION LENGTH (a-table) CHARACTERS + RETURNING p2 + SET ADDRESS OF a-table TO p2 + FREE p + + INITIALIZE prefix ALL TO VALUE + + IF LENGTH OF a-table NOT = 372 + MOVE LENGTH OF a-table TO dlen + DISPLAY "BAD SIZE: " dlen + END-DISPLAY + + INITIALIZE table-data (1:FUNCTION LENGTH(rows(1)) * n) + ALL TO VALUE + IF col2(1) NOT = "BC" + DISPLAY "col2(1) wrong: " col2(1) + END-DISPLAY + END-IF + IF rows(2) NOT = "DEA" + DISPLAY "rows(2) wrong: " rows(2) + END-DISPLAY + END-IF + + *> check if ref-mod also works as expected + MOVE ALL ZEROES TO a-table (1: (LENGTH OF a-table)) + + *> Test - should only initialize up to current size, not max: + INITIALIZE table-data TO DEFAULT + INITIALIZE table-data ALL TO VALUE + + *> Test - FUNCTION LENGTH(table-data) must be resolved at run-time + INITIALIZE table-data (1:FUNCTION LENGTH(table-data)) + ALL TO VALUE + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) + +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([INITIALIZE OCCURS ODOSLIDE]) +AT_KEYWORDS([extensions runsubscripts subscripts]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 p USAGE POINTER. + 01 p2 USAGE POINTER. + 01 dlen PIC 9(7). 01 grp-0. 05 FILLER PIC X(3). 05 FLD-0. @@ -1184,16 +1258,6 @@ AT_DATA([prog.cob], [ 15 FLD-5-4 PIC XX VALUE "ey". 05 FILLER PIC X(3). - LINKAGE SECTION. - 01 a-table. - 03 prefix. - 05 n PIC 9(03) VALUE 123. - 03 table-data value all "ABCDE". - 04 rows OCCURS 0 TO UNBOUNDED TIMES - DEPENDING ON n. - 05 col1 PIC X. - 05 col2 PIC X(02). - PROCEDURE DIVISION. MOVE ALL "*" TO grp-1. INITIALIZE FLD-1 ALL TO VALUE. @@ -1217,131 +1281,21 @@ AT_DATA([prog.cob], [ MOVE ALL "*" TO grp-5. INITIALIZE FLD-5 ALL TO VALUE. DISPLAY "GRP-5:" grp-5. - - ALLOCATE LENGTH OF prefix CHARACTERS - RETURNING p - SET ADDRESS OF a-table TO p - INITIALIZE prefix ALL TO VALUE - IF FUNCTION LENGTH (a-table) NOT = 372 - DISPLAY 'WRONG LENGTH table: ' FUNCTION LENGTH (a-table) - END-DISPLAY - END-IF - ALLOCATE FUNCTION LENGTH (a-table) CHARACTERS - RETURNING p2 - SET ADDRESS OF a-table TO p2 - FREE p - - INITIALIZE prefix ALL TO VALUE - *> FIXME: broken - initializes up to max but only should initialize - *> up to current size INITIALIZE table-data ALL TO VALUE - *> INITIALIZE table-data ALL TO VALUE - *> FIXME: broken - FUNCTION LENGTH(table-data) must be resolved - *> at run-time but is currently set to max at compile-time - *> INITIALIZE table-data (1:FUNCTION LENGTH(table-data)) - *> ALL TO VALUE - - INITIALIZE table-data TO DEFAULT - - INITIALIZE table-data ALL TO VALUE - - INITIALIZE table-data (1:FUNCTION LENGTH(rows(1)) * n) - ALL TO VALUE - IF col2(1) NOT = "BC" - DISPLAY "col2(1) wrong: " col2(1) - END-DISPLAY - END-IF - IF rows(2) NOT = "DEA" - DISPLAY "rows(2) wrong: " rows(2) - END-DISPLAY - END-IF - MOVE LENGTH OF a-table TO dlen - DISPLAY dlen. - *> check if ref-mod also works as expected - MOVE ALL ZEROES TO a-table (1: (LENGTH OF a-table)) - . ]) -AT_CHECK([$COBC -x -std=ibm -w -fodoslide prog.cob ], [0], [], []) +AT_CHECK([$COMPILE -fodoslide prog.cob ], [0], [], []) -AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [GRP-1:***ABCDE*** +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], +[GRP-1:***ABCDE*** GRP-2:***ABCD ABCD ABCD ABCD ABCD ABCD ABCD ABCD AB*** GRP-3:***ABC00XXABC00XXABC00XX*** GRP-4:***AB12YZAB12YZAB12YZAB12YZAB12YZAB12YZAB12YZAB12YZAB12YZAB12YZAB12YZ*** GRP-5:***Mon49eyMon49eyMon49eyMon49eyMon49eyMon49eyMon49eyMon -0000372 ], []) AT_CLEANUP -AT_SETUP([INITIALIZE OCCURS UNBOUNDED]) -AT_KEYWORDS([extensions runsubscripts subscripts refmod INITIALIZE]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 p USAGE POINTER. - 01 p2 USAGE POINTER. - - LINKAGE SECTION. - 01 a-table. - 03 prefix. - 05 n PIC 9(03) VALUE 123. - 03 table-data value all "ABCDE". - 04 rows OCCURS 0 TO UNBOUNDED TIMES - DEPENDING ON n. - 05 col1 PIC X. - 05 col2 PIC X(02). - - PROCEDURE DIVISION. - ALLOCATE LENGTH OF prefix CHARACTERS - RETURNING p - SET ADDRESS OF a-table TO p - INITIALIZE prefix ALL TO VALUE - IF FUNCTION LENGTH (a-table) NOT = 372 - DISPLAY 'WRONG LENGTH table: ' FUNCTION LENGTH (a-table) - END-DISPLAY - END-IF - ALLOCATE FUNCTION LENGTH (a-table) CHARACTERS - RETURNING p2 - SET ADDRESS OF a-table TO p2 - FREE p - INITIALIZE prefix ALL TO VALUE - *> FIXME: broken - initializes up to max but only should initialize - *> up to current size INITIALIZE table-data ALL TO VALUE - *> INITIALIZE table-data ALL TO VALUE - *> FIXME: broken - FUNCTION LENGTH(table-data) must be resolved - *> at run-time but is currently set to max at compile-time - *> INITIALIZE table-data (1:FUNCTION LENGTH(table-data)) - *> ALL TO VALUE - INITIALIZE table-data (1:FUNCTION LENGTH(rows(1)) * n) - ALL TO VALUE - IF col2(1) NOT = "BC" - DISPLAY "col2(1) wrong: " col2(1) - END-DISPLAY - END-IF - IF rows(2) NOT = "DEA" - DISPLAY "rows(2) wrong: " rows(2) - END-DISPLAY - END-IF - DISPLAY LENGTH OF a-table - *> check if ref-mod also works as expected - MOVE ALL ZEROES TO a-table (1: (LENGTH OF a-table)) - . -]) - -AT_CHECK([$COMPILE prog.cob], [0], [], []) - -# multiple issues, see comments above -AT_XFAIL_IF(true) - -AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) - -AT_CLEANUP - - AT_SETUP([DEPENDING ON with ODOSLIDE]) AT_KEYWORDS([nested ODO])