diff --git a/THANKS b/THANKS index b5b1514d9..08899d0d2 100644 --- a/THANKS +++ b/THANKS @@ -1,78 +1,89 @@ -Previous and current project maintainers: +Past and present maintainers: Keisuke Nishida Roger While (1950-2015) Simon Sobisch -Additional main developers with huge code and design contributions: +Other core developers with major code and design contributions -Ron Norman including for, but not limited to: - - implementation and ongoing work on C-/D-/VBISAM handler - - development of Report Writer - - external EXTFH along with ADDRESS OF FH--FCD and FH--KEYDEF - - improved compatibility to Micro Focus COBOL - - runtime configuration - - C-API for inspect/update COBOL data fields - - dump on abort +Ron Norman including but not limited to + - Implementation and ongoing work on the C-/D-/VBISAM handler + - Report Writer development + - Standard EXTFH together with ADDRESS OF FH--FCD and FH--KEYDEF + - Improved compatibility with Micro Focus COBOL + - Runtime configuration + - C-API to inspect/update COBOL data fields + - Dump on abort + - Performance improvements -Edward Hart including for, but not limited to: - - fine-grained configuration of runtime checks - - compiler configuration, especially reserved word handling +Edward Hart including but not limited to + - fine-grained configuration of run-time checks + - Compiler configuration, in particular reserved word handling - datetime intrinsic functions - - XML GNERATE and JSON GENERATE - - initial support for internal repository (function and program prototypes) - - syntax support for standard COBOL and existing implementor extensions - - bug fixing and improving the testsuite + - XML GENERATE and JSON GENERATE + - Initial support for internal repository (function and program prototypes) + - Syntax support for standard COBOL and existing implementor extensions + - Bug fixes and test suite enhancements -Further more explicit thanks to: +We are grateful for the work of the Translation Project, its translation teams +and their individual contributors, who provide translations of user messages +for non-English speakers. -Alain Lucari -Brian Tiffin -David Korn -Dave Pitts -Joe Robbins (-2017) -Keiichi Takahashi -Peg -Richard Smith -Thomas Biehler -William M. Klein -Yoshiki Kusumoto +Similar thanks go to all the packagers who allow users to install GnuCOBOL from +their distributions' package management systems. -We are thankful for the work of the Translation Project, their translation -teams and their one-time contributors, providing the translation of user -messages for non-English speakers. +Also to the many people that have helped with testing this software. +We hope that everyone will continue to provide feedback. This is invaluable +to the ongoing development process. -Also to the many people that have helped out in testing this software. -We hope that everybody will continue to provide feedback. This is invaluable -to the continuing development process. - -A special mention here of people who have provided exceptional support in terms -of time and resources on hardware that was not available to the developers: -Oleg Philon - For his work on the PowerPC -David Wilson - For his work on the MAC (Darwin) +A special mention here goes to people who have given exceptional support in +terms of time and resources on hardware that was not available to the +developers: +Oleg Philon - For his work on the PowerPC +David Wilson - For his work on the MAC (Darwin) Sergey Kashyrin - For his work on: - SUN Solaris - IBM AIX - HP-UX And continuing this amazing support: +Arnold Trembley - Win32 packaging and user support +Chuck Haatvedt - Work on optimized BCD handling Ludwin Janvier - patches for build/packaging issues Hans-Martin Rasch - Work on compiler syntax Michel Gouget - Work on syntax - IS Bill Klein - The mainstay for COBOL questions Frank Swarbrick - Work on compiler syntax -Warren Gay - For testing systems that we didn't known that we even support! - (eg. old DEC Alpha systems) +Warren Gay - For testing systems we didn't even know we supported! + (e.g. old DEC Alpha systems) Fabrizio Calabretta - Work on the internal EXTFH interface +Gary L. Cutler and Vincent B. Coen for +writing and maintaining the GnuCOBOL Programmer's Guide. + OCamlPro SAS for assigning David Declerck, Nicolas Berthier and Fabrice Le Fessant to work for adding GCOS (Bull) support and contributing the result. -Denis Hugonnard-Roche for ongoing additions to the internal testsuite to -improve code-coverage. +Denis Hugonnard-Roche for continuous additions to the internal test suite to +improve code coverage. + + +Further explicit thanks to + +Alain Lucari +Brian Tiffin +David Korn +Dave Pitts +Joe Robbins (-2017) +Keiichi Takahashi +Peg +Richard Smith +Thomas Biehler +William M. Klein +Yoshiki Kusumoto ------------------------------------------------------------------------------- @@ -88,7 +99,7 @@ OpenCOBOL was inspired by the TinyCOBOL project. Thanks to the TinyCOBOL authors and maintainers. -Additional from TinCOBOL: +Additional from TinyCOBOL: Rildo Pragana (1958-2020) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 628bbaf22..cd3cb9ab4 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -7,6 +7,30 @@ national literals * typeck.c (validate_move): don't permit alphanumeric literals in VALUE clause for numeric items + * field.c (cleanup_field_value): cleanup for national space + * scanner.l (scan_x): build "implied for empty" N / NX literal with + correct size + * scanner.l, tree.c (cb_concat_literals): output explanations of literal + errors as "note" instead of "error" + * tree.c: minor refactoring + +2023-03-28 Simon Sobisch + + * codegen.c (output_search_all): dropped unnecessary check + * codegen.c (output_search): add missing ODO runtime check + * codegen.c (output_search_whens): generate access to ODO value only once, + instead of on every internal SEARCH VARYING + * codegen.c (output_param): reduce scope of variables + +2023-03-24 Simon Sobisch + + * cobc.c: minor speedup in freeing memory + * reserved.c (get_user_specified_reserved_word): minor refactoring + +2023-03-23 Simon Sobisch + + * typeck.c (cb_build_move_field): generate optimized code for + reference-modification with same ref-mod length 2023-03-08 Emilien Lemaire diff --git a/cobc/cobc.c b/cobc/cobc.c index 531b6dc80..397e17cf9 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -574,7 +574,7 @@ static const struct option long_options[] = { {"std", CB_RQ_ARG, NULL, '$'}, {"conf", CB_RQ_ARG, NULL, '&'}, {"debug", CB_NO_ARG, NULL, 'd'}, - {"ext", CB_RQ_ARG, NULL, 'e'}, + {"ext", CB_RQ_ARG, NULL, 'e'}, /* note: kept *undocumented* until GC4, will be changed to '.' */ {"free", CB_NO_ARG, NULL, 'F'}, /* note: not assigned directly as this is only valid for */ {"fixed", CB_NO_ARG, NULL, 'f'}, /* `int` and sizeof(enum) isn't always sizeof (int) */ {"static", CB_NO_ARG, &cb_flag_static_call, 1}, @@ -1087,9 +1087,9 @@ cobc_main_stradd_dup (const char *str1, const char *str2) void * cobc_main_realloc (void *prevptr, const size_t size) { + register struct cobc_mem_struct *curr; + register struct cobc_mem_struct *prev; struct cobc_mem_struct *m; - struct cobc_mem_struct *curr; - struct cobc_mem_struct *prev; m = calloc ((size_t)1, COBC_MEM_SIZE + size); /* LCOV_EXCL_START */ @@ -1131,8 +1131,8 @@ cobc_main_realloc (void *prevptr, const size_t size) void cobc_main_free (void *prevptr) { - struct cobc_mem_struct *curr; - struct cobc_mem_struct *prev; + register struct cobc_mem_struct *curr; + register struct cobc_mem_struct *prev; prev = NULL; for (curr = cobc_mainmem_base; curr; curr = curr->next) { @@ -1203,9 +1203,9 @@ cobc_parse_strdup (const char *dupstr) void * cobc_parse_realloc (void *prevptr, const size_t size) { + register struct cobc_mem_struct *curr; + register struct cobc_mem_struct *prev; struct cobc_mem_struct *m; - struct cobc_mem_struct *curr; - struct cobc_mem_struct *prev; m = calloc ((size_t)1, COBC_MEM_SIZE + size); /* LCOV_EXCL_START */ @@ -1247,8 +1247,8 @@ cobc_parse_realloc (void *prevptr, const size_t size) void cobc_parse_free (void *prevptr) { - struct cobc_mem_struct *curr; - struct cobc_mem_struct *prev; + register struct cobc_mem_struct *curr; + register struct cobc_mem_struct *prev; prev = NULL; for (curr = cobc_parsemem_base; curr; curr = curr->next) { @@ -3616,7 +3616,8 @@ process_command_line (const int argc, char **argv) #endif break; - case 'e': + case 'e': /* until GC 4 we keep (undocumented) 'e', + but that's reserved for possible --error-log */ /* -ext : Add an extension suffix */ if (strlen (cob_optarg) > 15U) { cobc_err_exit (COBC_INV_PAR, "--ext"); diff --git a/cobc/codegen.c b/cobc/codegen.c index 3dc177767..57b3c464f 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -3041,6 +3041,11 @@ output_integer (cb_tree x) output_param (x, -1); output (")"); break; + + case CB_TAG_FUNCALL: + output_funcall (x); + break; + /* LCOV_EXCL_START */ default: CB_TREE_TAG_UNEXPECTED_ABORT (x); @@ -3433,12 +3438,7 @@ create_field (struct cb_field *f, cb_tree x) static void output_param (cb_tree x, int id) { - struct cb_reference *r; struct cb_field *f; - struct cb_cast *cp; - struct cb_binary_op *bp; - struct cb_intrinsic *ip; - struct cb_alphabet_name *abp; cb_tree l; if (x == NULL) { @@ -3474,8 +3474,8 @@ output_param (cb_tree x, int id) case CB_TAG_LOCALE_NAME: output_param (CB_LOCALE_NAME(x)->list, id); break; - case CB_TAG_ALPHABET_NAME: - abp = CB_ALPHABET_NAME (x); + case CB_TAG_ALPHABET_NAME: { + const struct cb_alphabet_name *abp = CB_ALPHABET_NAME (x); switch (abp->alphabet_type) { case CB_ALPHABET_ASCII: #ifdef COB_EBCDIC_MACHINE @@ -3513,8 +3513,9 @@ output_param (cb_tree x, int id) break; } break; - case CB_TAG_CAST: - cp = CB_CAST (x); + } + case CB_TAG_CAST: { + const struct cb_cast *cp = CB_CAST (x); switch (cp->cast_type) { case CB_CAST_INTEGER: output_integer (cp->val); @@ -3549,6 +3550,7 @@ output_param (cb_tree x, int id) break; } break; + } case CB_TAG_DECIMAL: output ("%s%d", CB_PREFIX_DECIMAL, CB_DECIMAL (x)->id); break; @@ -3561,16 +3563,18 @@ output_param (cb_tree x, int id) case CB_TAG_REPORT: output ("&%s%s", CB_PREFIX_REPORT, CB_REPORT_PTR (x)->cname); break; - case CB_TAG_REPORT_LINE: + case CB_TAG_REPORT_LINE: { + const struct cb_reference *r /* NOTE: do not use CB_REFERENCE_P because 'x' has a tag of CB_TAG_REPORT_LINE */ #if 1 /* FIXME: Should have expected type! */ - r = (struct cb_reference *)x; + = (struct cb_reference *)x; #else - r = CB_REFERENCE (x); + = CB_REFERENCE (x); #endif f = CB_FIELD (r->value); output ("&%s%d", CB_PREFIX_REPORT_LINE, f->id); break; + } case CB_TAG_LITERAL: if (nolitcast) { output ("&%s%d", CB_PREFIX_CONST, cb_lookup_literal (x, 0)); @@ -3582,8 +3586,8 @@ output_param (cb_tree x, int id) case CB_TAG_FIELD: x = cb_build_field_reference (CB_FIELD (x), NULL); /* Fall through */ - case CB_TAG_REFERENCE: - r = CB_REFERENCE (x); + case CB_TAG_REFERENCE: { + const struct cb_reference *r = CB_REFERENCE (x); if (CB_LOCALE_NAME_P (r->value)) { output_param (CB_LOCALE_NAME (r->value)->list, id); break; @@ -3754,8 +3758,9 @@ output_param (cb_tree x, int id) output (" )"); } break; - case CB_TAG_BINARY_OP: - bp = CB_BINARY_OP (x); + } + case CB_TAG_BINARY_OP: { + const struct cb_binary_op *bp = CB_BINARY_OP (x); output ("cob_intr_binop ("); output_param (bp->x, id); output (", "); @@ -3770,8 +3775,9 @@ output_param (cb_tree x, int id) output_param (bp->y, id); output (")"); break; - case CB_TAG_INTRINSIC: - ip = CB_INTRINSIC (x); + } + case CB_TAG_INTRINSIC: { + const struct cb_intrinsic *ip = CB_INTRINSIC (x); if (ip->isuser) { char *func; l = cb_ref (ip->name); @@ -3857,6 +3863,7 @@ output_param (cb_tree x, int id) } output (")"); break; + } case CB_TAG_ML_TREE: output ("&%s%d", CB_PREFIX_ML_TREE, CB_ML_TREE (x)->id); break; @@ -4278,7 +4285,7 @@ output_cond (cb_tree x, const int save_flag) case '~': output ("((int)"); if (save_flag - && p->flag == BOP_OPERANDS_SWAPPED) { + && p->flag == BOP_OPERANDS_SWAPPED) { output_cond (p->x, 2); } else { output_cond (p->x, save_flag); @@ -5707,20 +5714,24 @@ output_search_whens (cb_tree table, struct cb_field *p, cb_tree at_end, idx = CB_VALUE (p->index_list); } + output_block_open (); + output_prefix (); + output ("const int max = "); + output_occurs (p); + output (";"); + output_newline (); + /* Start loop */ last_line = -1; /* force statement reference output at begin of loop */ - output_line ("for (;;) {"); - output_indent_level += 2; + output_line ("for (;;)"); + output_block_open (); /* End test */ output_prefix (); output ("if ("); output_integer (idx); - output (" > "); - output_occurs (p); - output (")"); + output (" > max)"); output_newline (); - output_line ("/* Table end */"); output_block_open (); if (at_end) { output_source_reference (CB_PAIR_X (at_end), STMT_AT_END); @@ -5756,10 +5767,15 @@ output_search_whens (cb_tree table, struct cb_field *p, cb_tree at_end, output_move (idx, var); } /* End loop */ - output_indent_level -= 2; - output_line ("}"); + output_block_close (); + + output_block_close (); } +/* generate code for SEARCH ALL, + setup head (starting with 0) and tail (starting with max), + using the mid as index, then compare, + switching head/tail to the current index until match found */ static void output_search_all (cb_tree table, struct cb_field *p, cb_tree at_end, cb_tree when_cond, cb_tree when_stmts) @@ -5777,12 +5793,6 @@ output_search_all (cb_tree table, struct cb_field *p, cb_tree at_end, output (" + 1;"); output_newline (); - /* Check for at least one entry */ - output_prefix (); - output ("if ("); - output_occurs (p); - output (" == 0) head = tail;"); - output_newline (); output_newline (); /* Start loop */ @@ -5790,13 +5800,12 @@ output_search_all (cb_tree table, struct cb_field *p, cb_tree at_end, output_line ("for (;;)"); output_block_open (); - /* End test */ + /* End test, note: if ODO is 0 then "if 0 >= 0+1 -1" -> direct exit */ output_line ("if (head >= tail - 1)"); - output_line ("/* Table end */"); output_block_open (); if (at_end) { output_source_reference (CB_PAIR_X (at_end), STMT_AT_END); - output_stmt (CB_PAIR_Y (at_end)); + output_stmt (CB_PAIR_Y (at_end)); /* this is a CB_LIST ending with "break" */ } else { /* position to table here, otherwise we likely land in the WHEN (Note: if there's an explicit END-SEARCH there's always @@ -5829,7 +5838,7 @@ output_search_all (cb_tree table, struct cb_field *p, cb_tree at_end, output_newline (); output_newline (); - /* WHEN test */ + /* (single) WHEN test */ { /* output_source_reference would be ok here but we don't want to trace this (already tracing @@ -5880,12 +5889,30 @@ output_search (struct cb_search *p) { struct cb_field *fp = cb_code_field (p->table); - /* TODO: Add run-time checks for the table, including ODO */ + /* output ODO run-time check for the table */ + if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_SUBSCRIPT) && fp->odo_level != 0) { + struct cb_field *f; + for (f = fp; f; f = f->children) { + if (CB_VALID_TREE (f->depending) + && !f->flag_unbounded) { + cb_tree check = CB_BUILD_FUNCALL_5 ("cob_check_odo", + cb_build_cast_int (f->depending), + cb_int (f->occurs_min), + cb_int (f->occurs_max), + CB_BUILD_STRING0 (f->name), + CB_BUILD_STRING0 (CB_FIELD_PTR (f->depending)->name)); + optimize_defs[COB_CHK_ODO] = 1; + output_stmt (check); + } + } + } if (p->flag_all) { + /* note: no runtime check for index, because set by this code */ output_search_all (p->table, fp, p->at_end, CB_IF (p->whens)->test, CB_IF (p->whens)->stmt1); } else { + /* note: no runtime check for index, because if too big -> AT END */ output_search_whens (p->table, fp, p->at_end, p->var, p->whens); } } @@ -9903,27 +9930,27 @@ output_report_def_fields (int bgn, int id, struct cb_field *f, struct cb_report } } val[i] = 0; - output_local("\"%s\",%d,", val, (int)ref_size); - cobc_free((void*) val); + output_local ("\"%s\",%d,", val, (int)ref_size); + cobc_free ((void*) val); /* CHECKME: What about CB_CONST_P (ZERO/SPACE/QUOTE) ? */ } else { - output_local("NULL,0,"); + output_local ("NULL,0,"); } - if(f->step_count < f->size) + if (f->step_count < f->size) f->step_count = f->size; - if(f->report_column <= 0) /* No COLUMN was given */ + if (f->report_column <= 0) /* No COLUMN was given */ f->report_column = 1; - if(f->children) + if (f->children) f->report_flag |= COB_REPORT_GROUP_ITEM; - if(f->report_when) + if (f->report_when) f->report_flag |= COB_REPORT_HAD_WHEN; - if((f->report_flag&~(COB_REPORT_EMITTED|COB_REPORT_COLUMN_PLUS)) == 0) { - output_local("0,%d",f->report_line); - }else - if(subscript > 0) { - output_local("0x%X,%d",f->report_flag&~(COB_REPORT_EMITTED|COB_REPORT_GROUP_ITEM),f->report_line); + if ((f->report_flag&~(COB_REPORT_EMITTED|COB_REPORT_COLUMN_PLUS)) == 0) { + output_local ("0,%d", f->report_line); + } else + if (subscript > 0) { + output_local ("0x%X,%d", f->report_flag&~(COB_REPORT_EMITTED|COB_REPORT_GROUP_ITEM), f->report_line); } else { - output_local("0x%X,%d",f->report_flag&~COB_REPORT_EMITTED,f->report_line); + output_local ("0x%X,%d", f->report_flag&~COB_REPORT_EMITTED, f->report_line); } if(subscript > 1) { idx = 1; @@ -9936,19 +9963,19 @@ output_report_def_fields (int bgn, int id, struct cb_field *f, struct cb_report } if(l) { x = CB_VALUE (l); - output_local(",%d",cb_get_int(x)); + output_local (",%d", cb_get_int (x)); } else if(idx > 2) { - output_local(",%d",colnum + (f->step_count * (subscript - idx + 1))); + output_local (",%d", colnum + (f->step_count * (subscript - idx + 1))); } else { - output_local(",%d",f->report_column + (f->step_count * (subscript-1))); + output_local (",%d", f->report_column + (f->step_count * (subscript - 1))); } } else { - output_local(",%d",f->report_column); + output_local (",%d",f->report_column); } - output_local(",%d,%d",f->step_count,f->next_group_line); - output_local(",%d",f->level); - output_local(",0,0"); /* reportio flags: group_indicate & suppress */ + output_local (",%d,%d", f->step_count, f->next_group_line); + output_local (",%d", f->level); + output_local (",0,0"); /* reportio flags: group_indicate & suppress */ output_local ("};\n"); } @@ -10249,7 +10276,7 @@ output_report_definition (struct cb_report *p, struct cb_report *n) cb_tree l; output_local("\n"); - for(i= p->num_lines-1; i >= 0; i--) { + for(i= p->num_lines - 1; i >= 0; i--) { if(p->line_ids[i]->level == 1) output_report_define_lines(1,p->line_ids[i], p); } @@ -10263,7 +10290,7 @@ output_report_definition (struct cb_report *p, struct cb_report *n) output_local ("\n"); } sum_prv = 0; - for (i= p->num_lines-1; i >= 0; i--) { + for (i= p->num_lines - 1; i >= 0; i--) { if (p->line_ids[i]->level == 1) { output_report_sum_counters (1, p->line_ids[i], p); } @@ -10550,7 +10577,7 @@ output_field_display (struct cb_field *f, size_t offset, && f->storage != CB_STORAGE_LINKAGE) { output_param (x, 0); } else { - output ("COB_SET_FLD (%s, ", "f0"); + output ("COB_SET_FLD (f0, "); output_size (x); output (", "); output_data (x); @@ -10732,7 +10759,7 @@ output_display_fields (struct cb_field *f, size_t offset, unsigned int idx) && f->storage != CB_STORAGE_LINKAGE) { output ("%s%d", CB_PREFIX_FIELD, f->id); } else { - output ("COB_SET_FLD (%s, %d, NULL, ", "f0", f->size); + output ("COB_SET_FLD (f0, %d, NULL, ", f->size); output_attr (cb_build_field_reference (f, NULL)); output (")"); } diff --git a/cobc/field.c b/cobc/field.c index 24978ee06..024325638 100644 --- a/cobc/field.c +++ b/cobc/field.c @@ -3041,7 +3041,27 @@ cleanup_field_value (struct cb_field* f, cb_tree *val) } break; case CB_CATEGORY_NATIONAL: - /* FIXME: Fall-through, but should handle national space */ + if (CB_LITERAL_P (*val)) { + const struct cb_literal *lit = CB_LITERAL (*val); + char *p = (char*)lit->data; + char *end = p + lit->size - 1; + if (lit->size % COB_NATIONAL_SIZE != 0) { + break; + } + if (*end == ' ') { + while (p < end && p[0] == 0x00 && p[1] == ' ') p += 2; + if (p == end) *val = cb_space; + } + } + if (*val == cb_space + && !f->flag_internal_register + && ( cb_default_byte == CB_DEFAULT_BYTE_INIT) + && ( f->storage == CB_STORAGE_WORKING + || f->storage == CB_STORAGE_LOCAL) + && !f->children) { + return 1; + } + break; case CB_CATEGORY_ALPHANUMERIC: if (CB_LITERAL_P (*val)) { const struct cb_literal *lit = CB_LITERAL (*val); @@ -3587,6 +3607,7 @@ cb_is_figurative_constant (const cb_tree x) || x == cb_norm_high || x == cb_quote || (CB_REFERENCE_P (x) + && CB_REFERENCE (x)->subs == NULL && CB_REFERENCE (x)->flag_all); } diff --git a/cobc/reserved.c b/cobc/reserved.c index bfbf41221..f45b8b8a4 100644 --- a/cobc/reserved.c +++ b/cobc/reserved.c @@ -241,6 +241,7 @@ static struct system_name_struct *lookup_system_name (const char *, const int); /* Reserved word table, note: this list is sorted on startup in (initialize_reserved_words_if_needed), no need to care for EBCDIC */ + /* Description */ /* Word # Statement has terminator # Is context sensitive (only for printing) @@ -601,7 +602,7 @@ static struct cobc_reserved default_reserved_words[] = { /* FIXME + Check: 2014 Context-sensitive to COLUMN clause */ }, { "CENTERED", 0, 1, CENTERED, /* ACU extension */ - 0, CB_CS_DISPLAY + 0, CB_CS_DISPLAY }, { "CENTERED-HEADINGS", 0, 1, CENTERED_HEADINGS, /* ACU extension */ 0, CB_CS_GRAPHICAL_CONTROL | CB_CS_INQUIRE_MODIFY @@ -3937,7 +3938,7 @@ static const unsigned char pcob_lower_val[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; #endif struct list_reserved_line { - char *word_and_status; + char *word_and_status; char *aliases; }; @@ -4190,7 +4191,7 @@ search_reserved_list (const char * const word, const int needs_uppercasing, static char upper_word[COB_MAX_WORDLEN + 1]; size_t word_len; const char *sought_word; - struct cobc_reserved to_find; + struct cobc_reserved to_find; if (needs_uppercasing) { word_len = strlen (word) + 1; @@ -4221,24 +4222,21 @@ find_default_reserved_word (const char * const word, const int needs_uppercasing static struct cobc_reserved get_user_specified_reserved_word (struct amendment_list user_reserved) { - struct cobc_reserved cobc_reserved = create_dummy_reserved (NULL); - struct cobc_reserved *p; - - cobc_reserved.name = cobc_main_malloc (strlen (user_reserved.word) + 1); - strcpy ((char *) cobc_reserved.name, user_reserved.word); + struct cobc_reserved compiler_reserved = create_dummy_reserved (NULL); + compiler_reserved.name = cobc_main_strdup (user_reserved.word); if (!user_reserved.alias_for) { - cobc_reserved.context_sens + compiler_reserved.context_sens = !!user_reserved.is_context_sensitive; } else { - p = find_default_reserved_word (user_reserved.alias_for, 0); + struct cobc_reserved *p = find_default_reserved_word (user_reserved.alias_for, 0); if (p) { - cobc_reserved.token = p->token; - if (user_reserved.is_context_sensitive) { - cobc_reserved.context_sens = - !!user_reserved.is_context_sensitive; - cobc_reserved.context_test = p->context_test; - } + compiler_reserved.token = p->token; + if (user_reserved.is_context_sensitive) { + compiler_reserved.context_sens = + !!user_reserved.is_context_sensitive; + compiler_reserved.context_test = p->context_test; + } } else { /* FIXME: can we point to the fname originally defining the word? */ configuration_error (NULL, 0, 1, @@ -4247,7 +4245,7 @@ get_user_specified_reserved_word (struct amendment_list user_reserved) } } - return cobc_reserved; + return compiler_reserved; } static int @@ -4570,7 +4568,7 @@ get_reserved_words_with_amendments (void) add_reserved_word_to_map (reserved, 0); free_amendment_content (amendment_map[i]); - free_amendment_with_key (i); + free_amendment_with_key (i); } } diff --git a/cobc/scanner.l b/cobc/scanner.l index 04fd7b33d..a64760f2d 100644 --- a/cobc/scanner.l +++ b/cobc/scanner.l @@ -1,5 +1,5 @@ /* - Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. + Copyright (C) 2001-2012, 2014-2023 Free Software Foundation, Inc. Written by Keisuke Nishida, Roger While, Simon Sobisch, Edwart Hart, Ron Norman @@ -1313,7 +1313,7 @@ error_literal (const char *type, const char *literal, unsigned int literal_error } #endif } - cb_error ("%s", err_msg); + cb_note (COB_WARNOPT_NONE, 0, "%s", err_msg); } /* Scans a symbolic EBCDIC character given as a sequence of decimal digits @@ -1479,6 +1479,7 @@ read_literal (const char mark, const enum cb_literal_type type) _("national literal has zero length; a SPACE will be assumed") : _("alphanumeric literal has zero length; a SPACE will be assumed") ); + /* note: space gets UTF-16 converted down below */ plex_buff[i++] = ' '; } else if (i > cb_lit_length) { i = cb_lit_length; @@ -1494,7 +1495,7 @@ read_literal (const char mark, const enum cb_literal_type type) } else { /* poor-man's conversion iso-8859 -> utf-16 */ /* "!a0" = x'21613000' -> nx'00210061003000' */ - size_t new_size = i * 2; + size_t new_size = i * COB_NATIONAL_SIZE; if (new_size + 1 > plex_size) { plex_size = new_size + 1; plex_buff = cobc_realloc (plex_buff, plex_size); @@ -1505,7 +1506,6 @@ read_literal (const char mark, const enum cb_literal_type type) plex_buff[i * 2 + 1] = plex_buff [i]; plex_buff[i * 2] = 0; } - i = new_size; if (type != CB_LITERAL_NC) { if (cb_verify (cb_national_literals, _("national literal"))) { CB_UNFINISHED (_("national literal")); @@ -1515,7 +1515,7 @@ read_literal (const char mark, const enum cb_literal_type type) CB_UNFINISHED (_("national literal")); } } - yylval = cb_build_national_literal (plex_buff, i); + yylval = cb_build_national_literal (plex_buff, new_size); } } @@ -1539,16 +1539,19 @@ scan_x (const char *text, const char *type) curr_len = strlen (text); curr_len--; if (curr_len == 0) { - cb_verify (cb_zero_length_lit, _("zero-length literal")); - memset (plex_buff, 0, 5); + /* CHECKME: should this always be active or only with x"" ? */ + (void)cb_verify (cb_zero_length_lit, _("zero-length literal")); cb_warning (COBC_WARN_FILLER, - _("hexadecimal literal has zero length; X'00' will be assumed")); + _("hexadecimal literal has zero length; X'00' will be assumed")); + memset (plex_buff, 0, 5); if (type[0] == 'B') { yylval = cb_build_numeric_literal (0, "0", 0); + (void)cb_verify (cb_hexadecimal_boolean, _("hexadecimal-boolean literal")); } else if (type[0] != 'N') { yylval = cb_build_alphanumeric_literal (plex_buff, 1); - } else { - yylval = cb_build_national_literal (plex_buff, 1); + } else /* type N */ { + (void)cb_verify (cb_national_hex_literals, _("hexadecimal-national literal")); + yylval = cb_build_national_literal (plex_buff, COB_NATIONAL_SIZE); } RETURN_TOK (LITERAL); } @@ -1579,14 +1582,15 @@ scan_x (const char *text, const char *type) (unsigned long) result_len, 64); error_literal (type, plex_buff, literal_error++); /* we'll get an overflow below, but that's no problem, - an alternative would be to incement *text to only parse 64 / 4 + an alternative would be to increment *text to only parse 64 / 4 characters but that leads to not verified data, which is more important as the compilation will error-exit in any case */ } } else /* type N */ { result_len = curr_len / (2 * COB_NATIONAL_SIZE); if (!cb_verify (cb_national_hex_literals, _("hexadecimal-national literal"))) { - yylval = cb_build_national_literal ("", 1); + memset (plex_buff, 0, 5); + yylval = cb_build_national_literal (plex_buff, COB_NATIONAL_SIZE); RETURN_TOK (LITERAL); } else { CB_UNFINISHED (_("national literal")); @@ -1694,7 +1698,7 @@ scan_z (const char *text, const char *type) if (curr_len == 1) { curr_len--; - snprintf (err_msg, COB_MINI_MAX, + snprintf (err_msg, COB_MINI_MAX, _("%s literals must contain at least one character"), type); error_literal (type, "", 0); @@ -1747,7 +1751,10 @@ scan_h (const char *text, const char *type) if (type[1] != '#') { curr_len--; if (curr_len == 0) { - cb_error (_("H literals must contain at least one character")); + snprintf (err_msg, COB_MINI_MAX, + _("%s literals must contain at least one character"), + "H"); + error_literal ("H", "", 0); yylval = cb_build_numeric_literal (0, "0", 0); RETURN_TOK (LITERAL); } @@ -1827,7 +1834,7 @@ scan_b (const char *text, const char *type) if (curr_len == 1) { cb_verify (cb_zero_length_lit, _("zero-length literal")); cb_warning (COBC_WARN_FILLER, - _("Boolean literal has zero length; B'0' will be assumed")); + _("boolean literal has zero length; B'0' will be assumed")); } if (curr_len <= 1) { /* FIXME: we should really build a boolean literal... */ @@ -1854,7 +1861,7 @@ scan_b (const char *text, const char *type) (unsigned long) curr_len, 64); error_literal (type, plex_buff, literal_error++); /* we'll get an overflow below, but that's no problem, - an alternative would be to incement *text to only parse 64 / 4 + an alternative would be to increment *text to only parse 64 / 4 characters but that leads to not verified data, which is more important as the compilation will error-exit in any case */ } diff --git a/cobc/tree.c b/cobc/tree.c index b3a949248..527259e36 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -1615,15 +1615,11 @@ cb_tree_type (const cb_tree x, const struct cb_field *f) int cb_fits_int (const cb_tree x) { - struct cb_literal *l; - struct cb_field *f; - const char *s; - const unsigned char *p; - size_t size; - switch (CB_TREE_TAG (x)) { - case CB_TAG_LITERAL: - l = CB_LITERAL (x); + case CB_TAG_LITERAL: { + const struct cb_literal *l = CB_LITERAL (x); + const unsigned char *p; + size_t size; if (l->scale > 0) { return 0; } @@ -1638,18 +1634,21 @@ cb_fits_int (const cb_tree x) } if (size > 10) { return 0; - } - if (l->sign < 0) { - s = "2147483648"; - } else { - s = "2147483647"; - } - if (memcmp (p, s, 10U) > 0) { - return 0; + } else { /* size exactly 10 */ + const char *s; + if (l->sign < 0) { + s = "2147483648"; + } else { + s = "2147483647"; + } + if (memcmp (p, s, 10U) > 0) { + return 0; + } } return 1; - case CB_TAG_FIELD: - f = CB_FIELD (x); + } + case CB_TAG_FIELD: { + const struct cb_field *f = CB_FIELD (x); if (f->children) { return 0; } @@ -1689,10 +1688,13 @@ cb_fits_int (const cb_tree x) default: return 0; } + } case CB_TAG_REFERENCE: return cb_fits_int (CB_REFERENCE (x)->value); case CB_TAG_INTEGER: return 1; + case CB_TAG_CAST: + return cb_fits_int (CB_CAST (x)->val); default: if (x == cb_zero) { return 1; @@ -1704,14 +1706,11 @@ cb_fits_int (const cb_tree x) int cb_fits_long_long (const cb_tree x) { - struct cb_literal *l; - struct cb_field *f; - const char *s; - const unsigned char *p; - size_t size; - switch (CB_TREE_TAG (x)) { - case CB_TAG_LITERAL: + case CB_TAG_LITERAL: { + const struct cb_literal *l = CB_LITERAL (x); + const unsigned char *p; + size_t size; l = CB_LITERAL (x); if (l->scale > 0) { return 0; @@ -1727,18 +1726,21 @@ cb_fits_long_long (const cb_tree x) } if (size > 19) { return 0; - } - if (l->sign < 0) { - s = "9223372036854775808"; - } else { - s = "9223372036854775807"; - } - if (memcmp (p, s, 19U) > 0) { - return 0; + } else { /* size exactly 19 */ + const char *s; + if (l->sign < 0) { + s = "9223372036854775808"; + } else { + s = "9223372036854775807"; + } + if (memcmp (p, s, 19U) > 0) { + return 0; + } } return 1; - case CB_TAG_FIELD: - f = CB_FIELD (x); + } + case CB_TAG_FIELD: { + const struct cb_field *f = CB_FIELD (x); if (f->children) { return 0; } @@ -1777,10 +1779,13 @@ cb_fits_long_long (const cb_tree x) default: return 0; } + } case CB_TAG_REFERENCE: return cb_fits_long_long (CB_REFERENCE (x)->value); case CB_TAG_INTEGER: return 1; + case CB_TAG_CAST: + return cb_fits_long_long (CB_CAST (x)->val); default: if (x == cb_zero) { return 1; @@ -2818,7 +2823,7 @@ cb_concat_literals (const cb_tree x1, const cb_tree x2) char lit_out[39] = { 0 }; literal_for_diagnostic (lit_out, (void *)p->data); cb_error_x (x1, _("invalid literal: '%s'"), lit_out); - cb_error_x (x1, _("literal length %d exceeds %d characters"), + cb_note_x (COB_WARNOPT_NONE, x1, _("literal length %d exceeds %d characters"), p->size, cb_lit_length); return cb_error_node; } @@ -4153,11 +4158,13 @@ cb_field_variable_size (const struct cb_field *f) struct cb_field *fc; for (fc = f->children; fc; fc = fc->sister) { + if (fc->flag_picture_l) { + continue; /* seen as fixed-size */ + } if (fc->depending) { return fc; - } else if (fc->flag_picture_l) { - continue; - } else if ((p = cb_field_variable_size (fc)) != NULL) { + } + if ((p = cb_field_variable_size (fc)) != NULL) { return p; } } @@ -5885,7 +5892,7 @@ cb_build_binary_op (cb_tree x, const enum cb_binary_op_op op, cb_tree y) case '+': case '-': case '*': - sprintf(result, CB_FMT_LLD, rslt); + sprintf (result, CB_FMT_LLD, rslt); return cb_build_numeric_literal (0, result, rscale); break; case '/': @@ -5894,14 +5901,14 @@ cb_build_binary_op (cb_tree x, const enum cb_binary_op_op op, cb_tree y) break; } if (rslt != 0) { - sprintf(result, CB_FMT_LLD, rslt); + sprintf (result, CB_FMT_LLD, rslt); return cb_build_numeric_literal (0, result, rscale); } /* only calculate simple integer numerics */ if (xl->scale != 0 || yl->scale != 0) break; if ((xval % yval) == 0) { - sprintf(result, CB_FMT_LLD, xval / yval); + sprintf (result, CB_FMT_LLD, xval / yval); return cb_build_numeric_literal (0, result, rscale); } break; diff --git a/cobc/tree.h b/cobc/tree.h index c0645b3f8..53c7725d2 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -512,10 +512,10 @@ enum cb_index_type { struct cobc_reserved { const char *name; /* Word */ unsigned short nodegen; /* Statement with END-xxx */ - unsigned short context_sens; /* Context sensitive */ + unsigned short context_sens; /* Context sensitive (needed for user-amendmends) */ int token; /* Token */ - unsigned int context_set; /* Set context sensitive */ - unsigned int context_test; /* Test context sensitive */ + unsigned int context_set; /* context sensitive value set */ + unsigned int context_test; /* context sensitive value tested */ }; /* Basic common tree structure */ diff --git a/cobc/typeck.c b/cobc/typeck.c index 8ed475996..ec85af611 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -12078,6 +12078,22 @@ cb_build_move_field (cb_tree src, cb_tree dst) } src_size = cb_field_size (src); dst_size = cb_field_size (dst); + if (src_size == -1 + && dst_size == -1 + && CB_REFERENCE_P (src) + && CB_REFERENCE_P (dst)) { + /* check for same length, allowing us to do an optimized copy + case: MOVE VAR1 (POS1:LEN) TO VAR2 (POS2:LEN) */ + const struct cb_reference *r_src = CB_REFERENCE (src); + const struct cb_reference *r_dst = CB_REFERENCE (dst); + if (r_src->length && r_dst->length + && CB_REFERENCE_P (r_src->length) + && CB_REFERENCE_P (r_dst->length) + && CB_REFERENCE (r_src->length)->value + == CB_REFERENCE (r_dst->length)->value) { + src_size = dst_size = 1; + } + } if (src_size > 0 && dst_size > 0 && src_size >= dst_size && !cb_field_variable_size (src_f) && !cb_field_variable_size (dst_f)) { @@ -12161,6 +12177,7 @@ cb_build_move (cb_tree src, cb_tree dst) } if (current_program->flag_report) { + /* FIXME: too much for SUM field */ src = cb_check_sum_field (src); dst = cb_check_sum_field (dst); } diff --git a/config/ChangeLog b/config/ChangeLog index f9459fb62..882fcd3d7 100644 --- a/config/ChangeLog +++ b/config/ChangeLog @@ -1,4 +1,9 @@ +2023-03-22 Simon Sobisch + + * rm-strict.conf: enable line-col-zero-default per RM-COBOL Language + Reference for POSITION with implied zero + 2023-02-21 Simon Sobisch * rm-strict.conf: enable indirect-redefines as this was added diff --git a/config/rm-strict.conf b/config/rm-strict.conf index b51226e2b..f306de422 100644 --- a/config/rm-strict.conf +++ b/config/rm-strict.conf @@ -165,7 +165,7 @@ no-echo-means-secure: no # If yes, the first item in a field screen ACCEPT/DISPLAY (e.g. DISPLAY x UPON # CRT) is located after the previous ACCEPT/DISPLAY (as though LINE 0 COL 0 had # been specified). -line-col-zero-default: no +line-col-zero-default: yes # If yes, DISPLAY SPACES acts as ERASE EOS, DISPLAY X"01" acts as ERASE EOL, # DISPLAY X"02" acts as BLANK SCREEEN and DISPLAY X"07" acts as BELL. Note diff --git a/configure.ac b/configure.ac index 5d2552520..62c5b204a 100644 --- a/configure.ac +++ b/configure.ac @@ -1305,7 +1305,7 @@ if test "x$CURSES_LIBS" = x; then fi fi if test "$USE_CURSES" = "pdcurses" -o "x$ac_cv_lib_pdcurses_initscr" = xyes; then - AC_CHECK_HEADERS([pdcurses.g curses.h], + AC_CHECK_HEADERS([pdcurses.h curses.h], [USE_CURSES="pdcurses" break], [AS_IF([test "$USE_CURSES" != check],