From 77a5b506f1bd0eb392c462534324d5a1dd2034d6 Mon Sep 17 00:00:00 2001 From: ddeclerck Date: Mon, 2 Sep 2024 11:45:07 +0000 Subject: [PATCH] Merged revisions 4884-4891, 4894-4899, 4903, 4905, 5140, 5149, 5308, 5315-5318 from branches/gnucobol-3.x: ........ Fix bugs reported by the MSVC runtime checker cobc: * tree.c (char_to_precedence_idx, get_char_type_description, valid_char_order): adjusted size of precedence table and gave proper precedence to U libcob: * intrinsics.c (cob_intr_random), move.c (cob_move_display_to_packed): make casts with loss of data explicit using masking to silence the MSVC runtime error checker ........ Retrieve archive of NIST test suite from sourceforge instead of from an out-dated URL * tests/cobol85/Makefile.am: stop downloading "newcob.val.Z" from out-dated URL ........ Remove debugapi.h include from common.c - follow-up to r5315 ........ Disable Windows error popups in programs compiled with MSVC * libcob/common.c (DllMain) [_MSC_VER]: added calls to _CrtSetReportMode to disable Windows error popups and redirect them to stderr ........ Testuite fixes for MSVC * testsuite.src/run_file.at, testsuite.src/run_misc.at: fix a few tests that break under MSVC Debug while working under MSVC Release, by forcing a flush of stdout with fflush and using cob_free instead of free in C codes ........ portability adjustment of testcase from [r5140], not checking the (system-specific) warning text ........ runtime warnings with more details if loading of modules / entry points does not work libcob/call.c: * (cache_preload): runtime warning if preloading from existing path does not work * (cob_try_preload): runtime warning if preloading of requested module does not w * (cob_resolve_internal): runtime warning if loading module from existing path or resolving requested entry point does not workork ........ fixed some minor analyzer warnings ........ fixing [bugs:#758] "half included -R option" cobc/cobc.c (short_options): removed -R which was originally added with [r1059] and only dropped from evaluation but not from command line options with [r1125] ........ cobc options for (make) dependencies are back cobc: * cobc.c, cobc.h, pplex.l (ppopen), help.c: restored -MT and -MF options as they were available in GnuCOBOL 1.1 (adjusted to current code) * cobc.c (process_command_line): handle multiple -MT options like GCC * ChangeLog: integrated cobpp ChangeLog entries and added some historic changes from VCS log/diff ........ fileio fixes, especially for LSQ files libcob/fileio.c: * (save_status): rewritten to care for any sucessful completion (status 0x) instead of only on status 00 to not set an exception and to sync if COB_SYNC is active * (lineseq_read): use the locale setup for printable check in sequential data verification instead of libcob's internal one * for line sequential data verification only call isprint when cob_ls_validate > 1 (not configurable yet), use new macro IS_NOT_PRINTABLE for this check and execute it on both read and (re)write, resulting in status 0P now * fixed call of isprint on EBCDIC machines * [!COB_EXPERIMENTAL]: disable "new" status 0P via preprocessor to inspect later for either include as COB_LS_VALIDATE=PRINT or drop ........ header cleanup cobc/codegen.c (output_standard_includes): don't include stdio.h in generated programs ........ revert tests/cobol85/expand.pl ........ option to prevent unloading, internally set on abort libcob: * common.c (cob_hard_failure, cob_hard_failure_internal), call.c (cob_exit_call): skip unloading of modules for COB_CORE_ON_ERROR=2 to keep symbols in coredumps using cob_physical_cancel=-1 internally * call.c (close_and_free_module_list): extracted from cob_exit_call * common.c (get_config_val, set_config_val, translate_boolean_to_int): allow "boolean" values to be set to a third value via enum, new enum "never" used for COB_PHYSICAL_CANCEL (and prepared: "not_set"), to prevent unloading, which is useful for analysis tools like callgrind or perf to keep all symbols until end of the COBOL process additional tests/cobol85: * Makefile.am: always set COB_UNIX_LF for executing EXEC85 - to be identical to the later testsuite run * expand.pl: minor cleanup ........ minor cleanup for NIST test preparation tests/cobol85/Makefile.am: * ensure to not create half-baked module directories * added target "modules" as .PHONY entry ........ warning adjustment for -Wgoto-section cobc/typeck.c (cb_validate_labels): don't warn on GO TO own SECTION ........ Move cconv to libcob - fix c99 of [r4888] ........ Move cconv to libcob - fix win32 part of [r4888] libcob: * cconv.c adjusted includes per common.c * common.h: adjusted cconv module exports like others build_windows: * general for libcob+cobc: handle move of cconv module ........ Move cconv to libcob - sources for r4887 which only contained testsuite changes libcob: * conv.c: file moved from cobc to libcob * common.h: declare the new API for collating sequences cobc: * conv.c, conv.h: files moved from cobc to libcob * codegen.c: use the new libcob API for collating sequences * flag.def: change "ebcdic-table" to a flag with associated variable ........ Move cconv to libcob libcob: * conv.c: file moved from cobc to libcob * common.h: declare the new API for collating sequences cobc: * conv.c, conv.h: files moved from cobc to libcob * codegen.c: use the new libcob API for collating sequences * flag.def: change "ebcdic-table" to a flag with associated variable ........ minimal "parsing support" for USAGE UTF-8 and UTF-8 literals cobc: * tree.c: initial support for PIC U, for now handled as alphanumeric with size * 4 * scanner.l: minimal parsing for utf-8 literals * reserved.c, cobc.h (CB_CS_USAGE), parser.y: parsing for USAGE UTF-8 and the related BYTE-LENGTH clause * field.c, tree.c, typeck.c: minimal adjustments for PIC U ........ optimization for MOVE to edited fields libcob/move.c (cob_move_display_to_edited): several optimizations, the biggest one stays open, as it would need an adjusted function call from cobc (TBDL) ........ work on improved debugging experience and refactoring cobc: * codegen.c (output_label, output_label_c): extracted from output_stmt * codegen.c (output_label_c): added output of C labels for paragraphs using prefix PARAGRAPH and, to make them distinct, its label id as suffix * codegen.c (output_search_all, output_search_whens): if no AT END position token is available, use the start token instead * typeck.c (cb_emit_search, cb_emit_search_all), tree.h: return created search tree * parser.y (_end_search): if search has no AT END create an implicit one at END-SEARCH for better trace and debugging * codegen.c (output_assign, output_if, output_debug_item): extracted from output_stmt * typeck.c (cb_emit, cb_emit_list): changed from defines to inline functions, now returning the tree that was emitted ........ --- ChangeLog | 7 +- NEWS | 64 +- TODO | 51 + build_windows/ChangeLog.txt | 4 + build_windows/ocide/libcob.dll.cpj | 2 + build_windows/vs2008/cobc.vcproj | 8 - build_windows/vs2008/libcob.vcproj | 4 + build_windows/vs2010/cobc.vcxproj | 2 - build_windows/vs2010/cobc.vcxproj.filters | 6 - build_windows/vs2010/libcob.vcxproj | 4 +- build_windows/vs2010/libcob.vcxproj.filters | 4 + build_windows/vs2012/cobc.vcxproj | 2 - build_windows/vs2012/cobc.vcxproj.filters | 6 - build_windows/vs2012/libcob.vcxproj | 4 +- build_windows/vs2012/libcob.vcxproj.filters | 4 + build_windows/vs2013/cobc.vcxproj | 2 - build_windows/vs2013/cobc.vcxproj.filters | 6 - build_windows/vs2013/libcob.vcxproj | 4 +- build_windows/vs2013/libcob.vcxproj.filters | 4 + build_windows/vs2015/cobc.vcxproj | 2 - build_windows/vs2015/cobc.vcxproj.filters | 6 - build_windows/vs2015/libcob.vcxproj | 4 +- build_windows/vs2015/libcob.vcxproj.filters | 4 + build_windows/vs2017/cobc.vcxproj | 2 - build_windows/vs2017/cobc.vcxproj.filters | 6 - build_windows/vs2017/libcob.vcxproj | 4 +- build_windows/vs2017/libcob.vcxproj.filters | 4 + build_windows/vs2019/cobc.vcxproj | 2 - build_windows/vs2019/cobc.vcxproj.filters | 6 - build_windows/vs2019/libcob.vcxproj | 4 +- build_windows/vs2019/libcob.vcxproj.filters | 4 + cobc/ChangeLog | 362 +++-- cobc/Makefile.am | 6 +- cobc/cconv.h | 77 - cobc/cobc.c | 61 +- cobc/cobc.h | 3 + cobc/codegen.c | 1398 +++++++++---------- cobc/field.c | 2 +- cobc/flag.def | 2 +- cobc/help.c | 3 + cobc/parser.y | 60 +- cobc/pplex.l | 23 +- cobc/reserved.c | 11 +- cobc/scanner.l | 23 +- cobc/tree.c | 105 +- cobc/tree.h | 6 +- cobc/typeck.c | 63 +- config/runtime.cfg | 6 +- libcob/ChangeLog | 85 +- libcob/Makefile.am | 2 +- libcob/call.c | 100 +- {cobc => libcob}/cconv.c | 146 +- libcob/coblocal.h | 9 + libcob/common.c | 164 ++- libcob/common.h | 29 +- libcob/fileio.c | 207 ++- libcob/fileio.h | 2 +- libcob/intrinsic.c | 16 +- libcob/move.c | 199 +-- libcob/numeric.c | 7 +- libcob/screenio.c | 6 +- po/ChangeLog | 4 + tests/ChangeLog | 7 + tests/cobol85/ChangeLog | 10 + tests/cobol85/Makefile.am | 25 +- tests/cobol85/expand.pl | 2 +- tests/testsuite.src/configuration.at | 8 +- tests/testsuite.src/listings.at | 12 +- tests/testsuite.src/run_file.at | 2 + tests/testsuite.src/run_fundamental.at | 10 +- tests/testsuite.src/run_misc.at | 45 +- tests/testsuite.src/syn_copy.at | 12 +- tests/testsuite.src/syn_definition.at | 22 +- tests/testsuite.src/syn_file.at | 4 +- tests/testsuite.src/syn_misc.at | 6 +- tests/testsuite.src/used_binaries.at | 31 +- 76 files changed, 2170 insertions(+), 1449 deletions(-) delete mode 100644 cobc/cconv.h rename {cobc => libcob}/cconv.c (80%) diff --git a/ChangeLog b/ChangeLog index 8af2a8eae..9f42bfb1f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1424,8 +1424,7 @@ 2003-04-19 Keisuke Nishida * cob.pc.in: Removed. - - * cobpp: Removed. + * cobpp: integrated into cobc (ChangeLog entries moved there) 2002-03-01 Keisuke Nishida @@ -1581,6 +1580,10 @@ * configure.ac, Makefile.am: Rename 'COB_LDADD' to 'COB_LIBS' +2002-05-23 Keisuke Nishida + + * configure.ac.c: additions for use of gettext + 2002-05-19 Keisuke Nishida * Version 0.9.5 released. diff --git a/NEWS b/NEWS index 72f3e9ed6..f373f273f 100644 --- a/NEWS +++ b/NEWS @@ -6,7 +6,7 @@ NEWS - user visible changes -*- outline -*- a previous version; the internal library-number was therefore increased (libcob-5 instead of libcob-4). - *** previous versions compiled into the application module data structures + *** previous versions compiled into the application module data structures used by the run-time library, making it extremely difficult to expand the data structures for new functionality. An internal function calls were added that now generate the data structures and are completely @@ -129,12 +129,20 @@ Open Plans: ** Initial "testing support" of CODE-SET clause to convert between ASCII and EBCDIC on READ/WRITE/REWRITE for sequential and line-sequential files +** minimal "parsing support" for USAGE UTF-8 and UTF-8 literals + ** Support to exit the runtime from COBOL as hard error (including possible [core-]dump and stacktrace) with "STOP ERROR" statement or by CALL "CBL_RUNTIME_ERROR" +** COB_PHYSICAL_CANCEL may now be configured as "never" to prevent unloading, + of COBOL modules, both on CANCEL and on process exit, which is useful for + analysis tools like callgrind or perf to keep all symbols until the end of + the COBOL process + ** TODO - More to document, possibly after rc-1 + * Changes that potentially effects existing programs: ** ALLOCATE statement: earlier versions of GnuCOBOL initialized the memory @@ -142,10 +150,11 @@ Open Plans: this isn't done anymore so if you need the memory to be initialized specify that explicit in the source and recompile -** LINE SEQUENTIAL files, data validation: in case of non-printable data - a READ may result in status 09 and WRITE may error with status 71; - to disable this validation see the new runtime option COB_LS_VALIDATE - to restore old behavior and to increase performance on WRITE; +** LINE SEQUENTIAL files, data validation: in case of bad printable data + (less than SPACE) a READ may result in io status 09 and WRITE may error + with io status 71; see the new runtime option COB_LS_VALIDATE to disable + this validation (= old behavior) and to increase performance on line + sequential file io; if LS_NULLS is active and invalid data (bad encoded or missing encoding) is found io status 71 is returned @@ -296,7 +305,8 @@ Open Plans: to use this extension for other dialects use the new -fself-call-recursive=warning (or "ok") -** the option -g does not longer imply -fsource-location +** the option -g does not longer imply -fsource-location; but it auto-includes + references to the COBOL-paragraphs to further ease source level debugging ** new flag -fstack-extended (implied with --debug and --dump) to include the origin of entrypoints and PERFORM, this is used for the internal @@ -327,6 +337,12 @@ Open Plans: ** new compiler command line option to list the known runtime exception names and fatality `cobc --list-exceptions` +** the command line options -MT and -MF, which are used for creating a + dependency list (used copybooks) to be used for inclusion in Makefiles + or other processes, and which were removed in GnuCOBOL 2 are back in their + original version; note: their use will be adjusted where they don't match + GCC's same options in later versions, including addition of -M and -MD + ** New -std options: gcos GCOS compatibility @@ -364,6 +380,9 @@ Open Plans: longer loading time and longer compile times; if you use those a recompile is highly suggested +** several bugs in COPY REPLACING / REPLACING were fixed along with adding + support for exensions related to REPLACING LEADING / TRAILING + * Listing changes ** the timestamp in the header was changed from ANSI date format like @@ -408,15 +427,15 @@ Open Plans: ** execution times were significantly reduced for the following: INSPECT that use big COBOL fields (multiple KB) + MOVE and comparisions (especially with enabled runtime checks, to + optimize those a re-compile is needed) CALL data-item, and first time for each CALL ACCEPT DATE/TIME/DAY and datetime related FUNCTIONs - MOVE with enabled runtime checks (only with re-compile) - -** execution times for programs that are new generated with -fsource-location - (implied with --debug/-fec) are cut down, especially when many "simple" - statements or lot of sections/paragraphs are used; also the runtime checks - for use of LINKAGE fields and/or subscripts/reference-modification will be - much faster + runtime checks for use of LINKAGE/BASED fields and/or + subscripts/reference-modification (re-compile needed) + general: execution of programs generated with -fsource-location + (implied with --debug and -fec), especially when many "simple" + statements or lot of sections/paragraphs are used (re-compile needed) * New build features @@ -426,16 +445,16 @@ Open Plans: (experimental) ** configure now checks for PERL and passes that as default to make test ** cobc handles SOURCE_DATE_EPOCH now, allowing to override timestamps in - generated code and listing files, allowing reproducible builds + generated code and listing files, allowing reproducible builds of both + GnuCOBOL (extras folder) and COBOL programs * Obsolete features (will be removed in the next version if no explicit user requests are raised) ** use of old non-GMP randomizer for FUNCTION RANDOM -* Known issues in 3.2 (and 3.1) -** 3.2 only: the testing and documentation for COB_CORE_ON_ERROR is unfinished +* Known issues in 3.2 (and 3.1) ** testsuite: * if built with vbisam, cisam or disam, depending on the version used, some @@ -451,12 +470,13 @@ Open Plans: as expected in all cases ** floating-point comparison for equality may return unexpected results as it - involves a necessary tolerance; we seek input for a reasonable default for - GnuCOBOL 4 (use the mailing list or discussion board to share your comments - on this topic, keep in mind that this has to take both mathematical and - "C compiler portability" into account); you may adjust the default - tolerance of 0.0000001 by compiling GnuCOBOL for example with - LIBCOB_CPPFLAGS="-DCOB_FLOAT_DELTA=0.0000000000001" + involves a necessary tolerance; you may adjust the default tolerance of + 0.0000001 by compiling GnuCOBOL for example with + LIBCOB_CPPFLAGS="-DCOB_FLOAT_DELTA=0.0000000000001"; + we seek input for a reasonable default for GnuCOBOL 4 (use the mailing list + or discussion board to share your comments on this topic, keeping in mind + that this has to take both mathematical and "C compiler portability" into + account) ** features that are known to not be portable to every environment yet (especially when using a different compiler than GCC) diff --git a/TODO b/TODO index 90a59742d..d2ba1c24e 100644 --- a/TODO +++ b/TODO @@ -169,7 +169,11 @@ l_exit: As a third alternative we can just add a flag that says "assume I never go out of a section". +4.3 optimizing cob_move_display_to_edited +This function is relative often called in production systems and +re-calculates the picture on runtime, which the compiler already +did - pass this information along with the call. 5 Debugging support @@ -185,8 +189,55 @@ access the COBOL data at debugging time. Note: GnuCOBOL 3 implemented this partially, using extensions near full GDB support is already possible. +GnuCOBOL 4 provides this quite complete at runtime, too. + + 6 Better user manual Yes, we should, for now: refer to the GnuCOBOL Programmer's Guide https://sourceforge.net/p/gnucobol/code/HEAD/tree/external-doc/guide/ + +7 Issues raised during forward-porting of 3.x patches + +7.1 General issues + +- Decide what to do about gcdiff, especially under MSVC + +- Correctly implement delay-loading under MSVC + +- Possibly drop usage of external cobxref + +- Fix any remaining failed test case + +- Rework the context-sensitive reserved words handling (or use a bigger type) + +7.2 CHECKMEs, TODOs and #if-0'ed code + +- Investigate the two CHECKMEs about bdb_close_cursor in fbdb.c:ix_bdb_write_internal + +- Investigate the CHECKMEs in typeck.c:validate_move and in particular why it was necessary to add CB_LITERAL_P (checks to add in parser) + +- Investigate the CHECKME about the need for comma in move.c:cob_move_display_to_edited (first in GC 3.x) + +- Investigate the CHECKME about moving cob_set_exception call in common.c:cob_module_global_enter + +- Check the TODO about cb_default_byte in codegen.c:output_initialize + +- Make status an enum instead of an int in fileio.c:cob_file_save_status as per TODO + +- Move the IO status codes from common.h to fileio.h as per TODO + +- Check the #if-0'ed code in field.c:validate_field_value + +- Check the #if-0'ed code for setting last_exception_source in common.c:cob_set_exception + +- Check the #if-0'ed code about EOP exception in fileio.c:cob_file_save_status + +7.3 Other issues + +- Investigate the need to define READ_WRITE_NEEDS_FLUSH under MacOS ("LINE SEQUENTIAL COMMIT / ROLLBACK" test fails if not defined) + +- Check if should use strcpy or memcpy with computed max-length for file_open_name in fileio.c:cob_open + +- Check what we should do about the casts used to remove const on open_mode in fileio.c and others (eg. in cob_file_open) diff --git a/build_windows/ChangeLog.txt b/build_windows/ChangeLog.txt index 8d10f5280..81f5388d7 100644 --- a/build_windows/ChangeLog.txt +++ b/build_windows/ChangeLog.txt @@ -13,6 +13,10 @@ * makedist.cmd: first addition for CI output * version_cobc.rc, version_libcob.rc: updated date + rev +2022-12-17 Simon Sobisch + + * general for libcob+cobc: handle move of cconv module + 2022-10-16 Simon Sobisch * version_cobfile.rc: new file diff --git a/build_windows/ocide/libcob.dll.cpj b/build_windows/ocide/libcob.dll.cpj index b0e560725..fced6bed8 100644 --- a/build_windows/ocide/libcob.dll.cpj +++ b/build_windows/ocide/libcob.dll.cpj @@ -34,12 +34,14 @@ + + diff --git a/build_windows/vs2008/cobc.vcproj b/build_windows/vs2008/cobc.vcproj index 9abbf9bb2..e5e50c182 100644 --- a/build_windows/vs2008/cobc.vcproj +++ b/build_windows/vs2008/cobc.vcproj @@ -183,10 +183,6 @@ Filter="cpp;c;cc;cxx;def;odl;idl;hpj;bat;asm;asmx" UniqueIdentifier="{4FC737F1-C7A5-4376-A066-2A32D752A2FF}" > - - @@ -337,10 +333,6 @@ Filter="h;hpp;hxx;hm;inl;inc;xsd" UniqueIdentifier="{93995380-89BD-4b04-88EB-625FBE52EBFB}" > - - diff --git a/build_windows/vs2008/libcob.vcproj b/build_windows/vs2008/libcob.vcproj index 64fd22b4c..d1bc293a2 100644 --- a/build_windows/vs2008/libcob.vcproj +++ b/build_windows/vs2008/libcob.vcproj @@ -193,6 +193,10 @@ RelativePath="..\..\libcob\call.c" > + + diff --git a/build_windows/vs2010/cobc.vcxproj b/build_windows/vs2010/cobc.vcxproj index 8015fb784..51a227da3 100644 --- a/build_windows/vs2010/cobc.vcxproj +++ b/build_windows/vs2010/cobc.vcxproj @@ -187,7 +187,6 @@ - @@ -333,7 +332,6 @@ - diff --git a/build_windows/vs2010/cobc.vcxproj.filters b/build_windows/vs2010/cobc.vcxproj.filters index 5c4a0710c..732e84b6f 100644 --- a/build_windows/vs2010/cobc.vcxproj.filters +++ b/build_windows/vs2010/cobc.vcxproj.filters @@ -36,9 +36,6 @@ Source Files - - Source Files - Source Files @@ -251,9 +248,6 @@ Header Files - - Header Files - Header Files diff --git a/build_windows/vs2010/libcob.vcxproj b/build_windows/vs2010/libcob.vcxproj index a68fd904e..ebbd52243 100644 --- a/build_windows/vs2010/libcob.vcxproj +++ b/build_windows/vs2010/libcob.vcxproj @@ -170,6 +170,7 @@ + @@ -192,6 +193,7 @@ + @@ -219,4 +221,4 @@ - \ No newline at end of file + diff --git a/build_windows/vs2010/libcob.vcxproj.filters b/build_windows/vs2010/libcob.vcxproj.filters index 85f0012af..e62246a59 100644 --- a/build_windows/vs2010/libcob.vcxproj.filters +++ b/build_windows/vs2010/libcob.vcxproj.filters @@ -18,6 +18,9 @@ Source Files + + Source Files + Source Files @@ -119,6 +122,7 @@ Header Files + diff --git a/build_windows/vs2012/cobc.vcxproj b/build_windows/vs2012/cobc.vcxproj index 06388387c..6169e8f51 100644 --- a/build_windows/vs2012/cobc.vcxproj +++ b/build_windows/vs2012/cobc.vcxproj @@ -191,7 +191,6 @@ - @@ -337,7 +336,6 @@ - diff --git a/build_windows/vs2012/cobc.vcxproj.filters b/build_windows/vs2012/cobc.vcxproj.filters index 5c4a0710c..732e84b6f 100644 --- a/build_windows/vs2012/cobc.vcxproj.filters +++ b/build_windows/vs2012/cobc.vcxproj.filters @@ -36,9 +36,6 @@ Source Files - - Source Files - Source Files @@ -251,9 +248,6 @@ Header Files - - Header Files - Header Files diff --git a/build_windows/vs2012/libcob.vcxproj b/build_windows/vs2012/libcob.vcxproj index ef081e0a0..5c1847b20 100644 --- a/build_windows/vs2012/libcob.vcxproj +++ b/build_windows/vs2012/libcob.vcxproj @@ -172,6 +172,7 @@ + @@ -194,6 +195,7 @@ + @@ -221,4 +223,4 @@ - \ No newline at end of file + diff --git a/build_windows/vs2012/libcob.vcxproj.filters b/build_windows/vs2012/libcob.vcxproj.filters index 85f0012af..e62246a59 100644 --- a/build_windows/vs2012/libcob.vcxproj.filters +++ b/build_windows/vs2012/libcob.vcxproj.filters @@ -18,6 +18,9 @@ Source Files + + Source Files + Source Files @@ -119,6 +122,7 @@ Header Files + diff --git a/build_windows/vs2013/cobc.vcxproj b/build_windows/vs2013/cobc.vcxproj index 599b95a7e..303b4dc18 100644 --- a/build_windows/vs2013/cobc.vcxproj +++ b/build_windows/vs2013/cobc.vcxproj @@ -193,7 +193,6 @@ - @@ -339,7 +338,6 @@ - diff --git a/build_windows/vs2013/cobc.vcxproj.filters b/build_windows/vs2013/cobc.vcxproj.filters index 5c4a0710c..732e84b6f 100644 --- a/build_windows/vs2013/cobc.vcxproj.filters +++ b/build_windows/vs2013/cobc.vcxproj.filters @@ -36,9 +36,6 @@ Source Files - - Source Files - Source Files @@ -251,9 +248,6 @@ Header Files - - Header Files - Header Files diff --git a/build_windows/vs2013/libcob.vcxproj b/build_windows/vs2013/libcob.vcxproj index f3179d724..332353fbe 100644 --- a/build_windows/vs2013/libcob.vcxproj +++ b/build_windows/vs2013/libcob.vcxproj @@ -173,6 +173,7 @@ + @@ -195,6 +196,7 @@ + @@ -222,4 +224,4 @@ - \ No newline at end of file + diff --git a/build_windows/vs2013/libcob.vcxproj.filters b/build_windows/vs2013/libcob.vcxproj.filters index 85f0012af..e62246a59 100644 --- a/build_windows/vs2013/libcob.vcxproj.filters +++ b/build_windows/vs2013/libcob.vcxproj.filters @@ -18,6 +18,9 @@ Source Files + + Source Files + Source Files @@ -119,6 +122,7 @@ Header Files + diff --git a/build_windows/vs2015/cobc.vcxproj b/build_windows/vs2015/cobc.vcxproj index 94faa9985..45190313f 100644 --- a/build_windows/vs2015/cobc.vcxproj +++ b/build_windows/vs2015/cobc.vcxproj @@ -191,7 +191,6 @@ - @@ -337,7 +336,6 @@ - diff --git a/build_windows/vs2015/cobc.vcxproj.filters b/build_windows/vs2015/cobc.vcxproj.filters index 14274780e..3bb3682aa 100644 --- a/build_windows/vs2015/cobc.vcxproj.filters +++ b/build_windows/vs2015/cobc.vcxproj.filters @@ -36,9 +36,6 @@ Source Files - - Source Files - Source Files @@ -251,9 +248,6 @@ Header Files - - Header Files - Header Files diff --git a/build_windows/vs2015/libcob.vcxproj b/build_windows/vs2015/libcob.vcxproj index 907feda14..5fe4cbb31 100644 --- a/build_windows/vs2015/libcob.vcxproj +++ b/build_windows/vs2015/libcob.vcxproj @@ -164,6 +164,7 @@ + @@ -186,6 +187,7 @@ + @@ -213,4 +215,4 @@ - \ No newline at end of file + diff --git a/build_windows/vs2015/libcob.vcxproj.filters b/build_windows/vs2015/libcob.vcxproj.filters index 2d558a6ed..13c4c8997 100644 --- a/build_windows/vs2015/libcob.vcxproj.filters +++ b/build_windows/vs2015/libcob.vcxproj.filters @@ -18,6 +18,9 @@ Source Files + + Source Files + Source Files @@ -119,6 +122,7 @@ Header Files + diff --git a/build_windows/vs2017/cobc.vcxproj b/build_windows/vs2017/cobc.vcxproj index 3d07ba3dd..e7a1f930c 100644 --- a/build_windows/vs2017/cobc.vcxproj +++ b/build_windows/vs2017/cobc.vcxproj @@ -193,7 +193,6 @@ - @@ -339,7 +338,6 @@ - diff --git a/build_windows/vs2017/cobc.vcxproj.filters b/build_windows/vs2017/cobc.vcxproj.filters index 14274780e..3bb3682aa 100644 --- a/build_windows/vs2017/cobc.vcxproj.filters +++ b/build_windows/vs2017/cobc.vcxproj.filters @@ -36,9 +36,6 @@ Source Files - - Source Files - Source Files @@ -251,9 +248,6 @@ Header Files - - Header Files - Header Files diff --git a/build_windows/vs2017/libcob.vcxproj b/build_windows/vs2017/libcob.vcxproj index 8ce4ad83e..6f8b8a7cc 100644 --- a/build_windows/vs2017/libcob.vcxproj +++ b/build_windows/vs2017/libcob.vcxproj @@ -169,6 +169,7 @@ + @@ -191,6 +192,7 @@ + @@ -218,4 +220,4 @@ - \ No newline at end of file + diff --git a/build_windows/vs2017/libcob.vcxproj.filters b/build_windows/vs2017/libcob.vcxproj.filters index 2d558a6ed..13c4c8997 100644 --- a/build_windows/vs2017/libcob.vcxproj.filters +++ b/build_windows/vs2017/libcob.vcxproj.filters @@ -18,6 +18,9 @@ Source Files + + Source Files + Source Files @@ -119,6 +122,7 @@ Header Files + diff --git a/build_windows/vs2019/cobc.vcxproj b/build_windows/vs2019/cobc.vcxproj index ed90788b7..7b6d60932 100644 --- a/build_windows/vs2019/cobc.vcxproj +++ b/build_windows/vs2019/cobc.vcxproj @@ -193,7 +193,6 @@ - @@ -339,7 +338,6 @@ - diff --git a/build_windows/vs2019/cobc.vcxproj.filters b/build_windows/vs2019/cobc.vcxproj.filters index 14274780e..3bb3682aa 100644 --- a/build_windows/vs2019/cobc.vcxproj.filters +++ b/build_windows/vs2019/cobc.vcxproj.filters @@ -36,9 +36,6 @@ Source Files - - Source Files - Source Files @@ -251,9 +248,6 @@ Header Files - - Header Files - Header Files diff --git a/build_windows/vs2019/libcob.vcxproj b/build_windows/vs2019/libcob.vcxproj index b9ecc6af3..781fbf6c6 100644 --- a/build_windows/vs2019/libcob.vcxproj +++ b/build_windows/vs2019/libcob.vcxproj @@ -169,6 +169,7 @@ + @@ -191,6 +192,7 @@ + @@ -218,4 +220,4 @@ - \ No newline at end of file + diff --git a/build_windows/vs2019/libcob.vcxproj.filters b/build_windows/vs2019/libcob.vcxproj.filters index 2d558a6ed..13c4c8997 100644 --- a/build_windows/vs2019/libcob.vcxproj.filters +++ b/build_windows/vs2019/libcob.vcxproj.filters @@ -18,6 +18,9 @@ Source Files + + Source Files + Source Files @@ -119,6 +122,7 @@ Header Files + diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 9aa4a85e9..c0c76f996 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,9 @@ +2024-08-28 David Declerck + + * tree.c (char_to_precedence_idx, get_char_type_description, valid_char_order): + adjusted size of precedence table and gave proper precedence to U + 2024-08-04 David Declerck Adjustments to merge 2022-12-21: @@ -8,6 +13,10 @@ Adjustments to merge 2022-12-12: * codegen.c (emit_one_sym): output NULL as data storage and set is_internal flag to 1 for TYPEDEF + * codegen.c (output_assign, output_if, output_debug_item): extracted + from output_stmt + * typeck.c (cb_emit, cb_emit_list): changed from defines to inline + functions, now returning the tree that was emitted 2023-06-02 Simon Sobisch @@ -53,20 +62,66 @@ * codegen.c: Verify that EXTERNAL variables have 'ename' * field.c (copy_into_field): If EXTERNAL set 'ename' +2022-12-31 Simon Sobisch + + * cobc.c (short_options): removed -R which was only dropped from evaluation + in 2016-09-24; fixing bug #758 + +2022-12-30 Simon Sobisch + + * cobc.c, cobc.h, pplex.l (ppopen), help.c: restored -MT and -MF options + as they were available in GnuCOBOL 1.1 (adjusted to current code) + * cobc.c (process_command_line): handle multiple -MT options like GCC + * ChangeLog: integrated cobpp ChangeLog entries and added some + historic changes from VCS log/diff + +2022-12-29 Simon Sobisch + + * codegen.c (output_standard_includes): don't include stdio.h in + generated programs + 2022-12-21 Samuel Belondrade * codegen.c (output_base): fix undeclared variable with REDEFINE GLOBAL [bugs:#777] +2022-12-18 Simon Sobisch + + * typeck.c (cb_validate_labels): don't warn on GO TO own SECTION + +2022-12-17 Simon Sobisch + + * tree.c: initial support for PIC U, for now handled as alphanumeric with + size * 4 + * scanner.l: minimal parsing for utf-8 literals + * reserved.c, cobc.h (CB_CS_USAGE), parser.y: parsing for USAGE UTF-8 + and the related BYTE-LENGTH clause + * field.c, tree.c, typeck.c: minimal adjustments for PIC U + 2022-12-15 Simon Sobisch * codegen.c (output_initialize_to_value): fix bad generation for VALUE size greater than field size, see bug #777 + * codegen.c (output_label, output_label_c): extracted from output_stmt + * codegen.c (output_label_c): added output of C labels for paragraphs + using prefix PARAGRAPH and, to make them distinct, its label id as suffix + * codegen.c (output_search_all, output_search_whens): if no AT END position + token is available, use the start token instead + * typeck.c (cb_emit_search, cb_emit_search_all), tree.h: return created + search tree + * parser.y (_end_search): if search has no AT END create an implicit one + at END-SEARCH for better trace and debugging 2022-12-14 Simon Sobisch * typeck.c (validate_move): fix bug #643 add check for SET literal TO val +2022-12-13 David Declerck + + * conv.c, conv.h: files moved from cobc to libcob + * codegen.c: use the new libcob API for collating sequences + * flag.def: change "ebcdic-table" to a flag with associated variable + 2022-12-13 Simon Sobisch * cobc.c (cb_warn_opt_val, get_warn_opt_value, set_warn_opt_value), cobc.h: @@ -7340,6 +7395,10 @@ * error.c: remove special warnings for lvl-78 * pplex.l [_WIN32]: check for UTF-8 BOM in source files and skip it +201?-??-?? Roger While + + * cobc.c, cobc.h, pplex.l (ppopen): removed -MT and -MF options + 2009-??-?? Roger While * parser.y, reserved.c, tree.c, tree.h, codegen.c: full support of ANSI 85 @@ -9310,6 +9369,22 @@ * cobc.c: Use _WIN32 instead of __CYGWIN__ or __MINGW32__. +2004-02-16 Keisuke Nishida + + * pplex.l, ppparse.y: improved text manipulation + +2004-02-13 Keisuke Nishida + + * pplex.l: literal concatenation fix + +2004-02-06 Keisuke Nishida + + * pplex.l, ppparse.y: parse (and ignore) COPY SUPPRESS PRINTING + +2003-05-26 Keisuke Nishida + + * pplex.l (ppcopy), pparse.y, cobc.c, cobc.h: split ppcopy from ppopen + 2003-05-21 Keisuke Nishida * tree.h (cb_class, cb_category): New enums. @@ -9346,19 +9421,52 @@ * flag.def: New file. +2003-04-18 Keisuke Nishida + + integrate cobcpp into cobc + * pplex.l: renamed and adjusted from cobpp/scanner.l + * pparse.y: renamed and adjusted from cobpp/parser.y + * cobc.h: definitions from scanner.h + * Makefile.am, cobc.c: adjusted + +2003-04-02 Keisuke Nishida + + * pparse.y <- cobpp/parser.y, pplex.l <- cobpp/scanner.l: support for + SOURCE FORMAT compiler directive + +2003-03-26 Keisuke Nishida + + * cobpp.h (COBPP_DEFAULT_TAB_WIDTH): New macro. + (COBPP_DEFAULT_TEXT_COLUMN): New macro. + (COBPP_FORMAT_UNKNOWN): Removed. + (COBPP_FORMAT_SEMI_FIXED): Removed. + + * cobpp.c (short_options): New option `C'. Remove `D'. + (long_options): "debug" is replaced by "-fdebugging-line". + "-Wtrailing-line" is replaced by "-Wcolumn-overflow". + + * cobpp.h, cobpp.c (cobpp_text_column): New variable. + * pplex.l <- cobpp/scanner.l (read_line): Use it to cater for first 6 chars + + * cobpp.c (main): Do not infer the source format. + +2003-01-24 Keisuke Nishida + + * pplex.l <- cobpp/scanner.l (open_buffer): open copy file in "rb" mode + to avoid seek error on MinGW. (Thanks to peg@coboler.com) + 2002-11-01 Keisuke Nishida - * parser.y (resolve_predefined_names): Call recursively. + * parser.y (resolve_predefined_names): call recursively + * tree.h (YYLTYPE): moved from parser.y + * pplex.l <- cobpp/scanner.l (read_line): check newline at the end of file; + check column 7 before post-column 72 - * tree.h (YYLTYPE): Moved from parser.y. 2002-10-30 Keisuke Nishida * inline.c (output_search): Move index to variable. * inline.c (output_search_all): Unified 'cmp' variable. - -2002-10-30 Keisuke Nishida - * codegen.c (output_perform_until): Merge 'output_perform_before' and 'output_perform_after'. (output_perform): Call 'output_perform_until'. @@ -9373,6 +9481,11 @@ (output_perform_call): Don't use global_label. (codegen): Merge codegen_1. Traverse the tree only once. +2002-10-07 Keisuke Nishida + + * pplex.l <- cobpp/scanner.l (read_line): Inhibit column 72 warnings after + 4 times + 2002-10-06 Keisuke Nishida * Integrate numeric expressions and conditional expressions. @@ -9381,9 +9494,6 @@ * tree.c (make_expr): Build conditional as well. (make_cond, make_negative): Removed. * codegen.c, inline.c, parser.y: Updated. - -2002-10-06 Keisuke Nishida - * tree.h (cobc_evaluate): Removed. * tree.c (make_evaluate): Removed. * codegen.c (output_tree): Do not handle cobc_evaluate. @@ -9409,7 +9519,7 @@ 2002-09-30 Keisuke Nishida - * cobc.h (COBC_PACKAGE): Use PACKAGE_NAME. + * cobc.h (COBC_PACKAGE), cobpp.h (COBPP_PACKAGE): Use PACKAGE_NAME 2002-09-29 Keisuke Nishida @@ -9423,20 +9533,20 @@ 2002-09-24 Keisuke Nishida * scanner.l: Do not support single-quoted strings. - -2002-09-24 Keisuke Nishida - + * pplex.l <- cobpp/scanner.l: Do not support single-quoted strings. * codegen.c (codegen_1): Do not support non-computed-goto jump. + * pplex.l <- cobpp/scanner.l (display_line): Removed. + (yyinput): Append multiple LF's during concatenating lines. 2002-09-24 Keisuke Nishida * tree.h (cobc_parameter): Renamed from cobc_generic. - All files updated. + All files updated. 2002-09-24 Keisuke Nishida * inline.c (output_call_statement): Output the pointer to the - content length for COBC_CALL_BY_LENGTH. + content length for COBC_CALL_BY_LENGTH. 2002-09-23 Keisuke Nishida @@ -9445,15 +9555,20 @@ 2002-09-17 Keisuke Nishida * cobc.c (probe_source_format): Removed. - (preprocess): Don't set source format. - (process_command_line): Set cobpp flags here. - -2002-09-17 Keisuke Nishida - + (preprocess): Don't set source format. + (process_command_line): Set cobpp flags here. + * pparse.y <- cobpp/parser.y (yywarn): New function. + * cobpp.h (COBPP_FORMAT_UNKNOWN): New macro. + * cobpp.h, cobpp.c (cobpp_source_format_inferred): New variable. + * cobpp.c (cobpp_source_format): Default to COBPP_FORMAT_UNKNOWN. + (main): Infer source format here + * cobpp.h, cobpp.c (cobpp_warn_trailing_line): New variables. + * pplex.l <- cobpp/scanner.l (read_line): Show warnings for over column 72. * tree.h (COBC_CALL_BY_LENGTH): New macro. * reserved.c (reserved_words): Add LENGTH. * parser.y (call_mode): Add CONTENT LENGTH. * inline.c (output_call_statement): Handle COBC_CALL_BY_LENGTH. + * cobpp: Rename all `cob_*' to `cobpp_*'. 2002-09-13 Keisuke Nishida @@ -9464,17 +9579,15 @@ 2002-09-12 Keisuke Nishida * cobc.c (temp_name): Call GetTempFileName with 3rd argument 0. - Call DeleteFile to remove the temporary file. - -2002-09-12 Keisuke Nishida - + Call DeleteFile to remove the temporary file. * parser.y (validate_field_tree): Validate groups not having PICTURE. - (validate_field_tree): Create PICTURE of INDEX here, not in USAGE. + (validate_field_tree): Create PICTURE of INDEX here, not in USAGE. 2002-09-09 Keisuke Nishida * parser.y (ambiguous_error): display all fields with the same name. - (occurs_index): Use undefined_word. Set cobc_location. + (occurs_index): Use undefined_word. Set cobc_location. + * pplex.l <- cobpp/scanner.l (read_line): Don't use fgets. 2002-08-29 Keisuke Nishida @@ -9483,7 +9596,7 @@ 2002-08-28 Keisuke Nishida * cobc.c (terminate): Renamed from 'error'. - (temp_name): Use GetTempPath on MinGW environment. + (temp_name): Use GetTempPath on MinGW environment. 2002-08-20 Keisuke Nishida @@ -9494,10 +9607,16 @@ * reserved.c (reserved_words): Removed the tokens above. * scanner.h, scanner.l (cobc_skip_comment): Removed. * scanner.l: Don't handle the case of cobc_skip_comment. + * pplex.l <- cobpp/scanner.l: Better implementation of line connection. + Comments in IDENTIFICATION DIVISION are skipped here. + * cobc.c: New option -semi-fixed. -2002-08-20 Keisuke Nishida +2002-08-12 Keisuke Nishida - * cobc.c: New option -semi-fixed. + * cobpp.h (COB_FORMAT_SEMI_FIXED): New macro. + * cobpp.c (long_options): New option `semi-fixed'. + * pplex.l <- cobpp/scanner.l (yyinput): Support semi-fixed. + Skip comments and debugging lines here. 2002-08-02 Keisuke Nishida @@ -9506,29 +9625,23 @@ 2002-08-01 Keisuke Nishida * parser.y, reserved.c: SORT and MERGE support. - -2002-08-01 Keisuke Nishida - * tree.h (cobc_key): Define 'dir' as int. - Use COB_ASCENDING or COB_DESCENDING for this. + Use COB_ASCENDING or COB_DESCENDING for this. * inline.c (output_search_all): Updated. * parser.y (ascending_or_descending): Updated. - -2002-08-01 Keisuke Nishida - * parser.y (occurs_clause): Use predefined_name for DEPENDING ON. - (record_depending): Set 'record_depending' directly. + (record_depending): Set 'record_depending' directly. 2002-07-31 Keisuke Nishida * codegen.h (cobc_program_spec): Renamed from 'program_spec'. * parser.y (program_spec): Updated. * codegen.c: (output_switch): New variable. - (output, output_newline, output_prefix, output_line): Updated. - (loop_counter, loop_counter_max): New variables. - (codegen_1): Renamed from codegen. Set counter variables. - (codegen): New function. - (output_perform): Use loop_counter. + (output, output_newline, output_prefix, output_line): Updated. + (loop_counter, loop_counter_max): New variables. + (codegen_1): Renamed from codegen. Set counter variables. + (codegen): New function. + (output_perform): Use loop_counter. 2002-07-31 Keisuke Nishida @@ -9541,48 +9654,36 @@ 2002-07-26 Keisuke Nishida * parser.y: Accept SD clause. - -2002-07-26 Keisuke Nishida - * tree.c (make_word): Take constant and duplicate the name. 2002-07-22 Keisuke Nishida * parser.y (FUNCTION_NAME): Defined as the string type. * scanner.l (FUNCTION_STATE): Set value for FUNCTION_NAME. - -2002-07-22 Keisuke Nishida - * parser.y (display_with_no_advancing): Fixed port number. 2002-07-08 Keisuke Nishida * codegen.c (output_field): Support literals. - (output_file_name): Output ASSIGN clause. + (output_file_name): Output ASSIGN clause. * parser.y (open_list): Call "cob_open" without file name. - -2002-07-08 Keisuke Nishida - * codegen.c (output_field): New function. - (output_file_name): Use it. + (output_file_name): Use it. 2002-07-05 Keisuke Nishida * parser.y (screen_description): Set default line/column. * codegen.c (output_screen_definition): Updated. - Handle COB_SCREEN_TYPE_ATTRIBUTE. + Handle COB_SCREEN_TYPE_ATTRIBUTE. 2002-07-04 Keisuke Nishida * codegen.c (output_file_name): Rename 'cob_file_desc' to 'cob_file'. - -2002-07-04 Keisuke Nishida - * codegen.c (output_field_definition): New arguments 'gen_data' - and 'gen_filler'. - (output_file_name, codegen): Updated. + and 'gen_filler'. + (output_file_name, codegen): Updated. * parser.y (screen_option): Set LINE/COLUMN flags appropriately. - (screen_plus_minus): PLUS/MINUS flags. + (screen_plus_minus): PLUS/MINUS flags. 2002-07-03 Keisuke Nishida @@ -9591,36 +9692,33 @@ 2002-07-01 Keisuke Nishida * tree.h (cobc_field): New members: f.screen, screen_line, - screen_column, screen_from, screen_to, and screen_flag. + screen_column, screen_from, screen_to, and screen_flag. * codegen.h (screen_storage): New members: enable_screen and - screen_storage. + screen_storage. * codegen.c (output_screen_definition): New function. - (output_tree): Output screen data. - (codegen): Output screen definition. + (output_tree): Output screen data. + (codegen): Output screen definition. * parser.y (special_name): Add CURSOR and CRT STATUS. - (screen_section): New rules. - (accept_statement, display_statement): Support screen data. + (screen_section): New rules. + (accept_statement, display_statement): Support screen data. * reserved.c (reserved_words): Add related tokens. 2002-06-26 Keisuke Nishida * tree.c (compute_size): Handle SIGN SEPARATE only for numeric fields. * parser.y (validate_field): Don't throw error for multiple redefines. - -2002-06-26 Keisuke Nishida - * cobc.c, cobc.h (cobc_flags): New variable. - (LINK_STATIC, LINK_DYNAMIC): Removed. - (cobc_main_flag, cobc_debug_flag, cobc_verbose_flag) - (cobc_optimize_flag, cobc_failsafe_flag, cobc_link_style): Removed. + (LINK_STATIC, LINK_DYNAMIC): Removed. + (cobc_main_flag, cobc_debug_flag, cobc_verbose_flag) + (cobc_optimize_flag, cobc_failsafe_flag, cobc_link_style): Removed. * codegen.c (codegen, output_expr, output_line_directive): Updated. * inline.c (output_call_statement): Updated. 2002-06-24 Keisuke Nishida * parser.y (delete_statement, read_statement, start_statement) - (write_statement): set $$ instead of current_file_name. - (at_end, opt_invalid_key): Updated. + (write_statement): set $$ instead of current_file_name. + (at_end, opt_invalid_key): Updated. 2002-06-18 Keisuke Nishida @@ -9630,40 +9728,28 @@ * inline.c, inline.h (output_call_statement): Take st1 and st2. * parser.y (call_mode): Renamed from 'current_call_mode'. - (call_statement): Updated and clean up. + (call_statement): Updated and clean up. 2002-06-11 Keisuke Nishida * cobc.c (process_module): Use COB_MODULE_EXT. - Don't use -soname. - -2002-06-11 Keisuke Nishida - + Don't use -soname. * codegen.c: Use 'cob_alnum_desc' where appropriate. - -2002-06-11 Keisuke Nishida - * codegen.c (output_field_definition): Output NULL for - cob_field.desc when it is a group. - -2002-06-11 Keisuke Nishida - + cob_field.desc when it is a group. * codegen.c, inline.c: Updated for the change in libcob that - moved the 'size' field from cob_field_desc to cob_field. + moved the 'size' field from cob_field_desc to cob_field. 2002-06-09 Keisuke Nishida * tree.h (cobc_field): New member 'in_redefines'. * parser.y (validate_field): Set 'in_redefines' and validate REDEFINES. - Display error if a field under REDEFINES has VALUE clause. - (init_field): Inherit the 'in_redefines' flag. - -2002-06-09 Keisuke Nishida - + Display error if a field under REDEFINES has VALUE clause. + (init_field): Inherit the 'in_redefines' flag. * tree.c (make_tree, make_picture, make_word): Use memset to - initialize the memory allocated. - (make_literal, make_field, make_file_name, make_label_name_nodef) - (make_perform): Let make_tree initialize the memory by zero. + initialize the memory allocated. + (make_literal, make_field, make_file_name, make_label_name_nodef) + (make_perform): Let make_tree initialize the memory by zero. 2002-06-08 Keisuke Nishida @@ -9673,19 +9759,19 @@ * codegen.c (codegen): Updated. * parser.y (procedure_using): Don't show -m warning. +2002-06-07 Keisuke Nishida + + * pparse.y <- cobpp/parser.y (copy_statement, copy_in, copy_replacing): + Support "COPY ... IN/OF ..." syntax. + * pplex.l <- cobpp/scanner.l, scanner.h (include_copybook): Take a library name. + 2002-06-06 Keisuke Nishida * inline.c (search_set_keys): Dont check syntax error. * parser.y (search_statement): Check syntax error here. * parser.y (resolve_predefined_name): Return filler on error. - -2002-06-06 Keisuke Nishida - * codegen.c (codegen): Always generate program function, - putting main() at the end. - -2002-06-06 Keisuke Nishida - + putting main() at the end. * cobc.c (process_command_line, print_usage): Activate -g. 2002-06-05 Keisuke Nishida @@ -9697,40 +9783,38 @@ * codegen.c (output_perform_call): New function. * codegen.c (output_perform_once): Use 'output_perform_call'. * inline.c (output_file_handler): Use 'output_perform_call'. Cleanup. - -2002-06-04 Keisuke Nishida - + * cobpp/Makefile.am (cobpp_CFLAGS): -I$(top_srcdir), not -I$(top_srcdir)/lib. + * cobpp.c, pplex.l <- cobpp/scanner.l: Updated. * Makefile.am (cobc_CFLAGS): -I$(top_srcdir), not -I$(top_srcdir)/lib. * cobc.c, parser.y, scanner.l: Updated. 2002-06-03 Keisuke Nishida * cobc.c (init_environment): Recognize COB_LDADD. - -2002-06-03 Keisuke Nishida - + * cobpp/Makefile.am (cobpp_LDADD): Add libsupport.a here. + (cobpp_LIBS): Removed. * Makefile.am: Add libsupport.a to cobc_LDADD, removed cobc_LIBS 2002-05-31 Keisuke Nishida * functions.h: Removed. * tree.h (cobc_call): New field 'name' and 'func'. Remove 'tag'. - (make_call): Exported - (make_call_0, make_call_1, make_call_2, make_call_3, make_call_4): - Defined as macros. - (make_inline_0, make_inline_1, make_inline_2, make_inline_3, - make_inline_4, make_call_1_list): New macros. + (make_call): Exported + (make_call_0, make_call_1, make_call_2, make_call_3, make_call_4): + Defined as macros. + (make_inline_0, make_inline_1, make_inline_2, make_inline_3, + make_inline_4, make_call_1_list): New macros. * tree.c (make_call): Updated and Exported. - (make_call_0,make_call_1,make_call_2,make_call_3,make_call_4): Removed. + (make_call_0,make_call_1,make_call_2,make_call_3,make_call_4): Removed. * inline.c, codegen.h: (output_goto, output_goto_depending, - output_move, output_initialize, output_initialize_replacing, - output_display, output_search, output_search_all, - output_call_statement): Exported. + output_move, output_initialize, output_initialize_replacing, + output_display, output_search, output_search_all, + output_call_statement): Exported. * codegen.c, codegen.h: Don't include functions.h. * codegen.c (output_call): Updated. * parser.y: Updated. - (push_call_1_list, push_inline_0, push_inline_1, push_inline_2, - push_inline_3, push_inline_4): New macros. + (push_call_1_list, push_inline_0, push_inline_1, push_inline_2, + push_inline_3, push_inline_4): New macros. * Makefile.am (cobc_SOURCES): Updated. 2002-05-31 Keisuke Nishida @@ -9738,16 +9822,10 @@ * Display index name with the error message. * codegen.c (output_refmod_offset, output_length) * codegen.c (output_field_definition): Updated. - -2002-05-31 Keisuke Nishida - * tree.c, tree.h (cobc_return_code): New variable. * parser.y (call_returning): Move RETURN-CODE to RETURNING field. * inline.c (output_move_index): New function. * inline.c (output_call_statement): Don't take ret. - -2002-05-31 Keisuke Nishida - * codegen.c (output_expr): Give field name to cob_check_numeric. * codegen.c (output_field_definition): No longer output field name. @@ -9756,29 +9834,43 @@ * parser.y (expr_item_list): Better source location. * codegen.c (output_compare): Take additional argument for better source location. - * codegen.c (output_condition): Updated. - * inline.c (output_search_all): Updated. - -2002-05-29 Keisuke Nishida - + * codegen.c (output_condition), inline.c (output_search_all): Updated. * codegen.c (output_recursive): Process top-level redefinition. - -2002-05-29 Keisuke Nishida - * Keep field names at run-time. * codegen.c (output_field_definition): Output field name. 2002-05-29 Keisuke Nishida * cobc.c: Rename 'COB_LDADD' to 'COB_LIBS' - -2002-05-29 Keisuke Nishida - * cobc.c (cobc_verbose_flag): New variable. * cobc.c (short_options, long_options): New option -v and --verbose. * cobc.c (process_command_line): Handle -v option. * cobc.h (cobc_verbose_flag): Declared. +2002-05-23 Keisuke Nishida + + * cobc.c, parser.y, scanner.l, Makefile.am, cobpp/Makefile.am, + cobpp/cobpp.c, cobpp/cobpp.h, ppparse.y <- cobpp/parser.y, + pplex.l <- cobpp/scanner.l, cobpp/scanner.h: gettextized, + improved message handling + * cobc.c, cobpp/cobpp.c: call of bindtextdomain and other NLS calls + +2002-05-02 Keisuke Nishida + + * cobc.c, cobpp/cobpp.c, cobpp/cobpp.h: changed source format options + -X to --fixed and -F (X/Open free format) to --free + * cobpp/cobpp.h (print_usage): fixed help output for -MF and -MT + +2002-02-12 Keisuke Nishida + + * cobc.c, cobpp/cobpp.c: renamed -M to -MF, added -MT to adjust target name + +2002-01-29 Keisuke Nishida + + * cobpp.c, cobpp.h, pplex.l <- cobpp/scanner.l, cobc.c: add -M option to + place dependency list (copybooks) into dependency file for make + * cobc.c: cleanup for passing arguments to cobpp + Copyright 2002-2022 Free Software Foundation, Inc. diff --git a/cobc/Makefile.am b/cobc/Makefile.am index 84df8504f..1646fefeb 100644 --- a/cobc/Makefile.am +++ b/cobc/Makefile.am @@ -21,9 +21,9 @@ bin_PROGRAMS = cobc cobc_SOURCES = cobc.c cobc.h ppparse.y pplex.c parser.y scanner.c \ - config.c reserved.c error.c tree.c tree.h cconv.c cconv.h \ - field.c typeck.c codegen.c help.c sqlxfdgen.c config.def \ - flag.def warning.def codeoptim.def ppparse.def codeoptim.c + config.c reserved.c error.c tree.c tree.h field.c typeck.c \ + codegen.c help.c sqlxfdgen.c config.def flag.def warning.def \ + codeoptim.def ppparse.def codeoptim.c #cobc_SOURCES = cobc.c cobc.h ppparse.y pplex.l parser.y scanner.l config.c diff --git a/cobc/cconv.h b/cobc/cconv.h deleted file mode 100644 index 3bee1739f..000000000 --- a/cobc/cconv.h +++ /dev/null @@ -1,77 +0,0 @@ -/* - Copyright (C) 2005,2006,2022 Free Software Foundation, Inc. - Written by Roger While, Nicolas Berthier, Simon Sobisch - - This file is part of GnuCOBOL. - - The GnuCOBOL compiler is free software: you can redistribute it - and/or modify it under the terms of the GNU General Public License - as published by the Free Software Foundation, either version 3 of the - License, or (at your option) any later version. - - GnuCOBOL is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with GnuCOBOL. If not, see . -*/ -#ifndef CB_CCONV_H -#define CB_CCONV_H - -/* FIXME: inclusion of unistd.h is required for size_t. As in cobc.h, this may - require an additional installed header. */ -#include "config.h" -#ifdef HAVE_UNISTD_H -#include -#endif -#include "../libcob/common.h" - -/* "default" (likely MF) EBCDIC to ASCII conversion table */ -extern const cob_u8_t cob_ebcdic_ascii[256]; - -/* ASCII to "default" (likely MF) EBCDIC conversion table */ -extern const cob_u8_t cob_ascii_ebcdic[256]; - -/* EBCDIC GCOS7 8-bit to ASCII conversion table: - - https://support.bull.com/ols/product/system/gcos7/gcos7-com/g7-dps7000/doc-com/docf/g/47X257TN27-oct2009/47A205UL04.pdf, - p627. Note one page is missing from this documentation, but the full table - can be found in the French version. */ -extern const cob_u8_t cob_gcos7ebcdic_ascii[256]; - -/* EBCDIC GCOS7 8-bit to "default" EBCDIC conversion table */ -extern const cob_u8_t cob_gcos7ebcdic_ebcdic[256]; - -/* ASCII (8-bit) to EBCDIC GCOS7 conversion table */ -extern const cob_u8_t cob_ascii_gcos7ebcdic[256]; - -/* Restricted conversions: */ - -/* ASCII to EBCDIC conversion table (restricted) */ -extern const cob_u8_t cob_ascii_alt_ebcdic[256]; - -/* IBM EBCDIC to ASCII conversion table (restricted) - - cf https://www.ibm.com/docs/en/iis/11.3?topic=tables-ebcdic-ascii */ -extern const cob_u8_t cob_ibmebcdic_ascii[256]; - -/* ASCII to IBM EBCDIC conversion table (restricted) - - cf https://www.ibm.com/docs/en/iis/11.3?topic=tables-ascii-ebcdic */ -extern const cob_u8_t cob_ascii_ibmebcdic[256]; - -/* All supported conversions */ -enum ebcdic_table { - CB_EBCDIC_DEFAULT, - CB_EBCDIC_RESTRICTED_GC, - CB_EBCDIC_IBM, - CB_EBCDIC_GCOS, -}; - -extern enum ebcdic_table cb_ebcdic_table; - -int cobc_deciph_ebcdic_table_name (const char *const); - -#endif /* CB_CCONV_H */ diff --git a/cobc/cobc.c b/cobc/cobc.c index 88d357929..80086da55 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -61,7 +61,7 @@ #include "cobc.h" #include "tree.h" -#include "cconv.h" +#include "../libcob/coblocal.h" #include "../libcob/cobgetopt.h" @@ -112,6 +112,7 @@ const char *cb_storage_file_name = NULL; const char *cb_call_extfh = NULL; const char *cb_sqldb_schema = NULL; struct cb_text_list *cb_include_list = NULL; +struct cb_text_list *cb_depend_list = NULL; struct cb_text_list *cb_intrinsic_list = NULL; struct cb_text_list *cb_extension_list = NULL; struct cb_text_list *cb_static_call_list = NULL; @@ -121,6 +122,7 @@ const char *cob_config_dir = NULL; const char *cob_schema_dir = NULL; FILE *cb_storage_file = NULL; FILE *cb_listing_file = NULL; +FILE *cb_depend_file = NULL; /* Listing structures and externals */ @@ -258,6 +260,7 @@ static char *cobc_libs; /* -l... */ static char *cobc_lib_paths; /* -L... */ static char *cobc_include; /* -I... */ static char *cobc_ldflags; /* -Q / COB_LDFLAGS */ +static char *cb_depend_target; /* -MT ... */ static size_t cobc_cflags_size; static size_t cobc_libs_size; @@ -440,7 +443,7 @@ static const char *const cob_csyns[] = { #define COB_NUM_CSYNS sizeof(cob_csyns) / sizeof(cob_csyns[0]) -static const char short_options[] = "hVivqECScbmxjdFROPgGwo:t:T:I:L:l:D:K:k:"; +static const char short_options[] = "hVivqECScbmxjdFOPgGwo:t:T:I:L:l:D:K:k:"; #define CB_NO_ARG no_argument #define CB_RQ_ARG required_argument @@ -477,6 +480,8 @@ static const struct option long_options[] = { {"j", CB_OP_ARG, NULL, 'j'}, {"Q", CB_RQ_ARG, NULL, 'Q'}, {"A", CB_RQ_ARG, NULL, 'A'}, + {"MT", CB_RQ_ARG, NULL, '!'}, + {"MF", CB_RQ_ARG, NULL, '@'}, {"P", CB_OP_ARG, NULL, 'P'}, {"Xref", CB_NO_ARG, NULL, 'X'}, {"use-extfh", CB_RQ_ARG, NULL, 9}, /* this is used by COBOL-IT; Same is -fcallfh= */ @@ -3548,6 +3553,30 @@ process_command_line (const int argc, char **argv) cb_define_list = p; break; + case '!': + /* -MT */ + if (!cb_depend_target) { + cb_depend_target = cobc_strdup (cob_optarg); + } else { + /* multiple invocations add to the list */ + const size_t orig_len = strlen (cb_depend_target); + const size_t new_len = strlen (cob_optarg); + const size_t buff_len = orig_len + 1 + new_len + 1; + cb_depend_target = cobc_realloc (cb_depend_target, buff_len); + memset (cb_depend_target + orig_len, ' ', 1); + memcpy (cb_depend_target + orig_len + 1, cob_optarg, new_len); + memset (cb_depend_target + orig_len + 1 + new_len, 0, 1); + } + break; + + case '@': + /* -MF */ + cb_depend_file = fopen (cob_optarg, "w"); + if (!cb_depend_file) { + cb_perror (0, "cobc: %s: %s", cob_optarg, cb_get_strerror ()); + } + break; + case 'I': /* -I : Include/copy directory */ if (strlen (cob_optarg) > COB_SMALL_MAX) { @@ -3658,7 +3687,8 @@ process_command_line (const int argc, char **argv) case 16: /* -febcdic-table= */ - if (cobc_deciph_ebcdic_table_name (cob_optarg)) { + cb_ebcdic_table = cob_get_collation_by_name (cob_optarg, NULL, NULL); + if (cb_ebcdic_table < 0) { cobc_err_exit (COBC_INV_PAR, "-febcdic-table"); } break; @@ -3952,6 +3982,18 @@ process_command_line (const int argc, char **argv) cobc_main_free (output_name); cobc_main_free (output_name_buff); } + +#if 0 /* TODO: */ + if (cb_compile_level == CB_LEVEL_PREPROCESS && output_name && strcmp (output_name, COB_DASH) != 0)) { + cb_depend_file = output_file; + } +#endif + /* TODO: add -M and -MD (breaking change "per GCC" already announced) */ + if (cb_depend_file && !cb_depend_target) { + cobc_err_exit (_("-MT must be given to specify target file")); + fclose (cb_depend_file); + cb_depend_file = NULL; + } /* debug: Turn on all exception conditions -> drop note about this after hanling exit_option and general problems */ @@ -9103,6 +9145,19 @@ main (int argc, char **argv) cb_listing_file = NULL; } + /* Output dependency list */ + if (cb_depend_file) { + struct cb_text_list *l; + fprintf (cb_depend_file, "%s: \\\n", cb_depend_target); + for (l = cb_depend_list; l; l = l->next) { + fprintf (cb_depend_file, " %s%s\n", l->text, l->next ? " \\" : "\n"); + } + for (l = cb_depend_list; l; l = l->next) { + fprintf (cb_depend_file, "%s:\n", l->text); + } + fclose (cb_depend_file); + } + /* Clear rest of preprocess stuff */ plex_clear_all (); diff --git a/cobc/cobc.h b/cobc/cobc.h index 802ce7a7f..e9ce15f41 100644 --- a/cobc/cobc.h +++ b/cobc/cobc.h @@ -146,6 +146,7 @@ enum cb_current_date { #define CB_CS_DEFAULT CB_CS_DAY #define CB_CS_VALIDATE_STATUS CB_CS_DAY #define CB_CS_SPECIAL_NAMES CB_CS_DAY +#define CB_CS_USAGE CB_CS_DAY /* Support for cobc from stdin */ #define COB_DASH "-" @@ -433,6 +434,8 @@ extern int cb_saveargc; extern FILE *cb_listing_file; extern FILE *cb_src_list_file; +extern FILE *cb_depend_file; +extern struct cb_text_list *cb_depend_list; extern struct cb_text_list *cb_include_list; extern struct cb_text_list *cb_intrinsic_list; extern struct cb_text_list *cb_extension_list; diff --git a/cobc/codegen.c b/cobc/codegen.c index 61bbe9300..cf2162fea 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -37,7 +37,6 @@ #include "cobc.h" #include "tree.h" -#include "cconv.h" #if !defined(COB_ALIGN_KNOWN) && !defined(COB_ALLOW_UNALIGNED) #error System requires data alignment which is unknown @@ -178,11 +177,8 @@ static unsigned int needs_exit_prog = 0; static unsigned int needs_unifunc = 0; static unsigned int need_save_exception = 0; static unsigned int gen_nested_tab = 0; -static unsigned int gen_default_ebcdic = 0; -static unsigned int gen_alt_ebcdic = 0; +static unsigned int gen_ascii_ebcdic = 0; static unsigned int gen_ebcdic_ascii = 0; -static unsigned int gen_ibm_ebcdic = 0; -static unsigned int gen_gcos7_ebcdic = 0; static unsigned int gen_native = 0; static unsigned int gen_custom = 0; static unsigned int gen_figurative = 0; @@ -288,6 +284,7 @@ static int any_source_moves (struct cb_report *r, struct cb_field *f, int first) static struct cb_field * real_field_founder (const struct cb_field *f); static void add_field_cache (struct cb_field *f01, struct cb_field *f); +static void output_line_and_trace_info (cb_tree x, const enum cob_statement stmnt); static void output_source_reference (cb_tree, const enum cob_statement); static void codegen_init (struct cb_program *, const char *); @@ -1896,8 +1893,10 @@ output_standard_includes (struct cb_program *prog) output_line ("#define\t_XOPEN_SOURCE_EXTENDED 1"); output_line ("#endif"); #endif +#if 0 /* Simon: why should we include that? */ output_line ("#include "); - output_line ("#include "); +#endif + output_line ("#include /* for memcpy, memcmp and friends */"); #ifdef WORDS_BIGENDIAN output_line ("#define WORDS_BIGENDIAN 1"); #endif @@ -3121,44 +3120,6 @@ output_literals_figuratives_and_constants (void) /* Collating tables */ -enum cb_cconv_dir { OF_ASCII, TO_ASCII }; -static const char * -colseq_table_name (const enum ebcdic_table table_name, - const enum cb_cconv_dir direction, - const unsigned int field) -{ - /* FIXME: assumes !COB_EBCDIC_MACHINE */ - /* FIXME: record direction as well, so we know better what tables and - fields to output later on; for now only OF_ASCII is recorded. */ - switch (table_name) { - case CB_EBCDIC_DEFAULT: - default: - gen_default_ebcdic |= field ? 2 : 1; - return direction == OF_ASCII - ? "cob_ascii_ebcdic" - : "cob_ebcdic_ascii"; - case CB_EBCDIC_RESTRICTED_GC: - gen_alt_ebcdic |= field ? 2 : 1; - if (direction == TO_ASCII) { - /* TODO: define inverse conversion */ - cobc_err_msg ("Unexpected conversion from " - "restricted EBCDIC to ASCII!"); - COBC_ABORT (); - } - return "cob_a2e"; - case CB_EBCDIC_IBM: - gen_ibm_ebcdic |= field ? 2 : 1; - return direction == OF_ASCII - ? "cob_ascii_ibmebcdic" - : "cob_ibmebcdic_ascii"; - case CB_EBCDIC_GCOS: - gen_gcos7_ebcdic |= field ? 2 : 1; - return direction == OF_ASCII - ? "cob_ascii_gcos7ebcdic" - : "cob_gcos7ebcdic_ascii"; - } -} - /* Outputs conversion from given table, or a native conversion (identity) when omitted (if table == NULL). */ static void @@ -3176,138 +3137,59 @@ output_colseq_table (const char * const table_name, } static void -output_colseq_table_field (const char * table_name) +output_colseq_table_field (const char * field_name, const char * table_name) { const int i = lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0); - output_storage ("static cob_field f_%s = { 256, (cob_u8_ptr)%s, &%s%d };\n", - table_name, table_name, CB_PREFIX_ATTR, i); -} - -static void -output_default_ebcdic_table (void) -{ - const char * table_name; - - if (!gen_default_ebcdic) { - return; - } - - table_name = colseq_table_name (CB_EBCDIC_DEFAULT, OF_ASCII, 0); - output_storage ("\n/* ASCII to EBCDIC table */\n"); - output_colseq_table (table_name, cob_ascii_ebcdic); - if (gen_default_ebcdic > 1) { - output_colseq_table_field (table_name); - } - output_storage ("\n"); - -} - -static void -output_alt_ebcdic_table (void) -{ - const char * table_name; - - if (!gen_alt_ebcdic) { - return; - } - - table_name = colseq_table_name (CB_EBCDIC_RESTRICTED_GC, OF_ASCII, 0); - output_storage ("\n/* ASCII to EBCDIC translate table (restricted) */\n"); - output_colseq_table (table_name, cob_ascii_alt_ebcdic); - if (gen_alt_ebcdic > 1) { - output_colseq_table_field (table_name); - } - output_storage ("\n"); -} - -static void -output_ibm_ebcdic_table (void) -{ - const char * table_name; - - if (!gen_ibm_ebcdic) { - return; - } - - table_name = colseq_table_name (CB_EBCDIC_IBM, OF_ASCII, 0); - output_storage ("\n/* ASCII to IBM EBCDIC translate table (restricted) */\n"); - output_colseq_table (table_name, cob_ascii_ibmebcdic); - if (gen_ibm_ebcdic > 1) { - output_colseq_table_field (table_name); - } - output_storage ("\n"); + output_storage ("static cob_field %s = { 256, (cob_u8_ptr)%s, &%s%d };\n", + field_name, table_name, CB_PREFIX_ATTR, i); } static void -output_gcos7_ebcdic_table (void) +output_collating_tables (void) { - const char * table_name; - - if (!gen_gcos7_ebcdic) { - return; - } - - table_name = colseq_table_name (CB_EBCDIC_GCOS, OF_ASCII, 0); - output_storage ("\n/* ASCII to EBCDIC GCOS7 translate table */\n"); - output_colseq_table (table_name, cob_ascii_gcos7ebcdic); - if (gen_gcos7_ebcdic > 1) { - output_colseq_table_field (table_name); + if (gen_native) { + output_storage ("\n/* NATIVE table */\n"); + output_colseq_table ("cob_native", NULL); + if (gen_native > 1) { + output_colseq_table_field("f_native", "cob_native"); + } + output_storage ("\n"); } - output_storage ("\n"); -} - -static void -output_ebcdic_to_ascii_table (void) -{ - const char * table_name; - if (!gen_ebcdic_ascii) { - return; + if (gen_ascii_ebcdic) { + output_storage ("\n/* ASCII to EBCDIC table */\n"); + output_storage ("static const cob_u8_t *\tcob_ascii_ebcdic = NULL;\n"); + if (gen_ascii_ebcdic > 1) { + output_colseq_table_field("f_ascii_ebcdic", "NULL"); + } + output_storage ("\n"); } - table_name = colseq_table_name (CB_EBCDIC_DEFAULT, TO_ASCII, 0); - output_storage ("\n/* EBCDIC to ASCII table */\n"); - output_colseq_table (table_name, cob_ebcdic_ascii); - - if (gen_ebcdic_ascii > 1) { - output_storage ("static cob_field f_ebcdic_ascii = { 256, (cob_u8_ptr)%s, &%s%d };\n", - table_name, CB_PREFIX_ATTR, - lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0)); + if (gen_ebcdic_ascii) { + output_storage ("\n/* EBCDIC to ASCII table */\n"); + output_storage ("static const cob_u8_t *\tcob_ebcdic_ascii = NULL;\n"); + if (gen_ebcdic_ascii > 1) { + output_colseq_table_field("f_ebcdic_ascii", "NULL"); + } + output_storage ("\n"); } - - output_storage ("\n"); - } static void -output_native_table (void) +output_init_collating_tables (void) { - if (!gen_native) { - return; - } - - output_storage ("\n/* NATIVE table */\n"); - output_colseq_table ("cob_native", NULL); - - if (gen_native > 1) { - output_storage ("static cob_field f_native = { 256, (cob_u8_ptr)cob_native, &%s%d };\n", - CB_PREFIX_ATTR, - lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0)); + if ((gen_ascii_ebcdic > 0) || (gen_ebcdic_ascii > 0)) { + output_line ("cob_get_collation_by_name(\"%s\", %s, %s);", + cob_get_collation_name(cb_ebcdic_table), + (gen_ebcdic_ascii > 0) ? "&cob_ebcdic_ascii" : "NULL", + (gen_ascii_ebcdic > 0) ? "&cob_ascii_ebcdic" : "NULL"); + if (gen_ascii_ebcdic > 1) { + output_line("f_ascii_ebcdic.data = (cob_u8_ptr)cob_ascii_ebcdic;"); + } + if (gen_ebcdic_ascii > 1) { + output_line("f_ebcdic_ascii.data = (cob_u8_ptr)cob_ebcdic_ascii;"); + } } - - output_storage ("\n"); - -} - -static void -output_collating_tables (void) -{ - output_default_ebcdic_table (); - output_alt_ebcdic_table (); - output_ibm_ebcdic_table (); - output_gcos7_ebcdic_table (); - output_ebcdic_to_ascii_table (); - output_native_table (); } /* Strings */ @@ -4236,7 +4118,8 @@ output_param (cb_tree x, int id) output ("NULL"); } #else - output ("%s", colseq_table_name (cb_ebcdic_table, OF_ASCII, 0)); + output ("cob_ascii_ebcdic"); + gen_ascii_ebcdic |= 1; #endif break; case CB_ALPHABET_CUSTOM: @@ -4379,7 +4262,8 @@ output_param (cb_tree x, int id) gen_native = 2; output ("&f_native"); #else - output ("&f_%s", colseq_table_name (cb_ebcdic_table, OF_ASCII, 1)); + output ("&f_ascii_ebcdic"); + gen_ascii_ebcdic |= 2; #endif break; case CB_ALPHABET_CUSTOM: @@ -6450,10 +6334,11 @@ output_search_whens (cb_tree table, struct cb_field *p, cb_tree at_end, output_source_reference (CB_PAIR_X (at_end), STMT_AT_END); output_stmt (CB_PAIR_Y (at_end)); } else { - /* position is best guess here */ - table->source_line++; + /* position to table here, otherwise we likely land in the + first WHEN + (Note: if there's an explicit END-SEARCH there's always + and implicit AT END on its position (included by parser.y) */ output_source_reference (table, STMT_AT_END); - table->source_line--; output_line ("break;"); } output_block_close (); @@ -6528,10 +6413,10 @@ output_search_all (cb_tree table, struct cb_field *p, cb_tree at_end, output_source_reference (CB_PAIR_X (at_end), STMT_AT_END); output_stmt (CB_PAIR_Y (at_end)); } else { - /* position is best guess here */ - table->source_line++; + /* position to table here, otherwise we likely land in the + WHEN (Note: if there's an explicit END-SEARCH there's always + and implicit AT END on its position (included by parser.y) */ output_source_reference (table, STMT_AT_END); - table->source_line--; output_line ("break;"); } output_block_close (); @@ -8371,6 +8256,97 @@ output_perform (struct cb_perform *p) } } +static void +output_debug_item (const struct cb_debug *dbg) +{ + const size_t size = cb_code_field (dbg->target)->size; + const size_t copy_size = dbg->size > size ? size : dbg->size; + if (!dbg->value) { + /* content of variable */ + struct cb_field *f = CB_FIELD_PTR (dbg->fld); + /* address may change so we may have NULL or invalid pointer */ + if (f->flag_item_based || f->storage == CB_STORAGE_LINKAGE) { +#if 0 /* FIXME: this should be replaced in 4.x by a call to libcob + which checks for NULL, and for invalid access via handler, + then outputs the appropriate value */ + struct cb_field * ff = real_field_founder (f); + output_prefix (); + output ("cob_set_verified_data ("); + output_data (dbg->target); + output (", "); + output_data (CB_TREE(ff)); + output (", " CB_FMT_LLU ", %u); ", f->offset, size); + output_newline (); +#else + + const char *null_rep = ""; + f = real_field_founder (f); + /* in this case - pre-fill with space, then set var / null_rep */ + output_prefix (); + output ("memset ("); + output_data (dbg->target); + output (", ' ', %u);", (unsigned int)size); + output_newline (); + output_prefix (); + output ("if ("); + output_data (CB_TREE (f)); + output (" == NULL)"); + output_newline (); + output_prefix (); + output ("\t""memcpy ("); + output_data (dbg->target); + output (", %s%d", CB_PREFIX_STRING, lookup_string (null_rep)); + output (", %u);", (unsigned int)strlen (null_rep)); + output_newline (); + output_line ("else"); + output_prefix (); + output ("\t""memcpy ("); + output_data (dbg->target); + output (", "); + output_data (dbg->fld); + output (", %u);", (unsigned int)copy_size); + output_newline (); +#endif + } else { + /* normal field without changing address, copy data up to max*/ + output ("memcpy ("); + output_data (dbg->target); + output (", "); + output_data (dbg->fld); + output (", %u);", (unsigned int)copy_size); + output_newline (); + /* ... filled up with space */ + if (copy_size != size) { + output_prefix (); + output ("memset ("); + output_data (dbg->target); + output (" + %u, ' ', %u);", + (unsigned int)dbg->size, (unsigned int)(size - dbg->size)); + output_newline (); + } + } + return; + } + + /* pre-defined string */ + output_prefix (); + output ("memcpy ("); + output_data (dbg->target); + output (", "); + output ("%s%d", CB_PREFIX_STRING, lookup_string (dbg->value)); + output (", %u);", (unsigned int)copy_size); + output_newline (); + /* ... filled up with space */ + if (copy_size != size) { + output_prefix (); + output ("memset ("); + output_data (dbg->target); + output (" + %u, ' ', %u);", + (unsigned int)dbg->size, (unsigned int)(size - dbg->size)); + output_newline (); + } +} + static void output_file_error (struct cb_file *pfile) { @@ -8559,6 +8535,146 @@ output_alter (struct cb_alter *p) } } +/* conditions IF / WHEN / PRSENT-WHEN */ + +static void +output_if (const struct cb_if *ip) +{ + int skip_else; + if (ip->stmt1 == NULL + && ip->stmt2 == NULL) { + if (ip->statement != STMT_IF) { + output_line ("/* WHEN has code omitted */"); + } else { + output_line ("/* IF has code omitted */"); + } + return; + } + + if (ip->statement != STMT_IF) { + output_newline (); + if (ip->test == cb_true + && cb_flag_remove_unreachable) { + output_line ("/* WHEN is always TRUE */"); + } else if (ip->test == cb_false + && cb_flag_remove_unreachable) { + output_line ("/* WHEN is always FALSE */"); + } else + if (CB_TREE_TAG (ip->test) == CB_TAG_BINARY_OP) { + const struct cb_binary_op *bop = CB_BINARY_OP (ip->test); + cb_tree w = NULL; + if (bop->op == '!') { + w = bop->x; + } else if (bop->y) { + w = bop->y; + } else if (bop->x) { + w = bop->x; + } + if (w == cb_true) { + output_line ("/* WHEN is always %s */", + bop->op == '!' ? "FALSE" : "TRUE"); + } else if (w == cb_false) { + output_line ("/* WHEN is always %s */", + bop->op != '!' ? "FALSE" : "TRUE"); + } else { + w = ip->test; + /* LCOV_EXCL_START */ + if (!ip->test->source_line) { + /* untranslated as unlikely internal-check-only message */ + cobc_err_msg ("Unexpected call to output_stmt -> TAG_IF (BINARY) without source reference"); + output_line ("/* WHEN */"); + /* LCOV_EXCL_STOP */ + } else { + output_source_reference (w, STMT_WHEN); + } + } + } else if (ip->test->source_line) { + output_line ("/* Line: %-10d: WHEN */", ip->test->source_line); + if (last_line != ip->test->source_line + || last_stmt != STMT_WHEN) { + /* Output source location as code */ + output_line_and_trace_info (ip->test, STMT_WHEN); + last_stmt = STMT_WHEN; + } + /* LCOV_EXCL_START TODO - REMOVE when verified that we never reach this */ + } else { + output_line ("/* WHEN */"); + /* LCOV_EXCL_STOP */ + } + output_newline (); + } + + /* Really PRESENT WHEN for Report field/line */ + if (ip->statement == STMT_PRESENT_WHEN + && ip->stmt1 == NULL + && ip->stmt2 != NULL) { + struct cb_field *p2 = (struct cb_field *)ip->stmt2; + const char *target; + char fldname[64]; + if (p2->report_flag & COB_REPORT_LINE) { + sprintf (fldname, "%s%d",CB_PREFIX_REPORT_LINE,p2->id); + target = "Line"; + } else { + target = "Field"; + if (p2->report_field_name == NULL) { + sprintf (fldname,"%s%d",CB_PREFIX_REPORT_FIELD,++report_field_id); + p2->report_field_name = cobc_parse_strdup (fldname); + } else { + strcpy (fldname, p2->report_field_name); + } + } + output_line ("/* PRESENT WHEN %s: %d */", target, p2->common.source_line); + output_prefix (); + output ("if ("); + output_cond (ip->test, 0); + output (")"); + output_newline (); + output_line ("{"); + output_line ("\t%s.suppress = 0;", fldname); + output_line ("} else {"); + output_line ("\t%s.suppress = 1;", fldname); + output_line ("}"); + return; + } + + if (ip->test == cb_false + && ip->stmt1 == NULL + && cb_flag_remove_unreachable) { + output_line (" /* FALSE condition and code omitted */"); + skip_else = 1; + } else { + skip_else = 0; + output_prefix (); + output ("if ("); + output_cond (ip->test, 0); + output (")"); + output_newline (); + output_block_open (); + if (ip->stmt1) { + output_stmt (ip->stmt1); + } else { + output_line ("; /* Nothing */"); + } + output_block_close (); + } + + if (ip->stmt2) { + if (!skip_else) { + output_line ("else"); + } + output_line ("{"); + output_indent_level += 2; + if (ip->statement == STMT_IF) { + output_line ("/* ELSE */"); + } else { + output_line ("/* WHEN */"); + } + output_stmt (ip->stmt2); + output_indent_level -= 2; + output_line ("}"); + } +} + /* JSON/XML GENERATE suppress checks */ static void @@ -9109,66 +9225,373 @@ output_debug_stmts (cb_tree debug_checks) } static void -output_stmt (cb_tree x) +output_label_as_c (const struct cb_label *lp) { - stack_id = 0; - if (x == NULL) { - output_line (";"); + unsigned char buff[COB_MINI_BUFF]; + unsigned char *ptr = (unsigned char *)&buff; + cob_encode_program_id ((unsigned char*)lp->orig_name, ptr, + COB_MINI_MAX, COB_FOLD_UPPER); + if (*ptr == '_') ptr++; + if (lp->flag_section) { + /* SECTION label */ + output_line ("SECTION_%s:\t%s;", ptr, "cob_nop ()"); + } else if (lp->flag_entry_for_goto) { + /* ENTRY FOR GOTO label */ + if (cb_flag_source_location) { + const char *stmnt_enum + = cb_statement_enum_name[STMT_ENTRY_FOR_GO_TO]; + output_line ("ENTRY_GOTO_%s:\tmodule->statement = %s;", + ptr, stmnt_enum); + } else { + output_line ("ENTRY_GOTO_%s:\t%s;", ptr, "cob_nop ()"); + } + } else if (lp->flag_entry) { + /* ENTRY label */ + if (cb_flag_source_location) { + const char *stmnt_enum + = cb_statement_enum_name[STMT_ENTRY]; + output_line ("ENTRY_%s:\tmodule->statement = %s;", + ptr, stmnt_enum); + } else { + output_line ("ENTRY_%s:\t%s;", ptr, "cob_nop ()"); + } + } else { + /* Paragraph label */ + /* note: paragraphs need a suffix, both to not break some macro + names, and most important to prevent duplicates: + COBOL allows multiple pagraphs with the same name, even in the + same section; C allows only one per function and with our current + generation that means one identical generated paragraph + name "per program" */ + if (cb_flag_source_location) { + const char *stmnt_enum + = cb_statement_enum_name[STMT_ENTRY]; + output_line ("PARAGRAPH_%s_l_%d:\tmodule->statement = %s;", + ptr, lp->id, stmnt_enum); + } else { + output_line ("PARAGRAPH_%s_l_%d:\t%s;", ptr, lp->id, "cob_nop ()"); + } + } +} + +static void +output_label (const struct cb_label *lp) +{ + if (lp->flag_skip_label) { return; } - /* LCOV_EXCL_START */ - if (x == cb_error_node) { - cobc_err_msg (_("unexpected error_node parameter")); - COBC_ABORT (); + if (cb_flag_section_exit_check + && lp->flag_section + && !lp->flag_dummy_section) { + if (last_section + && last_section->flag_declaratives + && !lp->flag_declaratives) { + last_section = NULL; + } + if (last_section != NULL) { + output_line ("cob_check_beyond_exit (%s%d);" + "\t/* prevent fall-through */", CB_PREFIX_STRING, + lookup_string (last_section->name)); + } } - /* LCOV_EXCL_STOP */ - - if (inside_check != 0) { - if (inside_stack[inside_check - 1] != 0) { - inside_stack[inside_check - 1] = 0; - output (","); - output_newline (); + output_label_info (CB_TREE(lp), lp); + if (lp->flag_section) { + struct cb_para_label *pal; + for (pal = lp->para_label; pal; pal = pal->next) { + if (pal->para->segment > 49 + && pal->para->flag_alter) { + output_line ("label_%s%d = 0;", + CB_PREFIX_LABEL, pal->para->id); + } + } + last_segment = lp->segment; + last_section = lp; + } + if (lp->flag_begin) { + output_line ("%s%d:;", CB_PREFIX_LABEL, lp->id); + } + if (!lp->flag_dummy_exit + && !lp->flag_dummy_section + && !lp->flag_dummy_paragraph + && !lp->flag_default_handler) { + if (cb_flag_c_line_directives) { + output_cobol_info (CB_TREE(lp)); + } + if (cb_flag_c_labels) { + output_label_as_c (lp); + if (cb_flag_c_line_directives) { + output_c_info (); + } + } else { + if (cb_flag_c_line_directives) { + output_line ("cob_nop ();"); + output_c_info (); + } } } - if (x->source_line) { - cb_source_file = x->source_file; - cb_source_line = -x->source_line; - /* cb_source_column = x->source_column; */ + /* Check for runtime debug flag */ + if (current_prog->flag_debugging && lp->flag_is_debug_sect) { + output_line ("if (!cob_glob_ptr->cob_debugging_mode)"); + output_line ("\tgoto %s%d;", + CB_PREFIX_LABEL, CB_LABEL (lp->exit_label)->id); } - switch (CB_TREE_TAG (x)) { - case CB_TAG_STATEMENT: { - const struct cb_statement *p = CB_STATEMENT (x); - cb_tree debug_checks = current_prog->flag_gen_debug ? p->debug_check : NULL; - /* note: p->name and x->sourcefile/line are always available here */ + if (cb_flag_trace + || cobc_wants_debug) { + output_section_info (lp); + } + last_line = -1; /* force generation of source location */ - /* Output source location, but only if it isn't an implicit statement */ - if (!p->flag_implicit) { - /* Output source location as a comment */ - skip_line_num = 4; - /* Output source location as code */ - output_source_reference (x, p->statement); - /* USE FOR DEBUGGING: pre-fill DEBUG-LINE - FIXME: postpone to actual DEBUGGING procedure, - using module->module_stmt there - */ - if (current_prog->flag_gen_debug - && !p->flag_in_debug) { - output_prefix (); - output ("memcpy ("); - output_data (cb_debug_line); - output (", \"%6d\", 6);", x->source_line); - output_newline (); - } - last_line = x->source_line; - skip_line_num = 0; + /* Check procedure debugging */ + if (current_prog->flag_gen_debug && lp->flag_real_label) { + output_stmt (cb_build_debug (cb_debug_name, + (const char*)lp->name, NULL)); + if (current_prog->all_procedure) { + output_perform_call (current_prog->all_procedure, NULL); + } else if (lp->flag_debugging_mode) { + output_perform_call (lp->debug_section, NULL); } + } - if (!p->file) { + /* Check ALTER processing */ + if (lp->flag_alter) { + output_alter_check (lp); + } +} - if (p->ex_handler || p->not_ex_handler) { - output_line ("COB_RESET_EXCEPTION (0);"); +static void +output_assign (const struct cb_assign *ap) +{ + struct cb_field *f1, *f2; + if (CB_TREE_CLASS (ap->var) == CB_CLASS_NUMERIC + || CB_TREE_CLASS (ap->var) == CB_CLASS_ALPHANUMERIC + || CB_TREE_CLASS (ap->var) == CB_CLASS_ALPHABETIC) { + f1 = cb_code_field(ap->var); + if (!f1->flag_real_binary + && !f1->flag_binary_assign + && !(f1->usage == CB_USAGE_COMP_X && f1->size == 1) + && f1->pic + && f1->usage != CB_USAGE_LENGTH) { + output_prefix (); + if (f1->usage == CB_USAGE_COMP_X) { + output ("cob_set_compx ("); + output_param (ap->var, 0); + output (", (cob_s64_t)"); + output_integer (ap->val); + output (");\n"); + return; + } else + if (CB_NUMERIC_LITERAL_P (ap->val) + && CB_LITERAL (ap->val)->scale == 0 + && cb_get_long_long (ap->val) < cob_exp10_ll[f1->pic->digits]) { + output ("cob_set_llcon ("); + output_param (ap->var, 0); + } else { + output ("cob_set_llint ("); + output_param (ap->var, 0); + output (", "); + output (CB_FMT_LLD_F, cob_exp10_ll[f1->pic->digits]); + } + output (", (cob_s64_t)"); + output_integer (ap->val); + output (");\n"); + return; + } + } +#ifdef COB_NON_ALIGNED /* Nonaligned */ + if (CB_TREE_CLASS (ap->var) == CB_CLASS_POINTER + || CB_TREE_CLASS (ap->val) == CB_CLASS_POINTER) { + /* Pointer assignment */ + output_block_open (); + output_line ("void *temp_ptr;"); + + /* temp_ptr = source address; */ + output_prefix (); + if (ap->val == cb_null || ap->val == cb_zero) { + /* MOVE NULL ... */ + output ("temp_ptr = 0;"); + } else if (CB_TREE_TAG (ap->val) == CB_TAG_CAST) { + /* MOVE ADDRESS OF val ... */ + const struct cb_cast *cp = CB_CAST (ap->val); + output ("temp_ptr = "); + switch (cp->cast_type) { + case CB_CAST_ADDRESS: + output_data (cp->val); + break; + case CB_CAST_PROGRAM_POINTER: + output ("cob_call_field ("); + output_param (ap->val, -1); + if (current_prog->nested_prog_list) { + gen_nested_tab = 1; + output (", cob_nest_tab, 0, %d)", + cb_fold_call); + } else { + output (", NULL, 0, %d)", + cb_fold_call); + } + break; + /* LCOV_EXCL_START */ + default: + cobc_err_msg (_("unexpected cast type: %d"), + cp->cast_type); + COBC_ABORT (); + /* LCOV_EXCL_STOP */ + } + output (";"); + } else { + /* MOVE val ... */ + output ("memcpy(&temp_ptr, "); + output_data (ap->val); + output (", sizeof(temp_ptr));"); + } + output_newline (); + + /* Destination address = temp_ptr; */ + output_prefix (); + if (CB_TREE_TAG (ap->var) == CB_TAG_CAST) { + /* SET ADDRESS OF var ... */ + const struct cb_cast *cp = CB_CAST (ap->var); + /* LCOV_EXCL_START */ + if (cp->cast_type != CB_CAST_ADDRESS) { + cobc_err_msg (_("unexpected tree type: %d"), + cp->cast_type); + COBC_ABORT (); + } + /* LCOV_EXCL_STOP */ + output_data (cp->val); + output (" = temp_ptr;"); + } else { + /* MOVE ... TO var */ + output ("memcpy("); + output_data (ap->var); + output (", &temp_ptr, sizeof(temp_ptr));"); + } + output_newline (); + + output_block_close (); + } else { + /* Numeric assignment */ + output_prefix (); + output_integer (ap->var); + output (" = "); + output_integer (ap->val); + if (inside_check == 0) { + output (";"); + output_newline (); + if (CB_TREE_TAG (ap->var) == CB_TAG_CAST + && CB_CAST (ap->var)->cast_type == CB_CAST_ADDRESS + && CB_TREE_TAG (ap->val) == CB_TAG_CAST + && CB_CAST (ap->val)->cast_type == CB_CAST_ADDRESS) { + f1 = cb_code_field (CB_CAST(ap->var)->val); + if (!f1->flag_field) { + force_cache (f1); + } + if (f1->flag_any_length) { + f2 = cb_code_field (CB_CAST(ap->val)->val); + if (!f2->flag_field) { + force_cache (f2); + } + output_line ("%s%d.size = %s%d.size;", + CB_PREFIX_FIELD, f1->id, + CB_PREFIX_FIELD, f2->id); + } + } + } else { + inside_stack[inside_check - 1] = 1; + } + } +#else /* Nonaligned */ + /* Numeric assignment */ + output_prefix (); + output_integer (ap->var); + output (" = "); + output_integer (ap->val); + if (inside_check == 0) { + output (";"); + output_newline (); + if (CB_TREE_TAG (ap->var) == CB_TAG_CAST + && CB_CAST (ap->var)->cast_type == CB_CAST_ADDRESS + && CB_TREE_TAG (ap->val) == CB_TAG_CAST + && CB_CAST (ap->val)->cast_type == CB_CAST_ADDRESS) { + f1 = cb_code_field (CB_CAST(ap->var)->val); + if (f1->flag_any_length) { + f2 = cb_code_field (CB_CAST(ap->val)->val); + if (!f2->flag_field) { + force_cache (f2); + } + output_line ("%s%d.size = %s%d.size;", + CB_PREFIX_FIELD, f1->id, + CB_PREFIX_FIELD, f2->id); + } + } + } else { + inside_stack[inside_check - 1] = 1; + } +#endif /* Nonaligned */ +} + +static void +output_stmt (cb_tree x) +{ + stack_id = 0; + if (x == NULL) { + output_line (";"); + return; + } + /* LCOV_EXCL_START */ + if (x == cb_error_node) { + cobc_err_msg (_("unexpected error_node parameter")); + COBC_ABORT (); + } + /* LCOV_EXCL_STOP */ + + if (inside_check != 0) { + if (inside_stack[inside_check - 1] != 0) { + inside_stack[inside_check - 1] = 0; + output (","); + output_newline (); + } + } + + if (x->source_line) { + cb_source_file = x->source_file; + cb_source_line = -x->source_line; + /* cb_source_column = x->source_column; */ + } + + switch (CB_TREE_TAG (x)) { + case CB_TAG_STATEMENT: { + const struct cb_statement *p = CB_STATEMENT (x); + cb_tree debug_checks = current_prog->flag_gen_debug ? p->debug_check : NULL; + /* note: p->name and x->sourcefile/line are always available here */ + + /* Output source location, but only if it isn't an implicit statement */ + if (!p->flag_implicit) { + /* Output source location as a comment */ + skip_line_num = 4; + /* Output source location as code */ + output_source_reference (x, p->statement); + /* USE FOR DEBUGGING: pre-fill DEBUG-LINE + FIXME: postpone to actual DEBUGGING procedure, + using module->module_stmt there + */ + if (current_prog->flag_gen_debug + && !p->flag_in_debug) { + output_prefix (); + output ("memcpy ("); + output_data (cb_debug_line); + output (", \"%6d\", 6);", x->source_line); + output_newline (); + } + last_line = x->source_line; + skip_line_num = 0; + } + + if (!p->file) { + + if (p->ex_handler || p->not_ex_handler) { + output_line ("COB_RESET_EXCEPTION (0);"); } else if (cobc_wants_debug) { output_line ("cob_global_exception = -1;"); @@ -9277,123 +9700,10 @@ output_stmt (cb_tree x) } break; } - case CB_TAG_LABEL: { - const struct cb_label *lp = CB_LABEL (x); - if (lp->flag_skip_label) { - break; - } - if (cb_flag_section_exit_check - && lp->flag_section - && !lp->flag_dummy_section) { - if (last_section - && last_section->flag_declaratives - && !lp->flag_declaratives) { - last_section = NULL; - } - if (last_section != NULL) { - output_line ("cob_check_beyond_exit (%s%d);" - "\t/* prevent fall-through */", CB_PREFIX_STRING, - lookup_string (last_section->name)); - } - } - output_label_info (x, lp); - if (lp->flag_section) { - struct cb_para_label *pal; - for (pal = lp->para_label; pal; pal = pal->next) { - if (pal->para->segment > 49 - && pal->para->flag_alter) { - output_line ("label_%s%d = 0;", - CB_PREFIX_LABEL, pal->para->id); - } - } - last_segment = lp->segment; - last_section = lp; - } - if (lp->flag_begin) { - output_line ("%s%d:;", CB_PREFIX_LABEL, lp->id); - } - if (!lp->flag_dummy_exit - && !lp->flag_dummy_section - && !lp->flag_dummy_paragraph) { - if (cb_flag_c_line_directives) { - output_cobol_info (x); - } - if (cb_flag_c_labels - && (lp->flag_entry || lp->flag_section)) { - /* possibly come back later adding paragraphs, too; - note: these need also a prefix to not break some macro names, - and most important: COBOL allows multiple with the same - name, even in the same section; C allows only one per - function and with our current generation that means - one identical generated paragraph name "per program" */ - unsigned char buff[COB_MINI_BUFF]; - unsigned char *ptr = (unsigned char *)&buff; - cob_encode_program_id ((unsigned char*)lp->orig_name, ptr, - COB_MINI_MAX, COB_FOLD_UPPER); - if (*ptr == '_') ptr++; - if (lp->flag_section) { - output_line ("SECTION_%s:\t%s;", ptr, "cob_nop ()"); - } else if (lp->flag_entry_for_goto) { - if (cb_flag_source_location) { - const char *stmnt_enum - = cb_statement_enum_name[STMT_ENTRY_FOR_GO_TO]; - output_line ("ENTRY_GOTO_%s:\tmodule->statement = %s;", - ptr, stmnt_enum); - } else { - output_line ("ENTRY_GOTO_%s:\t%s;", ptr, "cob_nop ()"); - } - } else { - if (cb_flag_source_location) { - const char *stmnt_enum - = cb_statement_enum_name[STMT_ENTRY]; - output_line ("ENTRY_%s:\tmodule->statement = %s;", - ptr, stmnt_enum); - } else { - output_line ("ENTRY_%s:\t%s;", ptr, "cob_nop ()"); - } - } - if (cb_flag_c_line_directives) { - output_c_info (); - } - } else { - if (cb_flag_c_line_directives) { - output_line ("cob_nop ();"); - output_c_info (); - } - } - } - - /* Check for runtime debug flag */ - if (current_prog->flag_debugging && lp->flag_is_debug_sect) { - output_line ("if (!cob_glob_ptr->cob_debugging_mode)"); - output_line ("\tgoto %s%d;", - CB_PREFIX_LABEL, CB_LABEL (lp->exit_label)->id); - } - - if (cb_flag_trace - || cobc_wants_debug) { - output_section_info (lp); - } - last_line = -1; /* force generation of source location */ - - /* Check procedure debugging */ - if (current_prog->flag_gen_debug && lp->flag_real_label) { - output_stmt (cb_build_debug (cb_debug_name, - (const char*)lp->name, NULL)); - if (current_prog->all_procedure) { - output_perform_call (current_prog->all_procedure, NULL); - } else if (lp->flag_debugging_mode) { - output_perform_call (lp->debug_section, NULL); - } - } - - /* Check ALTER processing */ - if (lp->flag_alter) { - output_alter_check (lp); - } - + case CB_TAG_LABEL: + output_label (CB_LABEL(x)); break; - } + case CB_TAG_FUNCALL: output_prefix (); output_funcall (x); @@ -9404,192 +9714,31 @@ output_stmt (cb_tree x) inside_stack[inside_check - 1] = 1; } break; - case CB_TAG_ASSIGN: { - const struct cb_assign *ap = CB_ASSIGN (x); - struct cb_field *f1, *f2; - if (CB_TREE_CLASS (ap->var) == CB_CLASS_NUMERIC - || CB_TREE_CLASS (ap->var) == CB_CLASS_ALPHANUMERIC - || CB_TREE_CLASS (ap->var) == CB_CLASS_ALPHABETIC) { - f1 = cb_code_field(ap->var); - if (!f1->flag_real_binary - && !f1->flag_binary_assign - && !(f1->usage == CB_USAGE_COMP_X && f1->size == 1) - && f1->pic - && f1->usage != CB_USAGE_LENGTH) { - output_prefix (); - if (f1->usage == CB_USAGE_COMP_X) { - output ("cob_set_compx ("); - output_param (ap->var, 0); - output (", (cob_s64_t)"); - output_integer (ap->val); - output (");\n"); - break; - } else - if (CB_NUMERIC_LITERAL_P (ap->val) - && CB_LITERAL (ap->val)->scale == 0 - && cb_get_long_long (ap->val) < cob_exp10_ll[f1->pic->digits]) { - output ("cob_set_llcon ("); - output_param (ap->var, 0); - } else { - output ("cob_set_llint ("); - output_param (ap->var, 0); - output (", "); - output (CB_FMT_LLD_F, cob_exp10_ll[f1->pic->digits]); - } - output (", (cob_s64_t)"); - output_integer (ap->val); - output (");\n"); - break; - } - } -#ifdef COB_NON_ALIGNED - /* Nonaligned */ - if (CB_TREE_CLASS (ap->var) == CB_CLASS_POINTER - || CB_TREE_CLASS (ap->val) == CB_CLASS_POINTER) { - /* Pointer assignment */ - output_block_open (); - output_line ("void *temp_ptr;"); - /* temp_ptr = source address; */ - output_prefix (); - if (ap->val == cb_null || ap->val == cb_zero) { - /* MOVE NULL ... */ - output ("temp_ptr = 0;"); - } else if (CB_TREE_TAG (ap->val) == CB_TAG_CAST) { - /* MOVE ADDRESS OF val ... */ - const struct cb_cast *cp = CB_CAST (ap->val); - output ("temp_ptr = "); - switch (cp->cast_type) { - case CB_CAST_ADDRESS: - output_data (cp->val); - break; - case CB_CAST_PROGRAM_POINTER: - output ("cob_call_field ("); - output_param (ap->val, -1); - if (current_prog->nested_prog_list) { - gen_nested_tab = 1; - output (", cob_nest_tab, 0, %d)", - cb_fold_call); - } else { - output (", NULL, 0, %d)", - cb_fold_call); - } - break; - /* LCOV_EXCL_START */ - default: - cobc_err_msg (_("unexpected cast type: %d"), - cp->cast_type); - COBC_ABORT (); - /* LCOV_EXCL_STOP */ - } - output (";"); - } else { - /* MOVE val ... */ - output ("memcpy(&temp_ptr, "); - output_data (ap->val); - output (", sizeof(temp_ptr));"); - } - output_newline (); - - /* Destination address = temp_ptr; */ - output_prefix (); - if (CB_TREE_TAG (ap->var) == CB_TAG_CAST) { - /* SET ADDRESS OF var ... */ - const struct cb_cast *cp = CB_CAST (ap->var); - /* LCOV_EXCL_START */ - if (cp->cast_type != CB_CAST_ADDRESS) { - cobc_err_msg (_("unexpected tree type: %d"), - cp->cast_type); - COBC_ABORT (); - } - /* LCOV_EXCL_STOP */ - output_data (cp->val); - output (" = temp_ptr;"); - } else { - /* MOVE ... TO var */ - output ("memcpy("); - output_data (ap->var); - output (", &temp_ptr, sizeof(temp_ptr));"); - } - output_newline (); - - output_block_close (); - } else { - /* Numeric assignment */ - output_prefix (); - output_integer (ap->var); - output (" = "); - output_integer (ap->val); - if (inside_check == 0) { - output (";"); - output_newline (); - if (CB_TREE_TAG (ap->var) == CB_TAG_CAST - && CB_CAST (ap->var)->cast_type == CB_CAST_ADDRESS - && CB_TREE_TAG (ap->val) == CB_TAG_CAST - && CB_CAST (ap->val)->cast_type == CB_CAST_ADDRESS) { - f1 = cb_code_field (CB_CAST(ap->var)->val); - if (!f1->flag_field) { - force_cache (f1); - } - if (f1->flag_any_length) { - f2 = cb_code_field (CB_CAST(ap->val)->val); - if (!f2->flag_field) { - force_cache (f2); - } - output_line ("%s%d.size = %s%d.size;", - CB_PREFIX_FIELD, f1->id, - CB_PREFIX_FIELD, f2->id); - } - } - } else { - inside_stack[inside_check - 1] = 1; - } - } -#else /* Nonaligned */ - /* Numeric assignment */ - output_prefix (); - output_integer (ap->var); - output (" = "); - output_integer (ap->val); - if (inside_check == 0) { - output (";"); - output_newline (); - if (CB_TREE_TAG (ap->var) == CB_TAG_CAST - && CB_CAST (ap->var)->cast_type == CB_CAST_ADDRESS - && CB_TREE_TAG (ap->val) == CB_TAG_CAST - && CB_CAST (ap->val)->cast_type == CB_CAST_ADDRESS) { - f1 = cb_code_field (CB_CAST(ap->var)->val); - if (f1->flag_any_length) { - f2 = cb_code_field (CB_CAST(ap->val)->val); - if (!f2->flag_field) { - force_cache (f2); - } - output_line ("%s%d.size = %s%d.size;", - CB_PREFIX_FIELD, f1->id, - CB_PREFIX_FIELD, f2->id); - } - } - } else { - inside_stack[inside_check - 1] = 1; - } -#endif /* Nonaligned */ + case CB_TAG_ASSIGN: + output_assign (CB_ASSIGN (x)); break; - } + case CB_TAG_INITIALIZE: output_initialize (CB_INITIALIZE (x)); break; + case CB_TAG_SEARCH: output_search (CB_SEARCH (x)); break; + case CB_TAG_CALL: output_call (CB_CALL (x)); break; + case CB_TAG_GOTO: output_goto (CB_GOTO (x)); break; + case CB_TAG_CANCEL: output_cancel (CB_CANCEL (x)); break; + case CB_TAG_SET_ATTR: { const struct cb_set_attr *sap = CB_SET_ATTR (x); output_set_attribute (sap->fld, sap->val_on, sap->val_off); @@ -9598,149 +9747,25 @@ output_stmt (cb_tree x) case CB_TAG_XML_PARSE: output_xml_parse (CB_XML_PARSE (x)); break; + case CB_TAG_ALTER: output_alter (CB_ALTER (x)); break; - case CB_TAG_IF: { - const struct cb_if *ip = CB_IF (x); - int skip_else; - if (ip->stmt1 == NULL - && ip->stmt2 == NULL) { - if (ip->statement != STMT_IF) { - output_line ("/* WHEN has code omitted */"); - } else { - output_line ("/* IF has code omitted */"); - } - break; - } - if (ip->statement != STMT_IF) { - output_newline (); - if (ip->test == cb_true - && cb_flag_remove_unreachable) { - output_line ("/* WHEN is always TRUE */"); - } else if (ip->test == cb_false - && cb_flag_remove_unreachable) { - output_line ("/* WHEN is always FALSE */"); - } else - if (ip->test - && CB_TREE_TAG (ip->test) == CB_TAG_BINARY_OP) { - const struct cb_binary_op *bop = CB_BINARY_OP (ip->test); - cb_tree w = NULL; - if (bop->op == '!') { - w = bop->x; - } else if (bop->y) { - w = bop->y; - } else if (bop->x) { - w = bop->x; - } - if (w == cb_true) { - output_line ("/* WHEN is always %s */", bop->op == '!' ? "FALSE" : "TRUE"); - } else if (w == cb_false) { - output_line ("/* WHEN is always %s */", bop->op != '!' ? "FALSE" : "TRUE"); - } else { - w = ip->test; - /* LCOV_EXCL_START */ - if (!ip->test->source_line) { - /* untranslated as unlikely internal-check-only message */ - cobc_err_msg ("Unexpected call to output_stmt -> TAG_IF (BINARY) without source reference"); - output_line ("/* WHEN */"); - /* LCOV_EXCL_STOP */ - } else { - output_source_reference (w, STMT_WHEN); - } - } - } else if (ip->test->source_line) { - output_line ("/* Line: %-10d: WHEN */", ip->test->source_line); - if (last_line != ip->test->source_line - || last_stmt != STMT_WHEN) { - /* Output source location as code */ - output_line_and_trace_info (ip->test, STMT_WHEN); - last_stmt = STMT_WHEN; - } - /* LCOV_EXCL_START TODO - REMOVE when verified that we never reach this */ - } else { - output_line ("/* WHEN */"); - /* LCOV_EXCL_STOP */ - } - output_newline (); - } - output_prefix (); - /* Really PRESENT WHEN for Report field/line */ - if (ip->statement == STMT_PRESENT_WHEN - && ip->stmt1 == NULL - && ip->stmt2 != NULL) { - struct cb_field *p2 = (struct cb_field *)ip->stmt2; - const char *target; - char fldname[64]; - if (p2->report_flag & COB_REPORT_LINE) { - sprintf (fldname, "%s%d",CB_PREFIX_REPORT_LINE,p2->id); - target = "Line"; - } else { - target = "Field"; - if (p2->report_field_name == NULL) { - sprintf (fldname,"%s%d",CB_PREFIX_REPORT_FIELD,++report_field_id); - p2->report_field_name = cobc_parse_strdup (fldname); - } else { - strcpy (fldname, p2->report_field_name); - } - } - output_line ("/* PRESENT WHEN %s: %d */", target, p2->common.source_line); - output_prefix (); - output ("if ("); - output_cond (ip->test, 0); - output (")"); - output_newline (); - output_line ("{"); - output_line ("\t%s.suppress = 0;", fldname); - output_line ("} else {"); - output_line ("\t%s.suppress = 1;", fldname); - output_line ("}"); - break; - } - if (ip->test == cb_false - && ip->stmt1 == NULL - && cb_flag_remove_unreachable) { - output_line (" /* FALSE condition and code omitted */"); - skip_else = 1; - } else { - skip_else = 0; - output ("if ("); - output_cond (ip->test, 0); - output (")"); - output_newline (); - output_block_open (); - if (ip->stmt1) { - output_stmt (ip->stmt1); - } else { - output_line ("; /* Nothing */"); - } - output_block_close (); - } - if (ip->stmt2) { - if (!skip_else) { - output_line ("else"); - } - output_line ("{"); - output_indent_level += 2; - if (ip->statement == STMT_IF) { - output_line ("/* ELSE */"); - } else { - output_line ("/* WHEN */"); - } - output_stmt (ip->stmt2); - output_indent_level -= 2; - output_line ("}"); - } + + case CB_TAG_IF: + output_if (CB_IF (x)); break; - } + case CB_TAG_PERFORM: output_perform (CB_PERFORM (x)); break; + /* "common" CONTINUE, note: CONTINUE AFTER exp SECONDS is already translated into a funcall */ case CB_TAG_CONTINUE: output_line (";"); break; + case CB_TAG_LIST: if (cb_flag_extra_brace) { output_block_open (); @@ -9752,9 +9777,11 @@ output_stmt (cb_tree x) output_block_close (); } break; + case CB_TAG_REFERENCE: output_stmt (CB_REFERENCE(x)->value); break; + case CB_TAG_DIRECT: if (CB_DIRECT (x)->flag_is_direct) { if (CB_DIRECT (x)->flag_new_line) { @@ -9770,97 +9797,14 @@ output_stmt (cb_tree x) /* setting DEBUG-ITEM */ case CB_TAG_DEBUG: if (current_prog->flag_gen_debug) { - const struct cb_debug *dbg = CB_DEBUG (x); - const size_t size = cb_code_field (dbg->target)->size; - const size_t copy_size = dbg->size > size ? size : dbg->size; - if (dbg->value) { - /* pre-defined string */ - output_prefix (); - output ("memcpy ("); - output_data (dbg->target); - output (", "); - output ("%s%d", CB_PREFIX_STRING, lookup_string (dbg->value)); - output (", %u);", (unsigned int)copy_size); - output_newline (); - /* ... filled up with space */ - if (copy_size != size) { - output_prefix (); - output ("memset ("); - output_data (dbg->target); - output (" + %u, ' ', %u);", - (unsigned int)dbg->size, (unsigned int)(size - dbg->size)); - output_newline (); - } - } else { - /* content of variable */ - struct cb_field *f = CB_FIELD_PTR (dbg->fld); - /* address may change so we may have NULL or invalid pointer */ - if (f->flag_item_based || f->storage == CB_STORAGE_LINKAGE) { -#if 0 /* FIXME: this should be replaced in 4.x by a call to libcob - which checks for NULL, and for invalid access via handler, - then outputs the appropriate value */ - struct cb_field * ff = real_field_founder (f); - output_prefix (); - output ("cob_set_verified_data ("); - output_data (dbg->target); - output (", "); - output_data (CB_TREE(ff)); - output (", " CB_FMT_LLU ", %u); ", f->offset, size); - output_newline (); -#else - - const char *null_rep = ""; - f = real_field_founder (f); - /* in this case - pre-fill with space, then set var / null_rep */ - output_prefix (); - output ("memset ("); - output_data (dbg->target); - output (", ' ', %u);", (unsigned int)size); - output_newline (); - output_prefix (); - output ("if ("); - output_data (CB_TREE (f)); - output (" == NULL)"); - output_newline (); - output_prefix (); - output ("\t""memcpy ("); - output_data (dbg->target); - output (", %s%d", CB_PREFIX_STRING, lookup_string (null_rep)); - output (", %u);", (unsigned int)strlen (null_rep)); - output_newline (); - output_line ("else"); - output_prefix (); - output ("\t""memcpy ("); - output_data (dbg->target); - output (", "); - output_data (dbg->fld); - output (", %u);", (unsigned int)copy_size); - output_newline (); -#endif - } else { - /* normal field without changing address, copy data up to max*/ - output ("memcpy ("); - output_data (dbg->target); - output (", "); - output_data (dbg->fld); - output (", %u);", (unsigned int)copy_size); - output_newline (); - /* ... filled up with space */ - if (copy_size != size) { - output_prefix (); - output ("memset ("); - output_data (dbg->target); - output (" + %u, ' ', %u);", - (unsigned int)dbg->size, (unsigned int)(size - dbg->size)); - output_newline (); - } - } - } + output_debug_item (CB_DEBUG (x)); } break; + case CB_TAG_DEBUG_CALL: output_perform_call (CB_DEBUG_CALL(x)->target, NULL); break; + case CB_TAG_ML_SUPPRESS_CHECKS: output_ml_suppress_checks (CB_ML_SUPPRESS_CHECKS (x)); break; @@ -10204,14 +10148,16 @@ output_file_initialization (struct cb_file *f) const char *alph_write, *alph_read; switch (f->code_set->alphabet_type) { case CB_ALPHABET_ASCII: - alph_read = colseq_table_name (cb_ebcdic_table, OF_ASCII, 0); - alph_write = colseq_table_name (cb_ebcdic_table, TO_ASCII, 0); + alph_read = "cob_ascii_ebcdic"; + alph_write = "cob_ebcdic_ascii"; gen_ebcdic_ascii = 1; + gen_ascii_ebcdic |= 1; break; case CB_ALPHABET_EBCDIC: - alph_read = colseq_table_name (cb_ebcdic_table, TO_ASCII, 0); - alph_write = colseq_table_name (cb_ebcdic_table, OF_ASCII, 0); + alph_read = "cob_ebcdic_ascii"; + alph_write = "cob_ascii_ebcdic"; gen_ebcdic_ascii = 1; + gen_ascii_ebcdic |= 1; break; /* case CB_ALPHABET_CUSTOM: */ default: @@ -12104,6 +12050,8 @@ output_module_init_function (struct cb_program *prog) output_line ("module->module_sources = NULL;"); } + output_init_collating_tables(); + output_block_close (); output_newline (); } @@ -14368,10 +14316,7 @@ codegen_init (struct cb_program *prog, const char *translate_name) buff[pos] = 0; output_name = cobc_check_string (buff); } - gen_default_ebcdic = 0; - gen_alt_ebcdic = 0; - gen_ibm_ebcdic = 0; - gen_gcos7_ebcdic = 0; + gen_ascii_ebcdic = 0; gen_ebcdic_ascii = 0; gen_native = 0; gen_figurative = 0; @@ -14539,8 +14484,7 @@ codegen_internal (struct cb_program *prog, const int subsequent_call) output_newline (); } - if (((gen_native | gen_default_ebcdic | gen_alt_ebcdic | - gen_ibm_ebcdic | gen_gcos7_ebcdic) > 1) + if (((gen_native | gen_ascii_ebcdic) > 1) || gen_ebcdic_ascii || prog->alphabet_name_list) { (void)lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0); } diff --git a/cobc/field.c b/cobc/field.c index f7c7e3a65..490b540ea 100644 --- a/cobc/field.c +++ b/cobc/field.c @@ -1238,7 +1238,7 @@ validate_any_length_item (struct cb_field *f) } else if (f->pic->category != CB_CATEGORY_ALPHANUMERIC && f->pic->category != CB_CATEGORY_NATIONAL && f->pic->category != CB_CATEGORY_BOOLEAN) { - cb_error_x (x, _("'%s' ANY LENGTH must be PIC X, PIC N or PIC 1"), + cb_error_x (x, _("'%s' ANY LENGTH must be PIC X, PIC U, PIC N or PIC 1"), f->name); } /* diff --git a/cobc/flag.def b/cobc/flag.def index 47827cc0e..f26984769 100644 --- a/cobc/flag.def +++ b/cobc/flag.def @@ -89,7 +89,7 @@ CB_FLAG_NQ (0, "ec", 14, CB_FLAG_NQ (0, "no-ec", 17, _(" -fno-ec=\tdisable code generation for ")) -CB_FLAG_NQ (1, "ebcdic-table", 16, /* cf cconv.h for all available tables */ +CB_FLAG_RQ (cb_ebcdic_table, 1, "ebcdic-table", 0, 16, /* cf cconv.h for all available tables */ _(" -febcdic-table=[DEFAULT|RESTRICTED-GC|IBM|GCOS]\tdefine EBCDIC translation table:\n" " * default: translation to extended ASCII as per MF\n" " * restricted-gc: translation from restricted ASCII only\n" diff --git a/cobc/help.c b/cobc/help.c index a8e01943e..76309f5ad 100644 --- a/cobc/help.c +++ b/cobc/help.c @@ -25,6 +25,7 @@ #include #include "cobc.h" +#include "tree.h" /* for COB_INTERNAL_XREF */ void cobc_print_usage (char * prog) @@ -129,6 +130,8 @@ cobc_print_usage_common_options (void) puts (_(" --list-system display system routines")); puts (_(" --save-temps[=] save intermediate files\n" " * default: current directory")); + puts (_(" -MT set/add target file used in dependency list")); + puts (_(" -MF place dependency list into ")); puts (_(" -ext add file extension for resolving COPY")); putchar ('\n'); } diff --git a/cobc/parser.y b/cobc/parser.y index b86ff0288..2a308887c 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -2208,7 +2208,7 @@ static void error_if_following_every_clause (void) { if (ml_suppress_list - && CB_ML_SUPPRESS (CB_VALUE (ml_suppress_list))->target == CB_ML_SUPPRESS_TYPE) { + && CB_ML_SUPPRESS (CB_VALUE (ml_suppress_list))->target == CB_ML_SUPPRESS_TYPE) { cb_error (_("WHEN clause must follow EVERY clause")); } } @@ -2243,9 +2243,9 @@ add_when_to_ml_suppress_conds (cb_tree when_list) */ if (ml_suppress_list) { last_suppress_clause = CB_ML_SUPPRESS (CB_VALUE (ml_suppress_list)); - if ((last_suppress_clause->target == CB_ML_SUPPRESS_IDENTIFIER - || last_suppress_clause->target == CB_ML_SUPPRESS_TYPE) - && !last_suppress_clause->when_list) { + if ( (last_suppress_clause->target == CB_ML_SUPPRESS_IDENTIFIER + || last_suppress_clause->target == CB_ML_SUPPRESS_TYPE) + && !last_suppress_clause->when_list) { last_suppress_clause->when_list = when_list; return; } @@ -7628,7 +7628,7 @@ picture_clause: check_repeated ("PICTURE", SYN_CLAUSE_4, &check_pic_duplicate); current_field->pic = CB_PICTURE ($1); /* always returned, invalid picture will have size == 0 */ } - _pic_locale_format_or_depending_on + _pic_locale_format_or_depending_on_or_byte_length { if ((!current_field->pic || current_field->pic->variable_length) && !current_field->flag_picture_l) { @@ -7640,7 +7640,7 @@ picture_clause: } ; -_pic_locale_format_or_depending_on: +_pic_locale_format_or_depending_on_or_byte_length: /* empty */ | LOCALE _is_locale_name SIZE _is integer { @@ -7697,6 +7697,7 @@ _pic_locale_format_or_depending_on: redefines. */ current_field->flag_picture_l = 1; } +| byte_length_clause ; _is_locale_name: @@ -8003,7 +8004,12 @@ usage: check_repeated ("USAGE", SYN_CLAUSE_5, &check_pic_duplicate); CB_UNFINISHED ("USAGE NATIONAL"); } -| TYPEDEF_NAME +| UTF_8 + { + check_repeated ("USAGE", SYN_CLAUSE_5, &check_pic_duplicate); + CB_UNFINISHED ("USAGE UTF-8"); + } +| TYPEDEF_NAME { if (!check_repeated ("USAGE", SYN_CLAUSE_5, &check_pic_duplicate)) { if (current_field->external_definition) { @@ -8093,6 +8099,20 @@ sign_clause: } ; +/* BYTE-LENGTH clause (UTF-8 data items) */ + +byte_length_clause: + BYTE_LENGTH integer + { + if (current_field->pic && current_field->pic->orig + && current_field->pic->orig[0] == 'U') { + current_field->size = cb_get_int ($2); + } else { + /* wrong place, but good enough for now */ + cb_error (_("'%s' is not USAGE UTF-8"), cb_name (CB_TREE(current_field))); + } + } +; /* REPORT (RD) OCCURS clause */ @@ -15791,7 +15811,7 @@ search_body: table_name _search_varying _search_at_end search_whens { - cb_emit_search ($1, $2, $3, $4); + $$ = cb_emit_search ($1, $2, $3, $4); } ; @@ -15800,7 +15820,7 @@ search_all_body: WHEN expr statement_list { - cb_emit_search_all ($1, $2, $4, $5); + $$ = cb_emit_search_all ($1, $2, $4, $5); } ; @@ -15851,12 +15871,26 @@ _end_search: { TERMINATOR_WARNING ($-2, SEARCH); } -| END_SEARCH +| END_SEARCH end_search_pos_token { + cb_tree x = $-0; + if (x) { + struct cb_search *p = CB_SEARCH ($-0); + if (p->at_end == NULL) { + cb_tree brk = cb_build_direct ("break;", 0); + p->at_end = CB_BUILD_PAIR ($2, brk); + } + } TERMINATOR_CLEAR ($-2, SEARCH); } ; +end_search_pos_token: + { + $$ = cb_build_comment ("END-SEARCH"); + } +; + /* SEND statement (COMMUNICATION SECTION) */ @@ -18008,6 +18042,12 @@ _count_in: /* Expressions */ +/* CHECKME: How can we integrate source references here + to correctly attach #line directives in the code + within codegen.c (output_cond) ? + Possibly directly add in push_expr? + This may also allows us to drop cb_exp_line */ + condition: expr { diff --git a/cobc/pplex.l b/cobc/pplex.l index 2793aa5ae..d47641382 100644 --- a/cobc/pplex.l +++ b/cobc/pplex.l @@ -183,9 +183,12 @@ static void check_listing (const char *, const unsigned int); static void skip_to_eol (void); static void count_newlines (const char *); static void display_finish (void); -static void set_print_replace_list (struct cb_replace_list *list); +static void set_print_replace_list (struct cb_replace_list *); static void get_new_listing_file (void); +static struct cb_text_list *pp_text_list_add (struct cb_text_list *, + const char *, const size_t); + %} WORD [_0-9A-Z\x80-\xFF-]+ @@ -1162,9 +1165,6 @@ int ppopen (const char *name, struct cb_replace_list *replacing_list) { struct copy_info *current_copy_info; -#if 0 - char *s; -#endif char *dname; cb_tree x = NULL; @@ -1235,6 +1235,11 @@ ppopen (const char *name, struct cb_replace_list *replacing_list) cb_current_file->name = cobc_strdup (name); } + /* Add to dependency list */ + if (cb_depend_file) { + cb_depend_list = pp_text_list_add (cb_depend_list, name, strlen (name)); + } + /* Preserve the current buffer */ current_copy_info = cobc_malloc (sizeof (struct copy_info)); current_copy_info->file = cb_source_file; @@ -1272,9 +1277,13 @@ ppopen (const char *name, struct cb_replace_list *replacing_list) dname = cobc_strdup (name); current_copy_info->dname = dname; #if 0 /* Simon: better adjust the output where needed */ - for (s = dname; *s; ++s) { - if (*s == '\\') { - *s = '/'; + { + char *s = dname; + while (*s) { + if (*s == '\\') { + *s = '/'; + } + s++; } } #endif diff --git a/cobc/reserved.c b/cobc/reserved.c index db95ab8d3..b51d65389 100644 --- a/cobc/reserved.c +++ b/cobc/reserved.c @@ -3012,8 +3012,8 @@ static struct cobc_reserved default_reserved_words[] = { { "UPPER", 0, 1, UPPER, /* Extension */ 0, CB_CS_ACCEPT }, - { "USAGE", 0, 0, USAGE, /* 2002 */ - 0, 0 + { "USAGE", 1, 0, USAGE, /* 2002 */ + CB_CS_USAGE, 0 }, { "USE", 0, 0, USE, /* 2002 */ 0, 0 @@ -3040,7 +3040,7 @@ static struct cobc_reserved default_reserved_words[] = { 0, CB_CS_ALPHABET }, { "UTF-8", 0, 1, UTF_8, /* 2002 (C/S) */ - 0, CB_CS_ALPHABET + 0, CB_CS_ALPHABET | CB_CS_USAGE }, { "V", 0, 1, V, /* Extension */ 0, CB_CS_RECORDING @@ -3123,6 +3123,11 @@ static struct cobc_reserved default_reserved_words[] = { { "WIDTH-IN-CELLS", 0, 1, WIDTH_IN_CELLS, /* ACU extension */ 0, CB_CS_GRAPHICAL_CONTROL | CB_CS_INQUIRE_MODIFY }, +#if 0 /* deactivated for now, as stdcall prototypes have several pending issues */ + { "WINAPI", 0, 1, WINAPI, /* Extension: implicit defined CALL-CONVENTION */ + 0, CB_CS_CALL | CB_CS_OPTIONS + }, +#endif { "WINDOW", 0, 0, WINDOW, /* ACU extension */ 0, 0 }, diff --git a/cobc/scanner.l b/cobc/scanner.l index 20ce7c27b..3386f4075 100644 --- a/cobc/scanner.l +++ b/cobc/scanner.l @@ -436,6 +436,21 @@ NX"\""[^""\n]*"\"" { RETURN_TOK (scan_x (yytext + 3, "NX")); } +U[''""] { + /* N national string literal */ + cobc_force_literal = 0; + /* TODO: utf8 string - needs different handling */ + read_literal (yytext [1], "U"); + RETURN_TOK (LITERAL); +} + +UX"\'"[^''\n]*"\'" | +UX"\""[^""\n]*"\"" { + /* UX string literal */ + cobc_force_literal = 0; + RETURN_TOK (scan_x (yytext + 3, "UX")); +} + Z"\'"[^''\n]*"\'" | Z"\""[^""\n]*"\"" { /* Z string literal */ @@ -1426,6 +1441,9 @@ read_literal (const char mark, const char *type) plex_buff[i] = 0; if (type[0] != 'N') { yylval = cb_build_alphanumeric_literal (plex_buff, i); + if (type[0] == 'U') { + CB_UNFINISHED (_("UTF-8 literal")); + } } else { /* poor-man's conversion iso-8859 -> utf-16 */ /* "!a0" = x'21613000' -> nx'00210061003000' */ @@ -1498,7 +1516,7 @@ scan_x (const char *text, const char *type) plex_buff = cobc_malloc (plex_size); } memcpy (plex_buff, text, curr_len); - if (type[0] == 'X') { + if (type[0] == 'X' || type [0] == 'U') { result_len = curr_len / 2; /* characters, two half-bytes (hex) = 1 byte */ } else if (type[0] == 'B') { result_len = curr_len * 4; /* boolean characters B -> 1110 */ @@ -1518,7 +1536,7 @@ scan_x (const char *text, const char *type) characters but that leads to not verified data, which is more important as the compilation will error-exit in any case */ } - } else { + } 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); @@ -1610,6 +1628,7 @@ scan_x (const char *text, const char *type) } error_literal (type, plex_buff, literal_error++); } + /* TODO: for type U needs additional checks */ if (type[0] != 'N') { yylval = cb_build_alphanumeric_literal (plex_buff, (size_t)(dst - plex_buff)); } else { diff --git a/cobc/tree.c b/cobc/tree.c index 842a6bfb2..ac8dbe282 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -59,6 +59,7 @@ #define PIC_ALPHANUMERIC_EDITED (PIC_ALPHANUMERIC | PIC_EDITED) #define PIC_NUMERIC_EDITED (PIC_NUMERIC | PIC_EDITED) #define PIC_FLOATING_EDITED (PIC_NUMERIC | PIC_NUMERIC_FLOATING | PIC_EDITED) +#define PIC_UTF8 (PIC_ALPHANUMERIC) /* TODO: handle separately */ #define PIC_NATIONAL_EDITED (PIC_NATIONAL | PIC_EDITED) /* Local variables */ @@ -2858,7 +2859,7 @@ cb_concat_literals (const cb_tree x1, const cb_tree x2) && (x1->category != CB_CATEGORY_NATIONAL) && (x1->category != CB_CATEGORY_BOOLEAN)) { cb_error_x (x1, - _("only alphanumeric, national or boolean literals may be concatenated")); + _("only alphanumeric, utf-8, national or boolean literals may be concatenated")); return cb_error_node; } @@ -3003,14 +3004,14 @@ find_floating_insertion_str (const cob_pic_symbol *str, /* Number of character types in picture strings */ /* - The 25 character types are: - B , . + + + CR cs cs Z Z + + cs cs 9 A L S V P P 1 N E + The 26 character types are: + B , . + + + CR cs cs Z Z + + cs cs 9 A L S V P P 1 U N E 0 - - DB * * - - X / Duplicates indicate floating/non-floating insertion symbols and/or left/right of decimal point positon. */ -#define CB_PIC_CHAR_TYPES 25 +#define CB_PIC_CHAR_TYPES 26 #define CB_FIRST_NON_P_DIGIT_CHAR_TYPE 9 #define CB_LAST_NON_P_DIGIT_CHAR_TYPE 15 #define CB_PIC_S_CHAR_TYPE 18 @@ -3106,12 +3107,15 @@ char_to_precedence_idx (const cob_pic_symbol *str, case '1': return 22; - case 'N': + case 'U': return 23; - case 'E': + case 'N': return 24; + case 'E': + return 25; + default: if (current_sym->symbol == current_program->currency_symbol) { if (!(first_floating_sym <= current_sym @@ -3200,8 +3204,10 @@ get_char_type_description (const int idx) case 22: return "1"; case 23: - return "N"; + return "U"; case 24: + return "N"; + case 25: return "E"; default: return NULL; @@ -3237,35 +3243,36 @@ valid_char_order (const cob_pic_symbol *str, const int s_char_seen) manual. */ /* - B , . + + + CR cs cs Z Z + + cs cs 9 A L S V P P 1 N E + B , . + + + CR cs cs Z Z + + cs cs 9 A L S V P P 1 U N E 0 - - DB * * - - X / */ - /* B */ { 1, 1, 1, 0, 1, 0, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 0, 1, 0, 1, 0 }, - /* , */ { 1, 1, 1, 0, 1, 0, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 0, 1, 0, 0, 0 }, - /* . */ { 1, 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, - /* + */ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1 }, - /* + */ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, - /* + */ { 1, 1, 1, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 1, 0, 0, 0 }, - /* C */ { 1, 1, 1, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 1, 0, 0, 0 }, - /* $ */ { 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, - /* $ */ { 1, 1, 1, 0, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 1, 1, 1, 0, 0, 0 }, - /* Z */ { 1, 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, - /* Z */ { 1, 1, 1, 0, 1, 0, 0, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0 }, - /* + */ { 1, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, - /* + */ { 1, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0 }, - /* $ */ { 1, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, - /* $ */ { 1, 1, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0 }, - /* 9 */ { 1, 1, 1, 1, 1, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 1, 1, 1, 1, 0, 1, 0, 0, 1 }, - /* X */ { 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0 }, - /* L */ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, - /* S */ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, - /* V */ { 1, 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 0, 1, 0, 1, 0, 0, 0, 0 }, - /* P */ { 1, 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 0, 1, 0, 1, 0, 0, 0, 0 }, - /* P */ { 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 0, 0, 0 }, - /* 1 */ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0 }, - /* N */ { 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0 }, - /* E */ { 1, 1, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, + /* B */ { 1, 1, 1, 0, 1, 0, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 0, 1, 0, 0, 1, 0 }, + /* , */ { 1, 1, 1, 0, 1, 0, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0 }, + /* . */ { 1, 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, + /* + */ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1 }, + /* + */ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, + /* + */ { 1, 1, 1, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0 }, + /* C */ { 1, 1, 1, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0 }, + /* $ */ { 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, + /* $ */ { 1, 1, 1, 0, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0 }, + /* Z */ { 1, 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, + /* Z */ { 1, 1, 1, 0, 1, 0, 0, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0 }, + /* + */ { 1, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, + /* + */ { 1, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0 }, + /* $ */ { 1, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, + /* $ */ { 1, 1, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0 }, + /* 9 */ { 1, 1, 1, 1, 1, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 1, 1, 1, 1, 0, 1, 0, 0, 0, 1 }, + /* X */ { 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0 }, + /* L */ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, + /* S */ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, + /* V */ { 1, 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0 }, + /* P */ { 1, 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0 }, + /* P */ { 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 0, 0, 0, 0 }, + /* 1 */ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0 }, + /* U */ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0 }, + /* N */ { 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0 }, + /* E */ { 1, 1, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, }; int error_emitted[CB_PIC_CHAR_TYPES][CB_PIC_CHAR_TYPES] = {{ 0 }}; int chars_seen[CB_PIC_CHAR_TYPES] = { 0 }; @@ -3593,12 +3600,12 @@ cb_build_picture (const char *str) case 'X': case 'A': if (paren_num + delta > INT_MAX) { - paren_num = INT_MAX - delta; + paren_num = (cob_s64_t)INT_MAX - delta; } break; case 'N': if (paren_num * 2 + delta > INT_MAX) { - paren_num = (INT_MAX - delta) / 2; + paren_num = ((cob_s64_t)INT_MAX - delta) / 2; } break; default: @@ -3637,6 +3644,16 @@ cb_build_picture (const char *str) x_digits += n; break; + case 'U': + /* this is only a hack and wrong, + adding UTF-8 type woll need a separate + PIC, but this will need handling in both + the compiler and the runtime, so fake as + ALPHANUMERIC for now */ + category |= PIC_UTF8; + x_digits += n * 4; + break; + case 'N': if (!(category & PIC_NATIONAL)) { category |= PIC_NATIONAL; @@ -3854,6 +3871,9 @@ cb_build_picture (const char *str) if (c == 'N') { size += n * (COB_NATIONAL_SIZE - 1); } + if (c == 'U') { + size += n * (4 - 1); + } /* Store in the buffer */ pic_buff[idx].symbol = c; @@ -3874,7 +3894,7 @@ cb_build_picture (const char *str) error_detected = 1; } if (digits == 0 && x_digits == 0) { - cb_error (_("PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; " + cb_error (_("PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; " "or at least two of the set +, - and the currency symbol")); error_detected = 1; } @@ -7299,7 +7319,7 @@ get_category_from_arguments (const struct cb_intrinsic_table *cbp, cb_tree args, if (result != CB_CATEGORY_NATIONAL) { cb_error (_("FUNCTION %s has invalid argument"), cbp->name); - cb_error (_("either all arguments or none should be if type %s"), "NATIONAL"); + cb_error (_("either all arguments or none should be of type %s"), "NATIONAL"); return cbp->category; } } else if (result != CB_CATEGORY_ALPHANUMERIC) { @@ -7593,10 +7613,13 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, if (cbp->intr_enum != CB_INTR_BYTE_LENGTH) { /* CHECKME: why don't we just check the category? Maybe needs to enforce field validation (see cb_build_length) */ - if ( fld->pic - && (fld->pic->category == CB_CATEGORY_NATIONAL - || fld->pic->category == CB_CATEGORY_NATIONAL_EDITED)) { - len /= COB_NATIONAL_SIZE; + if (fld->pic) { + if (fld->pic->category == CB_CATEGORY_NATIONAL + || fld->pic->category == CB_CATEGORY_NATIONAL_EDITED) { + len /= COB_NATIONAL_SIZE; + } else if (fld->pic->orig && fld->pic->orig[0] == 'U') { + len /= 4; + } } } sprintf (buff, "%d", len); diff --git a/cobc/tree.h b/cobc/tree.h index 55278955d..61c3a53f1 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -2540,9 +2540,9 @@ extern void cb_emit_return (cb_tree, cb_tree); extern void cb_emit_rollback (void); -extern void cb_emit_search (cb_tree, cb_tree, +extern cb_tree cb_emit_search (cb_tree, cb_tree, cb_tree, cb_tree); -extern void cb_emit_search_all (cb_tree, cb_tree, +extern cb_tree cb_emit_search_all (cb_tree, cb_tree, cb_tree, cb_tree); extern void cb_emit_setenv (cb_tree, cb_tree); @@ -2641,7 +2641,7 @@ extern void cb_check_definition_matches_prototype (struct cb_program *); extern void ylex_clear_all (void); extern void ylex_call_destroy (void); -/* cobc.c */ +/* cobc.c, help.c */ #ifndef COB_EXTERNAL_XREF #define COB_INTERNAL_XREF #endif diff --git a/cobc/typeck.c b/cobc/typeck.c index d147d211a..8fc2c99b5 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -75,11 +75,6 @@ struct expr_node { #define dpush(x) CB_ADD_TO_CHAIN (x, decimal_stack) -#define cb_emit(x) \ - current_statement->body = cb_list_add (current_statement->body, x) -#define cb_emit_list(l) \ - current_statement->body = cb_list_append (current_statement->body, l) - /* Global variables */ cb_tree cb_debug_item; @@ -1225,6 +1220,20 @@ cb_check_integer_value (cb_tree x) return cb_error_node; } +static COB_INLINE COB_A_INLINE cb_tree +cb_emit (cb_tree x) +{ + current_statement->body = cb_list_add (current_statement->body, x); + return x; +} + +static COB_INLINE COB_A_INLINE cb_tree +cb_emit_list (cb_tree l) +{ + current_statement->body = cb_list_append (current_statement->body, l); + return l; +} + static void cb_emit_incompat_data_checks (cb_tree x) { @@ -2753,7 +2762,6 @@ cb_build_identifier (cb_tree x, const int subchk) } /* Reference modification check */ - pseudosize = f->size; #if 0 /* CHECKME: if active, then one test fails (field), if not another (group)... it seems both are different checks, do we need a flag? */ if (cb_reference_bounds_check == CB_WARNING @@ -2765,7 +2773,11 @@ cb_build_identifier (cb_tree x, const int subchk) } #endif if (f->usage == CB_USAGE_NATIONAL ) { - pseudosize = pseudosize / 2; + pseudosize = f->size / 2; + } else if (f->pic && f->pic->orig && f->pic->orig[0] == 'U') { + pseudosize = f->size / 4; + } else { + pseudosize = f->size; } if (r->offset) { /* Compile-time check */ @@ -4356,7 +4368,8 @@ validate_alphabet (cb_tree alphabet) if (count == 256) { ap->high_val_char = lastval; } else if (values[255] != -1) { - for (n = 254; n >= 0; n--) { + ap->high_val_char = 0; + for (n = 254; n > 0; n--) { if (values[n] == -1) { ap->high_val_char = n; break; @@ -5404,8 +5417,10 @@ cb_validate_labels (struct cb_program *prog) /* check for warning options "house-rules" relevant for later optimizations */ if (label->flag_section) { - cb_warning_x (cb_warn_goto_section, x, - "GO TO SECTION '%s'", label->name); + if (label != current_section) { + cb_warning_x (cb_warn_goto_section, x, + "GO TO SECTION '%s'", label->name); + } } else if (label->section != current_section) { char qualified_name[COB_MAX_WORDLEN * 2 + 4 + 1]; cb_warning_x (cb_warn_goto_different_section, x, @@ -10868,7 +10883,7 @@ cb_check_overlapping (struct cb_field *src_f, struct cb_field *dst_f, /* Check for same parent field */ #ifdef _MSC_VER #pragma warning(push) -#pragma warning(disable: 6011) // cb_field_founder always returns a valid pointer +#pragma warning(disable: 6011) /* cb_field_founder always returns a valid pointer */ #endif ff1 = cb_field_founder (src_f); ff2 = cb_field_founder (dst_f); @@ -13103,7 +13118,7 @@ error_if_invalid_file_from_clause_literal (cb_tree literal) if (!(category == CB_CATEGORY_ALPHANUMERIC || category == CB_CATEGORY_NATIONAL || category == CB_CATEGORY_BOOLEAN)) { - cb_error_x (literal, _("literal in FROM clause must be alphanumeric, national or boolean")); + cb_error_x (literal, _("literal in FROM clause must be alphanumeric, utf-8, national or boolean")); return 1; } @@ -13417,45 +13432,50 @@ cb_search_ready (const cb_tree table) } } -void +cb_tree cb_emit_search (cb_tree table, cb_tree varying, cb_tree at_end, cb_tree whens) { + cb_tree search; + if (cb_validate_one (table) || cb_validate_one (varying) || whens == cb_error_node) { - return; + return NULL; } whens = cb_list_reverse (whens); if (at_end) { cb_check_needs_break (CB_PAIR_Y (at_end)); } - cb_emit (cb_build_search (0, table, varying, at_end, whens)); + search = cb_emit (cb_build_search (0, table, varying, at_end, whens)); cb_search_ready (NULL); + return search; } -void +cb_tree cb_emit_search_all (cb_tree table, cb_tree at_end, cb_tree when, cb_tree stmts) { cb_tree x; cb_tree stmt_lis; + cb_tree search; if (cb_validate_one (table) || when == cb_error_node) { - return; + return NULL; } x = cb_build_search_all (table, when); if (!x) { - return; + return NULL; } stmt_lis = cb_check_needs_break (stmts); 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, STMT_WHEN))); + x = cb_build_if (x, stmt_lis, NULL, STMT_WHEN); + search = cb_emit (cb_build_search (1, table, NULL, at_end, x)); cb_search_ready (NULL); + return search; } /* SET statement */ @@ -14857,8 +14877,9 @@ error_if_not_alnum_or_national (cb_tree ref, const char *name) { if (! (CB_TREE_CATEGORY (ref) == CB_CATEGORY_ALPHANUMERIC || CB_TREE_CATEGORY (ref) == CB_CATEGORY_NATIONAL)) { + /* note: at least with Enterprise COBOL utf8 is explicit forbidden here */ cb_error_x (ref, _("%s must be alphanumeric or national"), name); - return 1; + return 1; } else { return 0; } diff --git a/config/runtime.cfg b/config/runtime.cfg index 077281959..6874bec39 100644 --- a/config/runtime.cfg +++ b/config/runtime.cfg @@ -276,7 +276,11 @@ # run-time but needs more time to resolve CALLs (both to # active and not-active programs) # Alias: default_cancel_mode, LOGICAL_CANCELS (0 = yes) -# Type: boolean (evaluated for true only) +# Type: TRUE/YES/1 unload module on CANCEL +# FALSE/NO/0 unload module on STOP RUN only +# NEVER never unload module, only useful for profilers +# and tracing tools that do a post-mortem lookup +# of function address # Default: false # Example: PHYSICAL_CANCEL TRUE diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 70a953966..0fc92f53c 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,9 +1,28 @@ +2024-08-28 David Declerck + + * intrinsics.c (cob_intr_random), move.c (cob_move_display_to_packed): + make casts with loss of data explicit using masking to silence + the MSVC runtime error checker + +2024-08-22 David Declerck + + * common.c (DllMain) [_MSC_VER]: added calls to _CrtSetReportMode + to disable Windows error popups and redirect them to stderr + 2024-08-04 David Declerck Adjustments to merge 2022-12-21: * common.h (cob_symbol): added an is_internal flag * common.c (cob_dump_symbols): skip symbols marked is_internal in dump + * call.c (cache_preload, cob_resolve_internal): runtime warning if + (pre)loading from existing path does not work + * (cache_preload): runtime warning if preloading from existing path + does not work + * call.c (cob_try_preload): runtime warning if preloading of + requested module does not work + * (cob_resolve_internal): runtime warning if loading module from + existing path or resolving requested entry point does not work 2024-07-25 David Declerck @@ -11,7 +30,7 @@ adjusted to use cob_open_mode where possible while merging 2022-10-04 -2023-07-12 Simon Sobisch +2024-07-12 Simon Sobisch * numeric.c (cob_decimal_set_binar): C89 fix @@ -74,12 +93,34 @@ * screenio.c: renamed max_pairs_available as this is defined on HPUX * common.c (check_current_date): fixed bad snprintf size +2022-12-31 Simon Sobisch + + * numeric.c (cob_cmp_uint, cob_cmp_llint): prevent some overflows + +2022-12-29 Simon Sobisch + + * fileio.c [!COB_EXPERIMENTAL]: disable "new" status 0P via preprocessor + to inspect later for either include as COB_LS_VALIDATE=PRINT or drop + +2022-12-13 David Declerck + + * conv.c: file moved from cobc to libcob + * common.h: declare the new API for collating sequences + 2022-12-13 Simon Sobisch * strings.c (inspect_find_data): added missing area check bug #865 * strings.c (inspect_common_no_replace, inspect_common_replacing, is_marked): minor refactoring for optimization hints +2022-12-09 Simon Sobisch + + * common.c (get_config_val, set_config_val, translate_boolean_to_int): + allow "boolean" values to be set to a third value via enum, + new enum "never" used for COB_PHYSICAL_CANCEL (and prepared: "not_set"), + to prevent unloading, which is useful for analysis tools like callgrind + or perf to keep all symbols until end of the COBOL process + 2022-12-08 Ron Norman * call.c: For AIX, use RTLD_MEMBER to dlopen shared code from archive @@ -187,7 +228,29 @@ by checking sign/zero and reduced number of decimal shifting dynamic allocation * move.c (store_common_region): minor optimization - * move.c: + * move.c (cob_move_display_to_edited): several optimizations, the + biggest one stays open, needing adjusted function call from cobc + +2022-11-10 Simon Sobisch + + * coblocal.h: include common.h (for cob_ types) and stdio.h (for FILE) + * common.h: include stddef.h for size_t + * fileo.c (save_status): rewritten to care for any sucessful completion + (status 0x) instead of only on status 00 to not set an exception and + to sync if COB_SYNC is active + +2022-11-09 Simon Sobisch + + * common.c (cob_hard_failure, cob_hard_failure_internal), + call.c (cob_exit_call): skip unloading of modules for COB_CORE_ON_ERROR=2 + to keep symbols in coredumps using cob_physical_cancel=-1 internally + * call.c (close_and_free_module_list): extracted from cob_exit_call + * fileio.c (lineseq_read): use the locale setup for printable check in + sequential data verification instead of libcob's internal one + * fileio.c: for line sequential data verification only call isprint when + cob_ls_validate > 1 (not configurable), use new macro IS_NOT_PRINTABLE + for this check and execute it on both read and (re)write, resulting in + status 0P now, fixed call of isprint on EBCDIC machines 2022-11-04 Simon Sobisch @@ -2237,7 +2300,7 @@ 2019-12-27 Ron Norman - * common.h: Added cob_file.curkey to record recent file index + * common.h: Added cob_file.curkey to record recent file index * fileio.c: cob_read_next will check for records returned with a key that has all SUPPRESS character and skip the record. This will handle old VBISAM, ODBC & OCI @@ -2282,9 +2345,9 @@ 2019-11-18 Ron Norman - * common.h,fileio.c,fextfh.c,fbdb.c: Updates to support - SET ... TO ADDRESS OF FH--FCD OF file - SET ... TO ADDRESS OF FH--KEYDEF OF file + * common.h, fileio.c (fextfh.c, fbdb.c): Updates to support + SET ... TO ADDRESS OF FH--FCD OF file and + SET ... TO ADDRESS OF FH--KEYDEF OF file 2019-11-14 Ron Norman @@ -2294,10 +2357,10 @@ 2019-11-14 Ron Norman - * coblocal.h: + * coblocal.h: * common.c: Add runtime options COB_FILE_DICTIONARY & COB_FILE_DICTIONARY_PATH - * fileio.h: + * fileio.h: * fileio.c: Clean up of code to write/read file format information default is 'asgname.dd' Support for COB_FILE_DICTIONARY_PATH is not implemented @@ -2322,7 +2385,7 @@ 2019-10-26 Ron Norman * fileio.c: work on handling file definition parameters in IO_filename - RELATIVE file at end-of-file now returns status 10 + RELATIVE file at end-of-file now returns status 10 when ACCESS SEQUENTIAL, otherwise status 23 2019-10-25 Ron Norman @@ -6643,6 +6706,10 @@ * call.c (dynamic_reloading): Renamed from cob_dynamic_reloading. (cob_init_call): Initialize 'dynamic_reloading'. +2002-05-23 Keisuke Nishida + + * call.c, common.c, move.c, Makefile.am: gettextized + Copyright 2002-2024 Free Software Foundation, Inc. diff --git a/libcob/Makefile.am b/libcob/Makefile.am index 272481a4c..22af1a47a 100644 --- a/libcob/Makefile.am +++ b/libcob/Makefile.am @@ -37,7 +37,7 @@ AM_LDFLAGS = $(COB_FIX_LIB) $(COB_FIX_LIBTOOL) -no-undefined libcob_la_SOURCES = common.c move.c numeric.c strings.c \ fileio.c fsqlxfd.c fextfh.c focextfh.c mlio.c \ call.c cobcapi.c intrinsic.c termio.c screenio.c reportio.c cobgetopt.c \ - coblocal.h cobinternal.h system.def sysdefines.h fileio.h + coblocal.h cconv.c cobinternal.h system.def sysdefines.h fileio.h # note: currently misses libsupport... libcob_la_LIBADD = $(LIBCOB_LIBS) $(CODE_COVERAGE_LIBS) diff --git a/libcob/call.c b/libcob/call.c index 61fdf3d51..2048e8f98 100644 --- a/libcob/call.c +++ b/libcob/call.c @@ -48,6 +48,11 @@ FILE *fmemopen (void *buf, size_t size, const char *mode); #define HAVE_FMEMOPEN 1 #endif +/* Force symbol exports */ +#define COB_LIB_EXPIMP +#include "common.h" +#include "coblocal.h" + /* NOTE - The following variable should be uncommented when it is known that dlopen(NULL) is borked. This is known to be true for some PA-RISC HP-UX 11.11 systems. @@ -89,12 +94,12 @@ lt_dlsym (HMODULE hmod, const char *p) #define lt_dlexit() #define lt_dlhandle HMODULE -#if 0 /* RXWRXW - dlerror */ +#if 1 /* RXWRXW - dlerror */ static char errbuf[64]; static char * lt_dlerror (void) { - sprintf(errbuf, _("LoadLibrary/GetProcAddress error %d"), (int)GetLastError()); + sprintf (errbuf, _("LoadLibrary/GetProcAddress error %d"), (int)GetLastError()); return errbuf; } #endif @@ -125,11 +130,6 @@ lt_dlerror (void) #include "sysdefines.h" -/* Force symbol exports */ -#define COB_LIB_EXPIMP -#include "common.h" -#include "coblocal.h" - #define COB_MAX_COBCALL_PARMS 16 #define CALL_BUFF_SIZE 256U #define CALL_BUFF_MAX (CALL_BUFF_SIZE - 1U) @@ -478,12 +478,14 @@ do_cancel_module (struct call_hash *p, struct call_hash **base_hash, return; } - lt_dlclose (p->handle); + if (cobsetptr->cob_physical_cancel != -1) { + lt_dlclose (p->handle); - dynptr = base_dynload_ptr; - for (; dynptr; dynptr = dynptr->next) { - if (dynptr->handle == p->handle) { - dynptr->handle = NULL; + dynptr = base_dynload_ptr; + for (; dynptr; dynptr = dynptr->next) { + if (dynptr->handle == p->handle) { + dynptr->handle = NULL; + } } } @@ -620,11 +622,14 @@ cache_preload (const char *path) } if (access (path, R_OK) != 0) { + /* note: not reasonable to warn here as we test for multiple paths that way */ return 0; } libhandle = lt_dlopen (path); if (!libhandle) { + cob_runtime_warning ( + _("preloading from existing path '%s' failed; %s"), path, lt_dlerror()); return 0; } @@ -925,6 +930,7 @@ cob_resolve_internal (const char *name, const char *dirent, set_resolve_error (module_type); return NULL; } + lt_dlerror (); /* clear last error conditions */ handle = lt_dlopen (call_filename_buff); if (handle != NULL) { /* Candidate for future calls */ @@ -940,6 +946,10 @@ cob_resolve_internal (const char *name, const char *dirent, snprintf (resolve_error_buff, (size_t)CALL_BUFF_MAX, "entry point '%s' not found", (const char *)s); set_resolve_error (module_type); + /* lt_dlerror will now give either the message from lt_dlopen or lt_dlym */ + cob_runtime_warning ( + _("loading from existing path '%s' failed; %s"), + call_filename_buff, lt_dlerror ()); return NULL; } for (i = 0; i < resolve_size; ++i) { @@ -953,6 +963,7 @@ cob_resolve_internal (const char *name, const char *dirent, } call_filename_buff[COB_NORMAL_MAX] = 0; if (access (call_filename_buff, R_OK) == 0) { + lt_dlerror (); /* clear last error conditions */ handle = lt_dlopen (call_filename_buff); if (handle != NULL) { /* Candidate for future calls */ @@ -968,6 +979,10 @@ cob_resolve_internal (const char *name, const char *dirent, snprintf (resolve_error_buff, (size_t)CALL_BUFF_MAX, "entry point '%s' not found", (const char *)s); set_resolve_error (module_type); + /* lt_dlerror will now give either the message from lt_dlopen or lt_dlym */ + cob_runtime_warning ( + _("loading from existing path '%s' failed; %s"), + call_filename_buff, lt_dlerror ()); return NULL; } } @@ -1768,12 +1783,29 @@ cob_longjmp (struct cobjmp_buf *jbuf) } #endif +static void +close_and_free_module_list (struct struct_handle ** module_list_ptr) +{ + struct struct_handle *h = *module_list_ptr; + + while (h) { + struct struct_handle *j = h; + if (h->path) { + cob_free ((void*)h->path); + } + if (h->handle + && cobsetptr->cob_physical_cancel != -1) { + lt_dlclose (h->handle); + } + h = h->next; + cob_free (j); + } + *module_list_ptr = NULL; +} + void cob_exit_call (void) { - struct struct_handle *h; - struct struct_handle *j; - if (call_filename_buff) { cob_free (call_filename_buff); call_filename_buff = NULL; @@ -1819,34 +1851,13 @@ cob_exit_call (void) } call_table = NULL; } - - for (h = base_preload_ptr; h;) { - j = h; - if (h->path) { - cob_free ((void *)h->path); - } - if (h->handle) { - lt_dlclose (h->handle); - } - h = h->next; - cob_free (j); - } - base_preload_ptr = NULL; - for (h = base_dynload_ptr; h;) { - j = h; - if (h->path) { - cob_free ((void *)h->path); - } - if (h->handle) { - lt_dlclose (h->handle); - } - h = h->next; - cob_free (j); - } - base_dynload_ptr = NULL; + close_and_free_module_list (&base_preload_ptr); + close_and_free_module_list (&base_dynload_ptr); #if !defined(_WIN32) && !defined(USE_LIBDL) - lt_dlexit (); + if (cobsetptr->cob_physical_cancel != -1) { + lt_dlexit (); + } #if 0 /* RXWRXW - ltdl leak */ #ifndef COB_BORKED_DLOPEN /* Weird - ltdl leaks mainhandle - This appears to work but .. */ @@ -1889,7 +1900,12 @@ size_t cob_try_preload (const char* module_name) } } /* If not found, try just using the name as-is */ - return cache_preload (module_name); + ret = cache_preload (module_name); + + if (ret == 0) { + cob_runtime_warning (_("preloading of '%s' failed"), module_name); + } + return ret; #endif } diff --git a/cobc/cconv.c b/libcob/cconv.c similarity index 80% rename from cobc/cconv.c rename to libcob/cconv.c index 04048424d..a41bbb68d 100644 --- a/cobc/cconv.c +++ b/libcob/cconv.c @@ -18,10 +18,16 @@ along with GnuCOBOL. If not, see . */ -#include /* for FILE, used in cobc.h */ +#include "config.h" -#include "cobc.h" /* for cb_strcasecmp */ -#include "cconv.h" +#include +#include +#include + +/* Force symbol exports */ +#define COB_LIB_EXPIMP +#include "common.h" +#include "coblocal.h" /* TODO: Maybe use iconv or gconv before extending to other character sets while using standard naming scheme? Note, however, that specifications for GCOS7 @@ -115,7 +121,11 @@ const cob_u8_t cob_ascii_ebcdic[256] = { }; -/* EBCDIC GCOS7 8-bit to ASCII conversion table. */ +/* EBCDIC GCOS7 8-bit to ASCII conversion table: + + https://support.bull.com/ols/product/system/gcos7/gcos7-com/g7-dps7000/doc-com/docf/g/47X257TN27-oct2009/47A205UL04.pdf, + p627. Note one page is missing from this documentation, but the full table + can be found in the French version. */ const cob_u8_t cob_gcos7ebcdic_ascii[256] = { 0x00, 0x01, 0x02, 0x03, 0x9C, 0x09, 0x86, 0x7F, 0x97, 0x8D, 0x8E, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F, @@ -227,6 +237,42 @@ const cob_u8_t cob_gcos7ebcdic_ebcdic[256] = { 0xF8, 0xF9, 0xB3, 0xFB, 0xB9, 0xEA, 0xBB, 0xFF }; +/* "default" (?) EBCDIC to ASCII conversion table (restricted) */ +const cob_u8_t cob_ebcdic_ascii_alt[256] = { + 0x00, 0x01, 0x02, 0x03, 0x09, 0x7F, 0x0B, 0x0C, + 0x0D, 0x0E, 0x0F, 0x10, 0x11, 0x12, 0x13, 0x08, + 0x18, 0x19, 0x1C, 0x1D, 0x1E, 0x1F, 0x0A, 0x17, + 0x1B, 0x05, 0x06, 0x07, 0x16, 0x04, 0x14, 0x15, + 0x1A, 0x20, 0x2E, 0x3C, 0x28, 0x2B, 0x26, 0x21, + 0x24, 0x2A, 0x29, 0x3B, 0x2D, 0x2F, 0x7C, 0x2C, + 0x25, 0x5F, 0x3E, 0x3F, 0x60, 0x3A, 0x23, 0x40, + 0x27, 0x3D, 0x22, 0x61, 0x62, 0x63, 0x64, 0x65, + 0x66, 0x67, 0x68, 0x69, 0x6A, 0x6B, 0x6C, 0x6D, + 0x6E, 0x6F, 0x70, 0x71, 0x72, 0x7E, 0x73, 0x74, + 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x7B, 0x41, + 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, + 0x7D, 0x4A, 0x4B, 0x4C, 0x4D, 0x4E, 0x4F, 0x50, + 0x51, 0x52, 0x5C, 0x53, 0x54, 0x55, 0x56, 0x57, + 0x58, 0x59, 0x5A, 0x30, 0x31, 0x32, 0x33, 0x34, + 0x35, 0x36, 0x37, 0x38, 0x39, 0x5B, 0x5D, 0x5E, + 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, + 0x88, 0x89, 0x8A, 0x8B, 0x8C, 0x8D, 0x8E, 0x8F, + 0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, + 0x98, 0x99, 0x9A, 0x9B, 0x9C, 0x9D, 0x9E, 0x9F, + 0xA0, 0xA1, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7, + 0xA8, 0xA9, 0xAA, 0xAB, 0xAC, 0xAD, 0xAE, 0xAF, + 0xB0, 0xB1, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7, + 0xB8, 0xB9, 0xBA, 0xBB, 0xBC, 0xBD, 0xBE, 0xBF, + 0xC0, 0xC1, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7, + 0xC8, 0xC9, 0xCA, 0xCB, 0xCC, 0xCD, 0xCE, 0xCF, + 0xD0, 0xD1, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6, 0xD7, + 0xD8, 0xD9, 0xDA, 0xDB, 0xDC, 0xDD, 0xDE, 0xDF, + 0xE0, 0xE1, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, + 0xE8, 0xE9, 0xEA, 0xEB, 0xEC, 0xED, 0xEE, 0xEF, + 0xF0, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7, + 0xF8, 0xF9, 0xFA, 0xFB, 0xFC, 0xFD, 0xFE, 0xFF +}; + /* ASCII to "default" (?) EBCDIC conversion table (restricted) */ const cob_u8_t cob_ascii_alt_ebcdic[256] = { 0x00, 0x01, 0x02, 0x03, 0x1D, 0x19, 0x1A, 0x1B, @@ -341,21 +387,87 @@ const cob_u8_t cob_ascii_ibmebcdic[256] = { 0x3F, 0x3F, 0x3F, 0x3F, 0x3F, 0x3F, 0x3F, 0x3F }; -enum ebcdic_table cb_ebcdic_table = CB_EBCDIC_DEFAULT; +const char * +cob_get_collation_name (int col_id) +{ + switch (col_id) { + case CB_EBCDIC_DEFAULT: + return "DEFAULT"; + case CB_EBCDIC_RESTRICTED_GC: + return "RESTRICTED-GC"; + case CB_EBCDIC_IBM: + return "IBM"; + case CB_EBCDIC_GCOS: + return "GCOS"; + default: + return NULL; + } +} -/* Decipher character conversion table names */ -int cobc_deciph_ebcdic_table_name (const char *name) +static int +cob_get_collation_by_id (int col_id, + const cob_u8_t **p_ebcdic_as_ascii, + const cob_u8_t **p_ascii_as_ebcdic) { - if (! cb_strcasecmp (name, "DEFAULT")) { - cb_ebcdic_table = CB_EBCDIC_DEFAULT; - } else if (! cb_strcasecmp (name, "RESTRICTED-GC")) { - cb_ebcdic_table = CB_EBCDIC_RESTRICTED_GC; - } else if (! cb_strcasecmp (name, "IBM")) { - cb_ebcdic_table = CB_EBCDIC_IBM; - } else if (! cb_strcasecmp (name, "GCOS")) { - cb_ebcdic_table = CB_EBCDIC_GCOS; - } else { - return 1; + const cob_u8_t *ebcdic_as_ascii; + const cob_u8_t *ascii_as_ebcdic; + + switch (col_id) { + case CB_EBCDIC_DEFAULT: + ebcdic_as_ascii = cob_ebcdic_ascii; + ascii_as_ebcdic = cob_ascii_ebcdic; + break; + case CB_EBCDIC_RESTRICTED_GC: + ebcdic_as_ascii = cob_ebcdic_ascii_alt; + ascii_as_ebcdic = cob_ascii_alt_ebcdic; + break; + case CB_EBCDIC_IBM: + ebcdic_as_ascii = cob_ibmebcdic_ascii; + ascii_as_ebcdic = cob_ascii_ibmebcdic; + break; + case CB_EBCDIC_GCOS: + ebcdic_as_ascii = cob_gcos7ebcdic_ascii; + ascii_as_ebcdic = cob_ascii_gcos7ebcdic; + break; + default: + return -1; + } + + if (p_ebcdic_as_ascii != NULL) { + *p_ebcdic_as_ascii = ebcdic_as_ascii; + } + + if (p_ascii_as_ebcdic != NULL) { + *p_ascii_as_ebcdic = ascii_as_ebcdic; } + return 0; } + +int +cob_get_collation_by_name (const char *col_name, + const cob_u8_t **p_ebcdic_as_ascii, + const cob_u8_t **p_ascii_as_ebcdic) +{ + enum ebcdic_table col_id; + int res; + + if (!strcmp (col_name, "DEFAULT")) { + col_id = CB_EBCDIC_DEFAULT; + } else if (!strcmp (col_name, "RESTRICTED-GC")) { + col_id = CB_EBCDIC_RESTRICTED_GC; + } else if (!strcmp (col_name, "IBM")) { + col_id = CB_EBCDIC_IBM; + } else if (!strcmp (col_name, "GCOS")) { + col_id = CB_EBCDIC_GCOS; + } else { + return -1; + } + + res = cob_get_collation_by_id (col_id, p_ebcdic_as_ascii, p_ascii_as_ebcdic); + if (res < 0) { + return res; + } + + return col_id; +} diff --git a/libcob/coblocal.h b/libcob/coblocal.h index 71be6fcd8..7fae0f1be 100644 --- a/libcob/coblocal.h +++ b/libcob/coblocal.h @@ -56,6 +56,8 @@ #define N_(s) s #endif +#include "common.h" /* located next to coblocal.h */ +#include #include "cobinternal.h" @@ -496,5 +498,12 @@ cob_max_int (const int x, const int y) return y; } +/* All supported conversions */ +enum ebcdic_table { + CB_EBCDIC_DEFAULT = 0, + CB_EBCDIC_RESTRICTED_GC = 1, + CB_EBCDIC_IBM = 2, + CB_EBCDIC_GCOS = 3, +}; #endif /* COB_LOCAL_H */ diff --git a/libcob/common.c b/libcob/common.c index 8da537498..9e37420e0 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -345,6 +345,8 @@ static const char *setting_group[] = {" hidden setting ", "CALL configuration", "System configuration"}; static struct config_enum lwrupr[] = {{"LOWER", "1"}, {"UPPER", "2"}, {"not set", "0"}, {NULL, NULL}}; +static struct config_enum notset[] = {{"not set", "!"}, {NULL, NULL}}; +static struct config_enum never[] = {{"never", "!"}, {NULL, NULL}}; static struct config_enum beepopts[] = {{"FLASH", "1"}, {"SPEAKER", "2"}, {"FALSE", "9"}, {"BEEP", "0"}, {NULL, NULL}}; static struct config_enum timeopts[] = {{"0", "1000"}, {"1", "100"}, {"2", "10"}, {"3", "1"}, {NULL, NULL}}; static struct config_enum coeopts[] = {{"0", "0"}, {"1", "1"}, {"2", "2"}, {"3", "3"}, {NULL, NULL}}; @@ -401,7 +403,7 @@ static const char *not_set; */ static struct config_tbl gc_conf[] = { {"COB_LOAD_CASE", "load_case", "0", lwrupr, GRP_CALL, ENV_UINT | ENV_ENUMVAL, SETPOS (name_convert)}, - {"COB_PHYSICAL_CANCEL", "physical_cancel", "0", NULL, GRP_CALL, ENV_BOOL, SETPOS (cob_physical_cancel)}, + {"COB_PHYSICAL_CANCEL", "physical_cancel", "0", never, GRP_CALL, ENV_BOOL | ENV_ENUMVAL, SETPOS (cob_physical_cancel)}, {"default_cancel_mode", "default_cancel_mode", NULL, NULL, GRP_HIDE, ENV_BOOL | ENV_NOT, SETPOS (cob_physical_cancel)}, {"LOGICAL_CANCELS", "logical_cancels", NULL, NULL, GRP_HIDE, ENV_BOOL | ENV_NOT, SETPOS (cob_physical_cancel)}, {"COB_LIBRARY_PATH", "library_path", NULL, NULL, GRP_CALL, ENV_PATH, SETPOS (cob_library_path)}, /* default value set in cob_init_call() */ @@ -458,7 +460,7 @@ static struct config_tbl gc_conf[] = { {"STRIP_TRAILING_SPACES","strip_trailing_spaces",NULL,NULL,GRP_HIDE,ENV_BOOL|ENV_NOT,SETPOS(cob_ls_fixed)}, {"COB_LS_SPLIT","ls_split", "1",NULL,GRP_FILE,ENV_BOOL,SETPOS(cob_ls_split)}, {"COB_LS_INSTAB","ls_instab", "false",NULL,GRP_FILE,ENV_BOOL,SETPOS(cob_ls_instab)}, - {"COB_LS_NULLS","ls_nulls", "not set",NULL,GRP_FILE,ENV_BOOL,SETPOS(cob_ls_nulls)}, + {"COB_LS_NULLS","ls_nulls", "not set",notset,GRP_FILE,ENV_BOOL,SETPOS(cob_ls_nulls)}, {"COB_LS_VALIDATE","ls_validate", "1",NULL,GRP_FILE,ENV_BOOL,SETPOS(cob_ls_validate)}, {"COB_SHARE_MODE","share_mode", "none",shareopts,GRP_FILE,ENV_UINT|ENV_ENUM,SETPOS(cob_share_mode)}, {"COB_RETRY_MODE","retry_mode", "none",retryopts,GRP_FILE,ENV_UINT|ENV_ENUM,SETPOS(cob_retry_mode)}, @@ -3207,9 +3209,11 @@ handle_core_on_error () core_on_error = COB_D2I (env_val[0]); } } + /* explicit create a coredump file */ if (core_on_error == 3) { int ret = create_dumpfile (); if (ret) { + /* creation did not work, set to "internally 4" */ if (cob_initialized) { cobsetptr->cob_core_on_error = 4; } @@ -3231,6 +3235,10 @@ cob_hard_failure () { unsigned int core_on_error = handle_core_on_error (); if (core_on_error != 4) { + if (core_on_error == 2 && cob_initialized) { + /* prevent unloading modules */ + cobsetptr->cob_physical_cancel = -1; + } call_exit_handlers_and_terminate (); } exit_code = -1; @@ -3262,6 +3270,10 @@ cob_hard_failure_internal (const char *prefix) fprintf (stderr, "\n"); core_on_error = handle_core_on_error (); if (core_on_error != 4) { + if (core_on_error == 2 && cob_initialized) { + /* prevent unloading modules */ + cobsetptr->cob_physical_cancel = -1; + } call_exit_handlers_and_terminate (); } exit_code = -2; @@ -3343,7 +3355,7 @@ cob_module_global_enter (cob_module **module, cob_global **mglobal, /* Check module pointer */ if (!*module) { - struct cob_alloc_module* mod_ptr; + struct cob_alloc_module *mod_ptr; *module = cob_cache_malloc (sizeof (cob_module)); /* Add to list of all modules activated */ @@ -3351,12 +3363,16 @@ cob_module_global_enter (cob_module **module, cob_global **mglobal, mod_ptr->cob_pointer = *module; mod_ptr->next = cob_module_list; cob_module_list = mod_ptr; - } else if (entry == 0 - && !cobglobptr->cob_call_from_c) { - int k = 0; - cob_module *mod; + } else + if (entry == 0 + && !cobglobptr->cob_call_from_c) { + register int k = 0; + register cob_module *mod; for (mod = COB_MODULE_PTR; mod; mod = mod->next) { if (*module == mod) { + /* CHECKME: can we move this in 4.x to the generated program + to be done _before_ executing cob_module_global_enter using + a _static_ variable ? */ if (cobglobptr->cob_stmt_exception) { /* CALL has ON EXCEPTION so return to caller */ cob_set_exception (COB_EC_PROGRAM_RECURSIVE_CALL); @@ -3366,11 +3382,13 @@ cob_module_global_enter (cob_module **module, cob_global **mglobal, cob_module_err = mod; cob_fatal_error (COB_FERROR_RECURSIVE); } - if (k++ == MAX_MODULE_ITERS) { + /* LCOV_EXCL_START */ + if (k++ == MAX_MODULE_ITERS) { /* prevent endless loop in case of broken list */ /* not translated as highly unexpected */ cob_runtime_warning ("max module iterations exceeded, possible broken chain"); break; } + /* LCOV_EXCL_STOP */ } } @@ -3428,6 +3446,10 @@ cob_module_free (cob_module **module) } cob_module_clean (*module); + + /* TODO: consider storing the last entry and a prev pointer + to optimize for the likely case of "program added last is removed" + instead of checking _all_ previous entries */ prv = NULL; /* Remove from list of all modules activated */ for (ptr = cob_module_list; ptr; ptr = ptr->next) { @@ -4643,7 +4665,7 @@ static set_cob_time_from_localtime (time_t curtime, static time_t last_time = 0; static struct cob_time last_cobtime; - // FIXME: on reseting appropriate locale set last_time_no_sec = 0 + /* FIXME: on reseting appropriate locale set last_time_no_sec = 0 */ if (curtime == last_time) { memcpy (cb_time, &last_cobtime, sizeof (struct cob_time)); return; @@ -7723,7 +7745,8 @@ translate_boolean_to_int (const char *ptr) if (*(ptr + 1) == 0 && isdigit ((unsigned char)*ptr)) { return atoi (ptr); /* 0 or 1 */ } else - if (strcasecmp (ptr, "not set") == 0) { + /* pre-translated boolean "never" - not set" */ + if (strcmp (ptr, "!") == 0) { return -1; } else if (strcasecmp (ptr, "true") == 0 @@ -7771,7 +7794,8 @@ set_config_val (char *value, int pos) } } if ((data_type & ENV_ENUM || data_type & ENV_ENUMVAL) /* Must be one of the 'enum' values */ - && gc_conf[pos].enums[i].match == NULL) { + && gc_conf[pos].enums[i].match == NULL + && (!(data_type & ENV_BOOL))) { conf_runtime_error_value (ptr, pos); fprintf (stderr, _("should be one of the following values: %s"), ""); for (i = 0; gc_conf[pos].enums[i].match != NULL; i++) { @@ -7790,7 +7814,31 @@ set_config_val (char *value, int pos) } } - if ((data_type & ENV_UINT) /* Integer data, unsigned */ + if ((data_type & ENV_BOOL)) { /* Boolean: Yes/No, True/False,... */ + numval = translate_boolean_to_int (ptr); + + if (numval != -1 + && numval != 1 + && numval != 0) { + conf_runtime_error_value (ptr, pos); + conf_runtime_error (1, _("should be one of the following values: %s"), "true, false"); + return 1; + } + if ((data_type & ENV_NOT)) { /* Negate logic for actual setting */ + numval = !numval; + } + set_value (data, data_len, numval); + if ((data_type & ENV_RESETS)) { /* Additional setup needed */ + if (strcmp(gc_conf[pos].env_name, "COB_SET_DEBUG") == 0) { + /* Copy variables from settings (internal) to global structure, each time */ + cobglobptr->cob_debugging_mode = cobsetptr->cob_debugging_mode; + } + } + if (strcmp (gc_conf[pos].env_name, "COB_INSERT_MODE") == 0) { + cob_settings_screenio (); + } + + } else if ((data_type & ENV_UINT) /* Integer data, unsigned */ || (data_type & ENV_SINT) /* Integer data, signed */ || (data_type & ENV_SIZE) ) { /* Size: integer with K, M, G */ char sign = 0; @@ -7799,7 +7847,7 @@ set_config_val (char *value, int pos) || *ptr == '+') { if ((data_type & ENV_SINT) == 0) { conf_runtime_error_value (ptr, pos); - conf_runtime_error (1, _("should be unsigned")); // cob_runtime_warning + conf_runtime_error (1, _("should be unsigned")); /* cob_runtime_warning */ return 1; } sign = *ptr; @@ -7883,30 +7931,6 @@ set_config_val (char *value, int pos) cob_settings_screenio (); } - } else if ((data_type & ENV_BOOL)) { /* Boolean: Yes/No, True/False,... */ - numval = translate_boolean_to_int (ptr); - - if (numval != -1 - && numval != 1 - && numval != 0) { - conf_runtime_error_value (ptr, pos); - conf_runtime_error (1, _("should be one of the following values: %s"), "true, false"); - return 1; - } - if ((data_type & ENV_NOT)) { /* Negate logic for actual setting */ - numval = !numval; - } - set_value (data, data_len, numval); - if ((data_type & ENV_RESETS)) { /* Additional setup needed */ - if (strcmp(gc_conf[pos].env_name, "COB_SET_DEBUG") == 0) { - /* Copy variables from settings (internal) to global structure, each time */ - cobglobptr->cob_debugging_mode = cobsetptr->cob_debugging_mode; - } - } - if (strcmp (gc_conf[pos].env_name, "COB_INSERT_MODE") == 0) { - cob_settings_screenio (); - } - } else if ((data_type & ENV_FILE) || (data_type & ENV_PATH)) { /* Path (environment expanded) to be stored as a string */ memcpy (&str, data, sizeof (char *)); @@ -8009,7 +8033,27 @@ get_config_val (char *value, int pos, char *orgvalue) strcpy (value, _("unknown")); orgvalue[0] = 0; - if (data_type & ENV_UINT) { /* Integer data, unsigned */ + + if ((data_type & ENV_BOOL)) { /* Boolean: Yes/No, True/False,... */ + numval = get_value (data, data_len); + if (numval == -1) { + if (gc_conf[pos].enums == never) { + strcpy (value, "never"); + } else { + strcpy (value, _("not set")); + } + } else { + if ((data_type & ENV_NOT)) { + numval = !numval; + } + if (numval) { + strcpy (value, _("yes")); + } else { + strcpy (value, _("no")); + } + } + + } else if (data_type & ENV_UINT) { /* Integer data, unsigned */ numval = get_value (data, data_len); sprintf (value, CB_FMT_LLU, numval); @@ -8042,21 +8086,6 @@ get_config_val (char *value, int pos, char *orgvalue) sprintf (value, CB_FMT_LLD, numval); } - } else if ((data_type & ENV_BOOL)) { /* Boolean: Yes/No, True/False,... */ - numval = get_value (data, data_len); - if (numval == -1) { - strcpy (value, _("not set")); - } else { - if ((data_type & ENV_NOT)) { - numval = !numval; - } - if (numval) { - strcpy (value, _("yes")); - } else { - strcpy (value, _("no")); - } - } - /* TO-DO: Consolidate copy-and-pasted code! */ } else if (data_type & ENV_STR) { /* String stored as a string */ memcpy (&str, data, sizeof (char *)); @@ -10484,7 +10513,7 @@ cob_stack_trace_internal (FILE *target, int verbose, int count) source_file, source_line); if (mod->frame_ptr) { struct cob_frame_ext *perform_ptr = mod->frame_ptr; - int frame_max = 512; /* from -fstack-size */ + int frame_max = 512; /* max from -fstack-size */ while (frame_max--) { const unsigned int ffile_num = COB_GET_FILE_NUM (perform_ptr->module_stmt); const unsigned int fline = COB_GET_LINE_NUM (perform_ptr->module_stmt); @@ -11291,3 +11320,30 @@ init_statement_list (void) #undef COB_STATEMENT } #endif + +#ifdef _MSC_VER + +#include + +BOOL WINAPI DllMain (HINSTANCE hinstDLL, DWORD fdwReason, LPVOID lpReserved) +{ + COB_UNUSED (hinstDLL); + COB_UNUSED (lpReserved); + + if (fdwReason == DLL_PROCESS_ATTACH) { + /* Programs compiled with MSVC will by default display a popup + window on some errors. In general, we do not want that, + so we disable them, unless explicitly requested. */ + if (!IsDebuggerPresent() && !getenv ("DEBUG_POPUPS_WANTED")) { + _CrtSetReportMode(_CRT_WARN, _CRTDBG_MODE_FILE); + _CrtSetReportFile(_CRT_WARN, _CRTDBG_FILE_STDERR); + _CrtSetReportMode(_CRT_ERROR, _CRTDBG_MODE_FILE); + _CrtSetReportFile(_CRT_ERROR, _CRTDBG_FILE_STDERR); + _CrtSetReportMode(_CRT_ASSERT, _CRTDBG_MODE_FILE); + _CrtSetReportFile(_CRT_ASSERT, _CRTDBG_FILE_STDERR); + } + } + return TRUE; +} + +#endif diff --git a/libcob/common.h b/libcob/common.h index 7ae84641d..9ecb447e5 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -22,6 +22,8 @@ #ifndef COB_COMMON_H #define COB_COMMON_H +#include /* for size_t */ + /* Only define cob_decimal if we have the necessary mpz_t from gmp.h/mpir.h (or can self-define it from mp.h) */ #if !defined (__GMP_H__) @@ -989,7 +991,10 @@ enum cob_open_mode { #define COB_READ_MASK \ (COB_READ_NEXT | COB_READ_PREVIOUS | COB_READ_FIRST | COB_READ_LAST) -/* I-O status */ +/* I-O status - TODO: these should have internal only values; and then + map later to an i-o status "per dialect", inluding alphanumeric 0x + and 9/123 status values, + will be move to fileio.h in 4.x on remove of OC extfh */ #define COB_STATUS_00_SUCCESS 0 #define COB_STATUS_02_SUCCESS_DUPLICATE 2 @@ -997,6 +1002,9 @@ enum cob_open_mode { #define COB_STATUS_05_SUCCESS_OPTIONAL 5 #define COB_STATUS_06_READ_TRUNCATE 6 #define COB_STATUS_07_SUCCESS_NO_UNIT 7 +#ifdef COB_EXPERIMENTAL +#define COB_STATUS_0P_NOT_PRINTABLE 8 +#endif #define COB_STATUS_09_READ_DATA_BAD 9 #define COB_STATUS_10_END_OF_FILE 10 #define COB_STATUS_14_OUT_OF_KEY_RANGE 14 @@ -3016,4 +3024,23 @@ COB_EXPIMP cob_field *cob_intr_bit_to_char (cob_field *); COB_EXPIMP cob_field *cob_intr_hex_of (cob_field*); COB_EXPIMP cob_field *cob_intr_hex_to_char (cob_field*); +/************************/ +/* Functions in cconv.c */ +/************************/ + +/* Return the name corresponding to an internal collation id, + or NULL if such id is unknown. */ + +COB_EXPIMP const char * +cob_get_collation_name (int); + +/* Retrieve the EBCDIC and ASCII collating sequences for the given + collation name, and return its internal id, or -1 if such name + is unknown. The `p_ebcdic_as_ascii' and `p_ascii_as_ebcdic' + arguments may be NULL if one (or both) of the tables is not + needed (you may only care for the return value). */ + +COB_EXPIMP int +cob_get_collation_by_name (const char *, const cob_u8_t **, const cob_u8_t **); + #endif /* COB_COMMON_H */ diff --git a/libcob/fileio.c b/libcob/fileio.c index 57ccb075d..ab27f5169 100644 --- a/libcob/fileio.c +++ b/libcob/fileio.c @@ -41,6 +41,10 @@ #include #endif +#if defined (COB_EXPERIMENTAL) && defined (HAVE_LOCALE_H) +#include +#endif + #ifdef HAVE_SIGNAL_H #include #endif @@ -3345,37 +3349,27 @@ void cob_file_save_status (cob_file *f, cob_field *fnstatus, const int status) { int k, indent = 15; + int skip_exn = 0; + /* TODO: internally let status be an enum (also in internal storage); + and then map here to an i-o status "per dialect", + inluding alphanumeric 0x and 9/123 status values */ file_globptr->cob_error_file = f; if (status == 0) { memset (f->file_status, '0', (size_t)2); - /* EOP is non-fatal therefore 00 status but needs exception */ - if (eop_status == 0) { - file_globptr->cob_exception_code = 0; - } else { -#if 0 /* correct thing to do, but then also needs to have codegen adjusted - --> module-incompatibility --> 4.x */ - cob_set_exception (eop_status); -#else - cob_set_exception (COB_EC_I_O_EOP); +#ifdef COB_EXPERIMENTAL + } else if (status == COB_STATUS_0P_NOT_PRINTABLE) { + memcpy (f->file_status, "0P", (size_t)2); #endif - eop_status = 0; - } - if ((f->file_features & COB_FILE_SYNC)) { - cob_file_sync (f); - } } else if (status == 94 && chk_filename_spaces) { /* File Name error */ + skip_exn = 1; f->file_status[0] = '9'; f->file_status[1] = 4; - if (fnstatus) { - memcpy (fnstatus->data, f->file_status, (size_t)2); - } } else if (f->file_status[0] == '9' && f->file_status[1] == 4) { /* File name error */ - if (fnstatus) { - memcpy (fnstatus->data, f->file_status, (size_t)2); - } + skip_exn = 1; } else if (status > COB_STATUS_BASE) { + skip_exn = 1; if (delete_file_status) { delete_file_status = 0; cob_set_exception (COB_EC_DELETE_FILE); @@ -3414,17 +3408,36 @@ cob_file_save_status (cob_file *f, cob_field *fnstatus, const int status) break; } } else { + f->file_status[0] = (unsigned char)COB_I2D (status / 10); + f->file_status[1] = (unsigned char)COB_I2D (status % 10); + } + if (fnstatus) { + memcpy (fnstatus->data, f->file_status, (size_t)2); + } + if (f->file_status[0] == '0' + && (!delete_file_status || status == 0)) { + /* EOP is non-fatal therefore 00 status but needs exception */ + if (eop_status == 0) { + file_globptr->cob_exception_code = 0; + } else { +#if 0 /* correct thing to do, but then also needs to have codegen adjusted + --> module-incompatibility --> 4.x */ + cob_set_exception (eop_status); +#else + cob_set_exception (COB_EC_I_O_EOP); +#endif + eop_status = 0; + } + if ((f->file_features & COB_FILE_SYNC)) { + cob_file_sync (f); + } + } else if (!skip_exn) { if (delete_file_status) { delete_file_status = 0; cob_set_exception (COB_EC_DELETE_FILE); } else { cob_set_exception (status_exception[status / 10]); } - f->file_status[0] = (unsigned char)COB_I2D (status / 10); - f->file_status[1] = (unsigned char)COB_I2D (status % 10); - } - if (fnstatus) { - memcpy (fnstatus->data, f->file_status, (size_t)2); } if (f->trace_io @@ -4504,7 +4517,7 @@ cob_file_open (cob_file_api *a, cob_file *f, char *filename, #ifdef _WIN32 fmode = "rb+"; #else - if (!cobsetptr->cob_unix_lf) { + if (!file_setptr->cob_unix_lf) { fmode = "r+"; } else { fmode = "rb+"; @@ -5125,6 +5138,14 @@ sequential_rewrite (cob_file_api *a, cob_file *f, const int opt) #define IS_BAD_CHAR(x) (x < ' ' && x != COB_CHAR_BS && x != COB_CHAR_ESC \ && x != COB_CHAR_FF && x != COB_CHAR_SI && x != COB_CHAR_TAB) +#if defined (COB_EXPERIMENTAL) +#ifdef COB_EBCDIC_MACHINE +#define IS_NOT_PRINTABLE(x) (x > 0x40 && !isprint (x)) +#else +#define IS_NOT_PRINTABLE(x) (x > 0x7E && !isprint (x)) +#endif +#endif + static int lineseq_read (cob_file_api *a, cob_file *f, const int read_opts) { @@ -5134,6 +5155,16 @@ lineseq_read (cob_file_api *a, cob_file *f, const int read_opts) int n; int sts = COB_STATUS_00_SUCCESS; +#if defined (COB_EXPERIMENTAL) && defined (HAVE_SETLOCALE) + char *previous_locale = NULL; + + if (file_setptr->cob_ls_validate + && file_globptr->cob_locale_ctype) { + previous_locale = setlocale (LC_CTYPE, NULL); + setlocale (LC_CTYPE, file_globptr->cob_locale_ctype); + } +#endif + COB_UNUSED (a); COB_UNUSED (read_opts); @@ -5152,7 +5183,8 @@ lineseq_read (cob_file_api *a, cob_file *f, const int read_opts) if (open_next (f)) { goto again; } - return COB_STATUS_10_END_OF_FILE; + sts = COB_STATUS_10_END_OF_FILE; + goto End; } else { break; } @@ -5178,20 +5210,26 @@ lineseq_read (cob_file_api *a, cob_file *f, const int read_opts) } if ((f->file_features & COB_FILE_LS_VALIDATE) && !f->nconvert_fields) { - if ((IS_BAD_CHAR (n) - || (n > 0x7E && !isprint(n)))) { + if (IS_BAD_CHAR (n)) { sts = COB_STATUS_09_READ_DATA_BAD; +#if defined (COB_EXPERIMENTAL) + } else if (file_setptr->cob_ls_validate > 1 + && IS_NOT_PRINTABLE (n)) { + sts = COB_STATUS_0P_NOT_PRINTABLE; +#endif } } else if ((f->file_features & COB_FILE_LS_NULLS)) { if (n == 0) { n = getc (fp); /* NULL-Encoded -> should be less than a space */ if (n == EOF || (unsigned char)n >= ' ') { - return COB_STATUS_71_BAD_CHAR; + sts = COB_STATUS_71_BAD_CHAR; + goto End; } /* Not NULL-Encoded, may not be less than a space */ } else if (!f->nconvert_fields && (unsigned char)n < ' ') { - return COB_STATUS_71_BAD_CHAR; + sts = COB_STATUS_71_BAD_CHAR; + goto End; } } else if (n == COB_CHAR_TAB @@ -5250,9 +5288,15 @@ lineseq_read (cob_file_api *a, cob_file *f, const int read_opts) unsigned char *p; for (p = to_conv.data; p < conv_end; p++) { n = *p = f->code_set_read[*p]; - if ((IS_BAD_CHAR (n) - || (n > 0x7E && !isprint (n)))) { - sts = COB_STATUS_09_READ_DATA_BAD; + if (f->file_features & COB_FILE_LS_VALIDATE) { + if (IS_BAD_CHAR (n)) { + sts = COB_STATUS_09_READ_DATA_BAD; +#if defined (COB_EXPERIMENTAL) && defined (HAVE_SETLOCALE) + } else if (file_setptr->cob_ls_validate > 1 + && IS_NOT_PRINTABLE (n)) { + sts = COB_STATUS_0P_NOT_PRINTABLE; +#endif + } } } } @@ -5267,6 +5311,12 @@ lineseq_read (cob_file_api *a, cob_file *f, const int read_opts) if (f->open_mode == COB_OPEN_I_O) { /* Required on some systems */ fflush (fp); } +#endif +End: +#if defined (COB_EXPERIMENTAL) && defined (HAVE_SETLOCALE) + if (previous_locale) { + setlocale (LC_CTYPE, previous_locale); + } #endif return sts; } @@ -6702,7 +6752,7 @@ cob_file_external_addr (const char *exname, { cob_file **epfl = cob_external_addr (exname, sizeof (cob_file *)); - if (cobglobptr->cob_initial_external) { + if (file_globptr->cob_initial_external) { /* if the pointer was setup the first time: allocate the file and store the address for next request */ cob_file_malloc (pfl, pky, nkeys, linage); @@ -7286,6 +7336,9 @@ cob_read (cob_file *f, cob_field *key, cob_field *fnstatus, const int read_opts) case COB_STATUS_04_SUCCESS_INCOMPLETE: case COB_STATUS_06_READ_TRUNCATE: case COB_STATUS_09_READ_DATA_BAD: +#if defined (COB_EXPERIMENTAL) + case COB_STATUS_0P_NOT_PRINTABLE: +#endif f->flag_first_read = 0; f->flag_read_done = 1; f->flag_end_of_file = 0; @@ -7325,7 +7378,7 @@ is_suppressed_key_value (cob_file *f, const int idx) for (pos = 0; pos < (int)f->keys[idx].field->size && f->keys[idx].field->data[pos] == (unsigned char)f->keys[idx].char_suppress; - pos++); + pos++); /* All SUPPRESS char ? */ if (pos == f->keys[idx].field->size) { return 1; @@ -7423,6 +7476,9 @@ cob_read_next (cob_file *f, cob_field *fnstatus, const int read_opts) case COB_STATUS_04_SUCCESS_INCOMPLETE: case COB_STATUS_06_READ_TRUNCATE: case COB_STATUS_09_READ_DATA_BAD: +#if defined (COB_EXPERIMENTAL) + case COB_STATUS_0P_NOT_PRINTABLE: +#endif /* If record has suppressed key, skip it */ /* This is to catch CISAM, old VBISAM, ODBC & OCI */ if (f->organization == COB_ORG_INDEXED) { @@ -7470,14 +7526,14 @@ get_code_set_converted_data (cob_file *f) if (f->nconvert_fields) { /* CODE-SET FOR - convert specific areas only */ - const unsigned char* rec_end = converted_copy + size; + const unsigned char *rec_end = converted_copy + size; size_t ic; memcpy (converted_copy, real_rec_data, size); for (ic = 0; ic < f->nconvert_fields; ic++) { const cob_field to_conv = f->convert_field[ic]; - const unsigned char* to_conv_end = to_conv.data + to_conv.size; - const unsigned char* conv_end = rec_end < to_conv_end ? rec_end : to_conv_end; - unsigned char* p; + const unsigned char *to_conv_end = to_conv.data + to_conv.size; + const unsigned char *conv_end = rec_end < to_conv_end ? rec_end : to_conv_end; + unsigned char *p; for (p = to_conv.data; p < conv_end; p++) { *p = f->sort_collating[*p]; } @@ -7570,16 +7626,42 @@ cob_write (cob_file *f, cob_field *rec, const int opt, cob_field *fnstatus, not part of the record [= fixed length] */ const size_t size = lineseq_size (f); /* early pre-validation for data we'd otherwise convert */ - if (cobsetptr->cob_ls_validate + if (file_setptr->cob_ls_validate && !f->flag_line_adv && f->sort_collating) { const unsigned char *p = f->record->data; size_t i; - for (i = 0; i < size; ++i, ++p) { - if (IS_BAD_CHAR (*p)) { - cob_file_save_status (f, fnstatus, COB_STATUS_71_BAD_CHAR); + if (f->file_features & COB_FILE_LS_VALIDATE) { + for (i = 0; i < size; ++i, ++p) { + if (IS_BAD_CHAR (*p)) { + cob_file_save_status (f, fnstatus, COB_STATUS_71_BAD_CHAR); + return; + } + } + } else { +#if !defined (COB_EXPERIMENTAL) + for (i = 0; i < size; ++i, ++p) { + if (IS_BAD_CHAR (*p)) { + cob_file_save_status (f, fnstatus, COB_STATUS_71_BAD_CHAR); + return; + } + } +#else + int sts = 0; + for (i = 0; i < size; ++i, ++p) { + if (IS_BAD_CHAR (*p)) { + cob_file_save_status (f, fnstatus, COB_STATUS_71_BAD_CHAR); + return; + } + if (IS_NOT_PRINTABLE (*p)) { + sts = COB_STATUS_0P_NOT_PRINTABLE; + } + } + if (sts != 0) { + cob_file_save_status (f, fnstatus, COB_STATUS_0P_NOT_PRINTABLE); return; } +#endif } } f->record->size = size; @@ -7595,7 +7677,7 @@ cob_write (cob_file *f, cob_field *rec, const int opt, cob_field *fnstatus, } f->record->data = converted_copy; cob_file_save_status (f, fnstatus, - fileio_funcs[get_io_ptr (f)]->write (&file_api, f, opt)); + fileio_funcs[get_io_ptr (f)]->write (&file_api, f, opt)); f->record->data = real_rec_data; cob_free (converted_copy); @@ -7689,7 +7771,40 @@ cob_rewrite (cob_file *f, cob_field *rec, const int opt, cob_field *fnstatus) /* Re-Determine the size to be written (done here so possible CODE-SET conversions do not convert trailing spaces when not part of the record [= fixed length] */ - f->record->size = lineseq_size (f); + size_t size = lineseq_size (f); + /* early pre-validation for data we'd otherwise convert */ + if (file_setptr->cob_ls_validate + && !f->flag_line_adv + && f->sort_collating) { + const unsigned char *p = f->record->data; + size_t i; + if (f->file_features & COB_FILE_LS_VALIDATE) { + for (i = 0; i < size; ++i, ++p) { + if (IS_BAD_CHAR (*p)) { + cob_file_save_status (f, fnstatus, COB_STATUS_71_BAD_CHAR); + return; + } + } +#if defined (COB_EXPERIMENTAL) + } else { + int sts = 0; + for (i = 0; i < size; ++i, ++p) { + if (IS_BAD_CHAR (*p)) { + cob_file_save_status (f, fnstatus, COB_STATUS_71_BAD_CHAR); + return; + } + if (IS_NOT_PRINTABLE (*p)) { + sts = COB_STATUS_0P_NOT_PRINTABLE; + } + } + if (sts != 0) { + cob_file_save_status (f, fnstatus, COB_STATUS_0P_NOT_PRINTABLE); + return; + } +#endif + } + } + f->record->size = size; } /* CODE-SET conversion (rewrite from converted shadow-copy) */ diff --git a/libcob/fileio.h b/libcob/fileio.h index 86207434e..d7677d9a8 100644 --- a/libcob/fileio.h +++ b/libcob/fileio.h @@ -50,7 +50,7 @@ #ifndef EDEADLK #ifdef EDEADLOCK /* SCO name for EDEADLK */ #define EDEADLK EDEADLOCK -#else +#else #define EDEADLK 99 #endif #endif diff --git a/libcob/intrinsic.c b/libcob/intrinsic.c index 0e03da629..071c98a89 100644 --- a/libcob/intrinsic.c +++ b/libcob/intrinsic.c @@ -3951,7 +3951,7 @@ cob_intr_hex_to_char (cob_field *srcfield) if (size * 2 != srcfield->size) { /* posibly raise nonfatal exception here -> we only process the valid ones */ - // size--; + /* size--; */ } COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL); @@ -5517,11 +5517,7 @@ cob_intr_random (const int params, ...) cob_field *f; va_list args; double val; -#ifdef DISABLE_GMP_RANDOM - unsigned int seed = 0; -#else - unsigned long seed = 0; -#endif + unsigned long seed = 0; cob_field_attr attr; cob_field field; @@ -5533,7 +5529,11 @@ cob_intr_random (const int params, ...) if (specified_seed < 0) { cob_set_exception (COB_EC_ARGUMENT_FUNCTION); } else { +#ifdef _WIN32 + seed = (unsigned long)(specified_seed & 0xFFFFFFFF); +#else seed = (unsigned long)specified_seed; +#endif } rand_needs_seeding++; #ifdef DISABLE_GMP_RANDOM @@ -5542,7 +5542,11 @@ cob_intr_random (const int params, ...) #else } else if (rand_needs_seeding) { /* first invocation without explicit seed, use a random one */ +#ifdef _WIN32 + seed = (get_seconds_past_midnight () * (long)COB_MODULE_PTR) & 0xFFFFFFFF; +#else seed = get_seconds_past_midnight () * (long)COB_MODULE_PTR; +#endif rand_needs_seeding = 2; #endif } diff --git a/libcob/move.c b/libcob/move.c index 936d68351..082d52a8b 100644 --- a/libcob/move.c +++ b/libcob/move.c @@ -710,6 +710,9 @@ cob_move_binary_to_display (cob_field *f1, cob_field *f2) /* Edited */ +/* create numeric edited field, note: non-display fields + get "unpacked" first via indirect_move, then be edited + from display using this function */ static void cob_move_display_to_edited (cob_field *f1, cob_field *f2) { @@ -732,6 +735,7 @@ cob_move_display_to_edited (cob_field *f1, cob_field *f2) int suppress_zero = 1; int sign_first = 0; int p_is_left = 0; + int has_b = 0; int repeat; int n; unsigned char pad = ' '; @@ -781,7 +785,7 @@ cob_move_display_to_edited (cob_field *f1, cob_field *f2) } } - src = max - COB_FIELD_SCALE(f1) - count; + src = max - COB_FIELD_SCALE (f1) - count; if(COB_FIELD_PIC (f2) == NULL) { /* There is no PIC present so assume all PIC 9s */ n = f2->size; @@ -799,65 +803,16 @@ cob_move_display_to_edited (cob_field *f1, cob_field *f2) n = p->times_repeated; for (; n > 0; n--, ++dst) { switch (c) { - case '0': - case '/': - *dst = c; - break; - - case 'B': - *dst = suppress_zero ? pad : 'B'; - break; - - case 'P': - if (p_is_left) { - ++src; - --dst; - } - break; case '9': - *dst = (min <= src && src < max) ? *src++ : (src++, '0'); - if (*dst != '0') { + x = (min <= src && src < max) ? *src++ : (src++, '0'); + if (x != '0') { is_zero = suppress_zero = 0; } suppress_zero = 0; trailing_sign = 1; trailing_curr = 1; - break; - - case 'V': - --dst; - decimal_point = dst; - break; - - case '.': - case ',': - if (c == dec_symbol) { - *dst = dec_symbol; - decimal_point = dst; - } else { - if (suppress_zero) { - *dst = pad; - } else { - *dst = c; - } - } - break; - - case 'C': - case 'D': - end = dst; - /* Check negative and not zero */ - if (neg && !is_zero) { - if (c == 'C') { - memcpy (dst, "CR", (size_t)2); - } else { - memcpy (dst, "DB", (size_t)2); - } - } else { - memset (dst, ' ', (size_t)2); - } - dst++; + *dst = x; break; case 'Z': @@ -866,10 +821,10 @@ cob_move_display_to_edited (cob_field *f1, cob_field *f2) if (x != '0') { is_zero = suppress_zero = 0; } - pad = (c == '*') ? '*' : ' '; - *dst = suppress_zero ? pad : x; trailing_sign = 1; trailing_curr = 1; + pad = (c == '*') ? '*' : ' '; + *dst = suppress_zero ? pad : x; break; case '+': @@ -909,37 +864,99 @@ cob_move_display_to_edited (cob_field *f1, cob_field *f2) } break; - default: - if (c == currency) { - x = (min <= src && src < max) ? *src++ : (src++, '0'); - if (x != '0') { - is_zero = suppress_zero = 0; - } - num_curr++; - if (num_curr > 1) - trailing_sign = 1; - if (trailing_curr) { - *dst = currency; - --end; - } else if (dst == f2->data || suppress_zero) { + case '.': + case ',': + if (c == dec_symbol) { + *dst = dec_symbol; + decimal_point = dst; + } else { + if (suppress_zero) { *dst = pad; - curr_symbol = currency; } else { - *dst = x; + *dst = c; } - if (n > 1 || last_fixed_insertion_char == c) { - floating_insertion = 1; - } else if (!trailing_curr) { - if (last_fixed_insertion_pos) { - *last_fixed_insertion_pos = last_fixed_insertion_char; - } - last_fixed_insertion_pos = dst; - last_fixed_insertion_char = c; + } + break; + + case 'V': + --dst; + decimal_point = dst; + break; + + case '0': + case '/': + *dst = c; + break; + + case 'B': + if (suppress_zero) { + *dst = pad; + } else { + *dst = 'B'; + has_b = 1; + } + break; + + case 'P': + if (p_is_left) { + ++src; + --dst; + } + break; + + case 'C': + case 'D': + end = dst; + /* Check negative and not zero */ + if (neg && !is_zero) { + if (c == 'C') { + memcpy (dst, "CR", (size_t)2); + } else { + memcpy (dst, "DB", (size_t)2); } + } else { + memset (dst, ' ', (size_t)2); + } + dst++; + break; + + default: + /* LCOV_EXCL_START */ + if (c != currency) { + /* should never happen, consider remove [also the reason for not translating that] */ + cob_runtime_error ("cob_move_display_to_edited: invalid PIC character %c", c); + *dst = '?'; /* Invalid PIC */ break; } + /* LCOV_EXCL_STOP */ - *dst = '?'; /* Invalid PIC */ + x = (min <= src && src < max) ? *src++ : (src++, '0'); + if (x != '0') { + is_zero = suppress_zero = 0; + } + num_curr++; + if (num_curr > 1) { + trailing_sign = 1; + } + if (trailing_curr) { + *dst = currency; + --end; + } else if (dst == f2->data || suppress_zero) { + *dst = pad; + curr_symbol = currency; + } else { + *dst = x; + } + if (n > 1 || last_fixed_insertion_char == c) { + floating_insertion = 1; + } else if (!trailing_curr) { + if (last_fixed_insertion_pos) { + *last_fixed_insertion_pos = last_fixed_insertion_char; + } + last_fixed_insertion_pos = dst; + last_fixed_insertion_char = c; + } + break; } } } @@ -979,7 +996,12 @@ cob_move_display_to_edited (cob_field *f1, cob_field *f2) case '7': case '8': case '9': +#if 1 /* CHECKME: Why should we have a comma in here, necessary as shown in NIST NC, + (TODO: add this to the internal testsuite, must fail if commented out) + but not skip a period? */ case ',': + case '.': +#endif case '+': case '-': case '/': @@ -1025,17 +1047,18 @@ cob_move_display_to_edited (cob_field *f1, cob_field *f2) } } - /* Replace all 'B's by pad */ - count = 0; - for (dst = f2->data; dst < end; ++dst) { - if (*dst == 'B') { - if (count == 0) { - *dst = pad; + /* Replace all leading 'B's by pad, others by space */ + if (has_b) { + for (dst = f2->data; dst < end; ++dst) { + if (*dst == 'B') { + if (has_b) { + *dst = pad; + } else { + *dst = ' '; + } } else { - *dst = ' '; + has_b = 0; /* non-starting characters seen */ } - } else { - ++count; } } } diff --git a/libcob/numeric.c b/libcob/numeric.c index 88ffc7ab2..a7fc9ff69 100644 --- a/libcob/numeric.c +++ b/libcob/numeric.c @@ -2395,7 +2395,8 @@ cob_cmp_uint (cob_field *f1, const unsigned int n) cob_decimal_set_field (&cob_d1, f1); sign = mpz_sgn (cob_d1.value); if (sign == 0) { - return -n; + if (n > INT_MAX) return INT_MIN; + return -(int)n; } else if (sign == 1) { if (n <= 0) return 1; } else { @@ -2417,7 +2418,9 @@ cob_cmp_llint (cob_field *f1, const cob_s64_t n) cob_decimal_set_field (&cob_d1, f1); sign = mpz_sgn (cob_d1.value); if (sign == 0) { - return -n; + if (n > INT_MAX) return INT_MIN; + if (n < INT_MIN) return INT_MAX; + return -(int)n; } else if (sign == 1) { if (n <= 0) return 1; } else { diff --git a/libcob/screenio.c b/libcob/screenio.c index 9984eb1a4..4ea479da6 100644 --- a/libcob/screenio.c +++ b/libcob/screenio.c @@ -2064,7 +2064,7 @@ cob_screen_get_all (const int initial_curs, const int accept_timeout) mevent.bstate &= cob_mask_accept; if (mevent.bstate != 0) { global_return = mouse_to_exception_code (mevent.bstate); - cob_move_cursor (mline, mcolumn); // move cursor to pass position + cob_move_cursor (mline, mcolumn); /* move cursor to pass position */ goto screen_return; } continue; @@ -3015,7 +3015,7 @@ field_accept (cob_field *f, const int sline, const int scolumn, cob_field *fgc, mevent.bstate &= cob_mask_accept; if (mevent.bstate != 0) { fret = mouse_to_exception_code (mevent.bstate); - cob_move_cursor (mline, mcolumn); // move cursor to pass position + cob_move_cursor (mline, mcolumn); /* move cursor to pass position */ goto field_return; } } @@ -3257,7 +3257,7 @@ field_accept (cob_field *f, const int sline, const int scolumn, cob_field *fgc, mevent.bstate &= cob_mask_accept; if (mevent.bstate != 0) { fret = mouse_to_exception_code (mevent.bstate); - cob_move_cursor (mline, mcolumn); // move cursor to pass position + cob_move_cursor (mline, mcolumn); /* move cursor to pass position */ goto field_return; } continue; diff --git a/po/ChangeLog b/po/ChangeLog index 904eba2a0..815a90106 100644 --- a/po/ChangeLog +++ b/po/ChangeLog @@ -99,6 +99,10 @@ * ja.po: New file. +2002-05-23 Keisuke Nishida + + * new folder - created with gettextize + Copyright 2002,2010,2011,2014-2018 Free Software Foundation, Inc. diff --git a/tests/ChangeLog b/tests/ChangeLog index a92686469..b4d60c4fe 100644 --- a/tests/ChangeLog +++ b/tests/ChangeLog @@ -1,4 +1,11 @@ +2024-08-03 David Declerck + + * testsuite.src/run_file.at, testsuite.src/run_misc.at: + fix a few tests that break under MSVC Debug while working + under MSVC Release, by forcing a flush of stdout with + fflush and using cob_free instead of free in C codes + 2023-01-21 Simon Sobisch * atlocal.in: prefer config.status replacement over environment var diff --git a/tests/cobol85/ChangeLog b/tests/cobol85/ChangeLog index a91245319..bc947d6f5 100644 --- a/tests/cobol85/ChangeLog +++ b/tests/cobol85/ChangeLog @@ -1,8 +1,18 @@ +2024-08-27 Nicolas Berthier + + * Makefile.am: stop downloading "newcob.val.Z" from out-dated URL + 2023-06-02 Simon Sobisch * report.pl: place stderr from test runs into .out file +2022-12-22 Simon Sobisch + + * Makefile.am: ensure to not create half-baked module directories, + added "modules" to .PHONY target; always set COB_UNIX_LF for + executing EXEC85 to be identical to the later testsuite run + 2022-12-12 Simon Sobisch * Makefile.am: adjusted URL_NEWCOB_TAR_GZ as old value (SF download area) diff --git a/tests/cobol85/Makefile.am b/tests/cobol85/Makefile.am index c452047ba..c37231809 100644 --- a/tests/cobol85/Makefile.am +++ b/tests/cobol85/Makefile.am @@ -59,7 +59,10 @@ PRE_INST_ENV = "$(abs_top_builddir)/pre-inst-env" # MAKEFLAGS = --no-print-directory # targets that are only logical targets instead of files -.PHONY: test test-local diff-summary diff summary.log $(MODULES_RUN) unpack-Z unpack-gz +.PHONY: test test-local test-local-compat \ + diff-summary diff summary.log \ + modules $(MODULES_RUN) \ + unpack-Z unpack-gz NC_RUN: NC @cd NC && $(MAKE) -k $(SINGLE_TARGET) @@ -165,11 +168,13 @@ diff-summary: @diff $(DIFF_FLAGS) "$(srcdir)/$(SUMMARY)" "summary.log" @echo Done -newcob.val.Z: - @echo "Trying to download newcob.val.Z..." - @(which curl 1>/dev/null && curl $(CURL_FLAGS) "$(URL_NEWCOB_Z)" -o $@) || \ - wget $(WGET_FLAGS) "$(URL_NEWCOB_Z)" || \ - ($(RM) $@; echo "Downloading $@ failed"; false) +# Note: $(URL_NEWCOB_Z) is out-dated and simply grabs an HTML file +# without error. +# newcob.val.Z: +# @echo "Trying to download newcob.val.Z..." +# @(which curl 1>/dev/null && curl $(CURL_FLAGS) "$(URL_NEWCOB_Z)" -o $@) || \ +# wget $(WGET_FLAGS) "$(URL_NEWCOB_Z)" || \ +# ($(RM) $@; echo "Downloading $@ failed"; false) newcob.val.tar.gz: @echo "Trying to download newcob.val.tar.gz..." @@ -227,17 +232,17 @@ $(MODULES_ALL): newcob.val EXEC85$(EXEEXT) $(srcdir)/EXEC85.conf.in Makefile.mod else \ export NEWCOB_VAL=$(abs_srcdir)/newcob.val; \ fi; \ - cd $@ && $(PRE_INST_ENV) ../EXEC85$(EXEEXT) - @$(PERL) $(srcdir)/expand.pl $@/newcob.tmp $@ + (cd $@ && COB_UNIX_LF=Y $(PRE_INST_ENV) ../EXEC85$(EXEEXT)) || ($(RM) $(abs_builddir)/$@ && false) + @$(PERL) $(srcdir)/expand.pl $@/newcob.tmp $@ || ($(RM) $(abs_builddir)/$@ && false) # @$(RM) ./$@/newcob.tmp ./$@/newcob.log ./$@/EXEC85.conf - @export CBL_LIST="`ls $@/*.CBL | cut -f2 -d/ | tr '\n' ' '`" && \ + @(export CBL_LIST="`ls $@/*.CBL | cut -f2 -d/ | tr '\n' ' '`" && \ $(SED) -e 's/##MODULE##/'"$@"'/' \ -e 's|##COB85DIR##|'$(abs_srcdir)'|' \ -e 's|##DIFF_FLAGS##|'"$(DIFF_FLAGS)"'|' \ -e 's|##PERL##|'"$(PERL)"'|' \ -e 's|##TESTS##|'"` echo $$CBL_LIST | $(SED) -e 's/\.CBL//g'`"'|' \ -e 's|##TESTS_LOCAL##|'"`echo $$CBL_LIST | $(SED) -e 's/\.CBL/-local/g'`"'|' \ - $(srcdir)/Makefile.module.in > $@/Makefile + $(srcdir)/Makefile.module.in > $@/Makefile) || ($(RM) $(abs_builddir)/$@ && false) @echo "Finished module directory $@." EXEC85.cob: newcob.val diff --git a/tests/cobol85/expand.pl b/tests/cobol85/expand.pl index 3462cf9b9..bf4abb481 100755 --- a/tests/cobol85/expand.pl +++ b/tests/cobol85/expand.pl @@ -37,7 +37,7 @@ if (/^ \*HEADER,([^,]*),([^, ]*)(,([^,]*),([^, ]*))?/) { my ($type, $prog, $subt, $subr) = ($1, $2, $4, $5); $output = $type; - my $module = $moddir; + my $module = $moddir; # overwritten later in case of copybook my $name = ''; if ($subt) { if ($subt eq "SUBPRG") { diff --git a/tests/testsuite.src/configuration.at b/tests/testsuite.src/configuration.at index f71ecbf46..ef5d6126e 100644 --- a/tests/testsuite.src/configuration.at +++ b/tests/testsuite.src/configuration.at @@ -899,10 +899,10 @@ AT_DATA([prog.cob], [ STOP RUN. ]) -AT_CHECK([$COBC -febcdic-table=default prog.cob], [0], [], []) -AT_CHECK([$COBC -febcdic-table=restricted-gc prog.cob], [0], [], []) -AT_CHECK([$COBC -febcdic-table=ibm prog.cob], [0], [], []) -AT_CHECK([$COBC -febcdic-table=gcos prog.cob], [0], [], []) +AT_CHECK([$COBC -febcdic-table=DEFAULT prog.cob], [0], [], []) +AT_CHECK([$COBC -febcdic-table=RESTRICTED-GC prog.cob], [0], [], []) +AT_CHECK([$COBC -febcdic-table=IBM prog.cob], [0], [], []) +AT_CHECK([$COBC -febcdic-table=GCOS prog.cob], [0], [], []) AT_CHECK([$COBC -febcdic-table=unknown prog.cob], [1], [], [cobc: error: invalid parameter: -febcdic-table ]) diff --git a/tests/testsuite.src/listings.at b/tests/testsuite.src/listings.at index b02a67519..31cb56330 100644 --- a/tests/testsuite.src/listings.at +++ b/tests/testsuite.src/listings.at @@ -3487,13 +3487,13 @@ error: P must be at start or end of PICTURE string error: V cannot follow a P which is after the decimal point 000058 01 missing-symbols. 000059 03 PIC B(5). -error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 +error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 + and *; or at least two of the set +, - and the currency symbol 000060 03 PIC +. -error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 +error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 + and *; or at least two of the set +, - and the currency symbol 000061 03 PIC $. -error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 +error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 + and *; or at least two of the set +, - and the currency symbol 000062 000063 01 str-constant CONSTANT "hello". @@ -3687,9 +3687,9 @@ prog.cob:55: error: a leading currency symbol cannot follow 9 prog.cob:56: error: a leading currency symbol cannot follow B, 0 or / prog.cob:57: error: P must be at start or end of PICTURE string prog.cob:57: error: V cannot follow a P which is after the decimal point -prog.cob:59: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol -prog.cob:60: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol -prog.cob:61: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +prog.cob:59: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +prog.cob:60: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +prog.cob:61: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol prog.cob:67: error: 'STR-CONSTANT' is not a numeric literal prog.cob:68: error: 'FLOAT-CONSTANT' is not an integer prog.cob:69: error: 'SIGNED-CONSTANT' is not unsigned diff --git a/tests/testsuite.src/run_file.at b/tests/testsuite.src/run_file.at index 0795f93ff..bc8e0fc1c 100644 --- a/tests/testsuite.src/run_file.at +++ b/tests/testsuite.src/run_file.at @@ -9885,6 +9885,7 @@ doOpenFile( printf("EXFTH did %s; Status=%c%c; File now %s\n", opmsg, fcd->fileStatus[0], fcd->fileStatus[1], (fcd->openMode & OPEN_NOT_OPEN) ? "Closed" : "Open"); + fflush(stdout); return sts; } @@ -9939,6 +9940,7 @@ TSTFH (unsigned char *opCodep, FCD3 *fcd) sts = EXTFH(opCodep, fcd); printf("EXFTH did %s; Status=%c%c\n", txtOpCode(opCode), fcd->fileStatus[0], fcd->fileStatus[1]); + fflush(stdout); return sts; } diff --git a/tests/testsuite.src/run_fundamental.at b/tests/testsuite.src/run_fundamental.at index 5cb2da9fa..e2fffb4f5 100644 --- a/tests/testsuite.src/run_fundamental.at +++ b/tests/testsuite.src/run_fundamental.at @@ -1430,9 +1430,13 @@ some (void) AT_CHECK([$COMPILE prog.cob], [0], [], []) AT_CHECK([$COMPILE_MODULE module.c], [0], [], []) -AT_CHECK([$COBCRUN_DIRECT ./prog], [1], [], +# the warning itself is very system specific, so disable it, +# then run again checking only for the warning +AT_CHECK([COB_DISABLE_WARNINGS=1 $COBCRUN_DIRECT ./prog], [1], [], [libcob: prog.cob:6: error: entry point 'module' not found ]) +AT_CHECK([$COBCRUN_DIRECT ./prog 2> err.log], [1], [], []) +AT_CHECK([$GREP "libcob: prog.cob:6: warning: " err.log], [0], ignore, []) AT_CLEANUP @@ -1729,6 +1733,10 @@ AT_CHECK([COB_PHYSICAL_CANCEL=Y $COBCRUN_DIRECT ./prog], [0], [12< 121< ]) +AT_CHECK([COB_PHYSICAL_CANCEL=NEVER $COBCRUN_DIRECT ./prog], [0], +[12< +121< +]) AT_CLEANUP diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index f43ddce1a..1bf762e79 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -1780,17 +1780,17 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [Converted: "A#O2018 |!"], []) # For characters above IBM (with irregularities) and GCOS should match: -AT_CHECK([$COMPILE prog.cob -febcdic-table=ibm -o prog-ibm], [0], [], []) +AT_CHECK([$COMPILE prog.cob -febcdic-table=IBM -o prog-ibm], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog-ibm], [0], [Converted: "A#O2018 |@:>@"], []) # prefix is actually "|]" (escaped for m4 preproc) -AT_CHECK([$COMPILE prog.cob -febcdic-table=gcos -o prog-gcos], [0], [], []) +AT_CHECK([$COMPILE prog.cob -febcdic-table=GCOS -o prog-gcos], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog-gcos], [0], [Converted: "A#O2018 |@:>@"], []) # prefix is actually "|]" (escaped for m4 preproc) # FIXME: This really does not convert to anything close to ASCII; # what's this table supposed to encode? -# AT_CHECK([$COMPILE prog.cob -febcdic-table=restricted-gc -o prog-rgc], [0], [], []) +# AT_CHECK([$COMPILE prog.cob -febcdic-table=RESTRICTED-GC -o prog-rgc], [0], [], []) # AT_CHECK([$COBCRUN_DIRECT ./prog-rgc], [0], []) AT_CLEANUP @@ -7839,6 +7839,7 @@ dump (unsigned char *data) for (i = 0; i < 4; i++) printf ("%02X", data[i]); puts (" ."); + fflush (stdout); return 0; } ]]) @@ -8030,6 +8031,10 @@ AT_DATA([caller.cob], [ WHEN tkey(tidx) = 'C' CONTINUE END-SEARCH + SEARCH ALL tentry + WHEN tkey(tidx) = 'X' + CONTINUE + END-SEARCH *> STOP RUN. ]) @@ -8302,7 +8307,11 @@ Program-Id: caller SEARCH ALL Line: Program-Id: caller WHEN Line: 58 Program-Id: caller WHEN Line: 58 Program-Id: caller CONTINUE Line: 59 -Program-Id: caller STOP RUN Line: 62 +Program-Id: caller SEARCH ALL Line: 61 +Program-Id: caller WHEN Line: 62 +Program-Id: caller WHEN Line: 62 +Program-Id: caller AT END Line: 64 +Program-Id: caller STOP RUN Line: 66 ]) AT_CLEANUP @@ -10234,6 +10243,7 @@ CAPI (void *p1, ...) printf("Line%3d: ",k); } printf ("CALL with %d parameters\n",nargs); + fflush (stdout); for (k=1; k <= nargs; k++) { type = cob_get_param_type (k); digits = cob_get_param_digits (k); @@ -10588,6 +10598,7 @@ CAPI (void *p1, ...) printf("Line%3d: ",k); } printf ("CALL with %d parameters\n",nargs); + fflush (stdout); for (k=1; k <= nargs; k++) { cob_field *fld = cob_get_param_field (k, "CAPI"); type = cob_get_field_type (fld); @@ -10651,7 +10662,7 @@ CAPI (void *p1, ...) cob_put_field_str (fld, wrk); } printf (";\n"); - fflush(stdout); + fflush (stdout); } return 0; } @@ -11306,11 +11317,31 @@ AT_DATA([prog.cob], [ END PROGRAM c. ]) -AT_CHECK([$COMPILE -o prog prog.cob], [0], [], []) -AT_CHECK([$COBCRUN_DIRECT ./prog], [0], +AT_CHECK([$COMPILE_MODULE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN prog], [0], [Hello! Hello again! +], []) + +AT_DATA([caller.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. caller. + + PROCEDURE DIVISION. + MAIN-LINE. + + *> minimal side-test for performance comparisions + PERFORM DO-CHECK 10000 TIMES + DISPLAY 'DONE' UPON SYSERR WITH NO ADVANCING + GOBACK. + + DO-CHECK. + CALL "prog" + . ]) + +AT_CHECK([$COMPILE caller.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./caller], [0], ignore, [DONE]) AT_CLEANUP diff --git a/tests/testsuite.src/syn_copy.at b/tests/testsuite.src/syn_copy.at index f852773ea..5daa5b3eb 100644 --- a/tests/testsuite.src/syn_copy.at +++ b/tests/testsuite.src/syn_copy.at @@ -570,11 +570,11 @@ AT_CHECK([$COMPILE -fpartial-replace-when-literal-src=skip -o prog-skip prog.cob AT_CHECK([$COBCRUN_DIRECT ./prog-skip], [0], [OKOKOKOKOKOK]) AT_CHECK([$COMPILE -fpartial-replace-when-literal-src=ok -o prog prog.cob], [1], [], [copy.inc:2: error: parentheses must be preceded by a picture symbol -copy.inc:2: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +copy.inc:2: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol copy.inc:3: error: parentheses must be preceded by a picture symbol -copy.inc:3: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +copy.inc:3: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol copy.inc:4: error: parentheses must be preceded by a picture symbol -copy.inc:4: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +copy.inc:4: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol prog.cob:17: error: 'X' cannot be used here prog.cob:20: error: 'Y' cannot be used here ]) @@ -592,11 +592,11 @@ prog.cob:12: error: partial replacing with literal used prog.cob:13: error: partial replacing with literal used prog.cob:13: error: partial replacing with literal used copy.inc:2: error: parentheses must be preceded by a picture symbol -copy.inc:2: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +copy.inc:2: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol copy.inc:3: error: parentheses must be preceded by a picture symbol -copy.inc:3: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +copy.inc:3: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol copy.inc:4: error: parentheses must be preceded by a picture symbol -copy.inc:4: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +copy.inc:4: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol prog.cob:17: error: 'X' cannot be used here prog.cob:20: error: 'Y' cannot be used here ]) diff --git a/tests/testsuite.src/syn_definition.at b/tests/testsuite.src/syn_definition.at index af36b9d75..74a23b4a8 100644 --- a/tests/testsuite.src/syn_definition.at +++ b/tests/testsuite.src/syn_definition.at @@ -337,7 +337,7 @@ AT_CLEANUP AT_SETUP([GO TO sections and foreign paragraphs]) -AT_KEYWORDS([definition procedures]) +AT_KEYWORDS([definition procedures section paragraph]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. @@ -346,6 +346,8 @@ AT_DATA([prog.cob], [ S-1 SECTION. GO TO S-2. E-1. + IF FUNCTION SECONDS-PAST-MIDNIGHT = 10 + GO TO S-1. *> check that go to its own section is not warned S-2 SECTION. GO TO E-3. @@ -363,8 +365,8 @@ AT_CHECK([$COBC -fsyntax-only -Wall -Werror=goto-section prog.cob], [1], [], [prog.cob: in section 'S-1': prog.cob:6: error: GO TO SECTION 'S-2' [[-Werror=goto-section]] prog.cob: in section 'S-2': -prog.cob:10: warning: GO TO paragraph 'E-3' which is defined in another SECTION [[-Wgoto-different-section]] -prog.cob:14: note: 'E-3 IN S-3' defined here [[-Wgoto-different-section]] +prog.cob:12: warning: GO TO paragraph 'E-3' which is defined in another SECTION [[-Wgoto-different-section]] +prog.cob:16: note: 'E-3 IN S-3' defined here [[-Wgoto-different-section]] ]) AT_CLEANUP @@ -1611,9 +1613,9 @@ prog.cob:55: error: a leading currency symbol cannot follow 9 prog.cob:56: error: a leading currency symbol cannot follow B, 0 or / prog.cob:57: error: P must be at start or end of PICTURE string prog.cob:57: error: V cannot follow a P which is after the decimal point -prog.cob:59: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol -prog.cob:60: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol -prog.cob:61: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +prog.cob:59: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +prog.cob:60: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +prog.cob:61: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol prog.cob:67: error: 'STR-CONSTANT' is not a numeric literal prog.cob:68: error: 'FLOAT-CONSTANT' is not an integer prog.cob:69: error: 'SIGNED-CONSTANT' is not unsigned @@ -1689,9 +1691,9 @@ prog.cob:55: error: a leading currency symbol cannot follow 9 prog.cob:56: error: a leading currency symbol cannot follow B, 0 or / prog.cob:57: error: P must be at start or end of PICTURE string prog.cob:57: error: V cannot follow a P which is after the decimal point -prog.cob:59: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol -prog.cob:60: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol -prog.cob:61: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +prog.cob:59: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +prog.cob:60: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +prog.cob:61: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol prog.cob:67: error: 'STR-CONSTANT' is not a numeric literal prog.cob:68: error: 'FLOAT-CONSTANT' is not an integer prog.cob:69: error: 'SIGNED-CONSTANT' is not unsigned @@ -1720,7 +1722,7 @@ AT_DATA([prog.cob], [ AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], [prog.cob:2: error: 'P' is not defined prog.cob:2: error: invalid PICTURE character '' -prog.cob:2: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +prog.cob:2: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol prog.cob:2: error: PROGRAM-ID header missing prog.cob:2: error: PROCEDURE DIVISION header missing prog.cob:2: error: syntax error, unexpected PICTURE diff --git a/tests/testsuite.src/syn_file.at b/tests/testsuite.src/syn_file.at index ece36696d..17d94f78a 100644 --- a/tests/testsuite.src/syn_file.at +++ b/tests/testsuite.src/syn_file.at @@ -1727,11 +1727,11 @@ AT_DATA([prog.cob], [ AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], [prog.cob:21: error: figurative constants not allowed in FROM clause -prog.cob:21: error: literal in FROM clause must be alphanumeric, national or boolean +prog.cob:21: error: literal in FROM clause must be alphanumeric, utf-8, national or boolean prog.cob:22: warning: numeric value is expected prog.cob:13: note: 'f-rec' defined here as PIC 999999 prog.cob:24: error: figurative constants not allowed in FROM clause -prog.cob:24: error: literal in FROM clause must be alphanumeric, national or boolean +prog.cob:24: error: literal in FROM clause must be alphanumeric, utf-8, national or boolean prog.cob:25: warning: numeric value is expected prog.cob:13: note: 'f-rec' defined here as PIC 999999 ]) diff --git a/tests/testsuite.src/syn_misc.at b/tests/testsuite.src/syn_misc.at index 7ab38951d..019137e03 100644 --- a/tests/testsuite.src/syn_misc.at +++ b/tests/testsuite.src/syn_misc.at @@ -7016,9 +7016,9 @@ AT_DATA([prog.cob], [ AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], [prog.cob:9: warning: handling of USAGE NATIONAL is unfinished; implementation is likely to be changed prog.cob:18: warning: handling of USAGE NATIONAL is unfinished; implementation is likely to be changed -prog.cob:13: error: 'invalid-1' ANY LENGTH must be PIC X, PIC N or PIC 1 -prog.cob:14: error: 'invalid-2' ANY LENGTH must be PIC X, PIC N or PIC 1 -prog.cob:15: error: 'invalid-3' ANY LENGTH must be PIC X, PIC N or PIC 1 +prog.cob:13: error: 'invalid-1' ANY LENGTH must be PIC X, PIC U, PIC N or PIC 1 +prog.cob:14: error: 'invalid-2' ANY LENGTH must be PIC X, PIC U, PIC N or PIC 1 +prog.cob:15: error: 'invalid-3' ANY LENGTH must be PIC X, PIC U, PIC N or PIC 1 prog.cob:16: error: 'invalid-4' ANY NUMERIC must be PIC 9 prog.cob:17: error: 'invalid-5' ANY LENGTH has invalid definition prog.cob:18: error: 'invalid-6' ANY LENGTH has invalid definition diff --git a/tests/testsuite.src/used_binaries.at b/tests/testsuite.src/used_binaries.at index 08a7417a4..992f71cde 100644 --- a/tests/testsuite.src/used_binaries.at +++ b/tests/testsuite.src/used_binaries.at @@ -218,7 +218,7 @@ AT_CLEANUP AT_SETUP([compiler outputs (file specified)]) -AT_KEYWORDS([runmisc cobc gen-c-line-directives gen-c-labels gen line labels]) +AT_KEYWORDS([runmisc cobc gen-c-line-directives gen-c-labels gen line labels copy]) AT_DATA([prog.cob],[ IDENTIFICATION DIVISION. @@ -228,29 +228,35 @@ AT_DATA([prog.cob],[ 01 BLA PIC X(5) VALUE 'bluBb'. PROCEDURE DIVISION. MAIN-PROC SECTION. + 00. COPY PROC. END-PROC SECTION. - STOP RUN. + COPY PROCE in "sub". + EX. + STOP RUN. ]) AT_CHECK([mkdir -p sub/copy], [0], [], []) AT_DATA([sub/copy/PROC.cpy],[ - DISPLAY BLA NO ADVANCING. + DISPLAY BLA NO ADVANCING. +]) +AT_DATA([sub/PROCE.cpy],[ + DISPLAY ' END' NO ADVANCING. ]) AT_CHECK([$COBC -I sub/copy prog.cob -o prog.c], [0], [], []) AT_CHECK([$COBC -I sub/copy prog.c -o prog.$COB_OBJECT_EXT], [0], [], []) AT_CHECK([$COBC -I sub/copy prog.$COB_OBJECT_EXT -o prog.$COB_MODULE_EXT]) -AT_CHECK([$COBCRUN prog], [0], [bluBb], []) +AT_CHECK([$COBCRUN prog], [0], [bluBb END], []) AT_CHECK([$COBC -I sub/copy -x prog.cob -o prog.c], [0], [], []) AT_CHECK([$COBC -I sub/copy -x prog.c -o prog.$COB_OBJECT_EXT], [0], [], []) AT_CHECK([$COBC -I sub/copy -x prog.$COB_OBJECT_EXT -o progo$COB_EXE_EXT], [0], [], []) -AT_CHECK([$COBCRUN_DIRECT ./progo], [0], [bluBb], []) +AT_CHECK([$COBCRUN_DIRECT ./progo], [0], [bluBb END], []) # making the extension explicit here to not let case-insensitive file-systems catch a .CPY... AT_CHECK([$COBC -I sub/copy prog.cob -ext=cpy -o prog.i], [0], [], []) AT_CHECK([$COBC -x prog.i -o prog$COB_EXE_EXT], [0], [], []) -AT_CHECK([$COBCRUN_DIRECT ./prog$COB_EXE_EXT], [0], [bluBb], []) +AT_CHECK([$COBCRUN_DIRECT ./prog$COB_EXE_EXT], [0], [bluBb END], []) AT_CHECK([$COBC -x prog.i -fgen-c-line-directives -fgen-c-labels -save-temps], [0], [], []) AT_CHECK([$GREP 'prog.i' prog.c], [0], ignore, []) AT_CHECK([$GREP 'prog.i' prog.c | $GREP '#line'], [1], ignore, ignore) @@ -259,7 +265,15 @@ AT_CHECK([$GREP 'prog.i' prog.c | $GREP '#line'], [1], ignore, ignore) #AT_CHECK([$GREP 'PROC.cpy' prog.c | $GREP '#line'], [0], ignore, []) AT_CHECK([$GREP 'ENTRY_PROG:' prog.c], [0], ignore, []) AT_CHECK([$GREP 'SECTION_END__PROC:' prog.c], [0], ignore, []) -AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [bluBb], []) +AT_CHECK([$GREP 'PARAGRAPH_00_l_4:' prog.c], [0], ignore, []) +AT_CHECK([$GREP 'PARAGRAPH_EX_l_7:' prog.c], [0], ignore, []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [bluBb END], []) +AT_CHECK([$COBC -I sub/copy prog.cob -ext=cpy -o prog.i -MF prog.d -MT "prog.c prog.h" -MT prog$COB_EXE_EXT -MT prog.$COB_OBJECT_EXT -MT prog.i -fsyntax-only], [0], [], []) +AT_CHECK([$GREP 'prog.c prog.h ' prog.d], [0], ignore, []) +AT_CHECK([$GREP ' prog.i:' prog.d], [0], ignore, []) +AT_CHECK([$GREP 'sub/copy/PROC.cpy' prog.d], [0], ignore, []) +AT_CHECK([$GREP 'sub/PROCE.cpy' prog.d], [0], ignore, []) + AT_CLEANUP @@ -757,7 +771,8 @@ AT_CHECK([$COBCRUN ThisIsANameThatIsReallyNotAllowedAsProgIdInCOBOL], [1], [], # it would be allowed for preloading # this was previously checked in cobcrun, now only done in the runtime AT_CHECK([$COBCRUN -q -M ThisIsANameThatIsReallyNotAllowedAsProgIdInCOBOL noprog], [1], [], -[libcob: error: module 'noprog' not found +[libcob: warning: preloading of 'ThisIsANameThatIsReallyNotAllowedAsProgIdInCOBOL' failed +libcob: error: module 'noprog' not found ]) AT_CLEANUP