diff --git a/cobc/ChangeLog b/cobc/ChangeLog index bab8121b3..50fbd7507 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,8 +1,16 @@ +2024-07-10 Chuck Haatvedt + + * tree.c (cb_build_picture): fixed currency scale counting logic + 2024-06-19 David Declerck * cobc.c (process_compile): fix MSVC build command +2024-06-11 Chuck Haatvedt + + * tree.c (cb_build_picture): fixed currency digit counting logic + 2024-05-15 Simon Sobisch * replace.c: fix compile warnings and formatting diff --git a/cobc/tree.c b/cobc/tree.c index a49d8aaf0..c4df8cdf0 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -3797,11 +3797,17 @@ cb_build_picture (const char *str) category |= PIC_NUMERIC_EDITED; if (c_count == 0) { digits += n - 1; - c_count = n - 1; } else { digits += n; - c_count += n; } + if (v_count) { + if (c_count == 0) { + scale += n - 1; + } else { + scale += n; + } + } + c_count += n; break; } diff --git a/config/ChangeLog b/config/ChangeLog index 89dab2d0d..e31460947 100644 --- a/config/ChangeLog +++ b/config/ChangeLog @@ -1,4 +1,8 @@ +2024-07-11 David Declerck + + * general: fix minor alignment / tab issues + 2024-05-02 Simon Sobisch fixing bug #965 diff --git a/config/acu-strict.conf b/config/acu-strict.conf index f1f521602..2b9e45b17 100644 --- a/config/acu-strict.conf +++ b/config/acu-strict.conf @@ -34,11 +34,11 @@ tab-width: 8 text-column: 72 word-length: 60 literal-length: 4096 -numeric-literal-length: 31 # default in ACUCOBOL is 18 with the possibility to switch to 31 -pic-length: 100 +numeric-literal-length: 31 # default in ACUCOBOL is 18 with the possibility to switch to 31 +pic-length: 100 # Enable AREACHECK by default, for reference formats other than {fixed,free} -areacheck: no #not verified yet +areacheck: no # not verified yet # Default assign type # Value: 'dynamic', 'external' @@ -88,7 +88,7 @@ indirect-redefines: yes # 15 - 16 15 - 16 7 # 17 - 18 17 - 18 8 # -binary-size: 1-2-4-8 # not verified yet +binary-size: 1-2-4-8 # not verified yet # Numeric truncation according to ANSI binary-truncate: yes @@ -98,7 +98,7 @@ binary-truncate: yes binary-byteorder: big-endian # Allow larger REDEFINES items other than 01 non-external -larger-redefines: ok # not verified yet +larger-redefines: ok # not verified yet # Allow certain syntax variations (eg. REDEFINES position) relax-syntax-checks: yes @@ -121,28 +121,28 @@ move-ibm: no select-working: yes # LOCAL-STORAGE SECTION implies RECURSIVE attribute -local-implies-recursive: no +local-implies-recursive: no # If yes, LINKAGE SECTION items remain allocated # between invocations. sticky-linkage: no # If yes, allow non-matching level numbers -relax-level-hierarchy: no # not verified yet +relax-level-hierarchy: no # not verified yet # If yes, evaluate constant expressions at compile time constant-folding: no # Allow Hex 'F' for NUMERIC test of signed PACKED DECIMAL field -hostsign: no # not verified yet +hostsign: no # not verified yet # If yes, set WITH UPDATE clause as default for ACCEPT dest-item, # except if WITH NO UPDATE clause is used -accept-update: no # not verified yet +accept-update: no # not verified yet # If yes, set WITH AUTO clause as default for ACCEPT dest-item, # except if WITH TAB clause is used -accept-auto: no # not verified yet +accept-auto: no # not verified yet # If yes, DISPLAYs and ACCEPTs are, by default, done on the CRT (i.e., using # curses). @@ -194,59 +194,59 @@ xml-parse-xmlss: no # always in COMPAT screen-section-rules: acu # Whether DECIMAL-POINT IS COMMA has effect in XML/JSON GENERATE -dpc-in-data: xml # verify +dpc-in-data: xml # verify # Bounds against which to check subscripts (full, max, record) subscript-check: max # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: no +init-justify: no # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' alter-statement: obsolete -comment-paragraphs: obsolete # not verified yet +comment-paragraphs: obsolete # not verified yet partial-replace-when-literal-src: ok control-division: unconformable call-overflow: ok -data-records-clause: obsolete # not verified yet +data-records-clause: obsolete # not verified yet debugging-mode: ok use-for-debugging: unconformable -listing-statements: skip # only available in IBM mode -title-statement: skip # not available but a reserved word in acu +listing-statements: skip # only available in IBM mode +title-statement: skip # not available but a reserved word in acu entry-statement: ok -goto-statement-without-name: obsolete # not verified yet -label-records-clause: obsolete # not verified yet -memory-size-clause: obsolete # not verified yet -move-noninteger-to-alphanumeric: error # not verified yet +goto-statement-without-name: obsolete # not verified yet +label-records-clause: obsolete # not verified yet +memory-size-clause: obsolete # not verified yet +move-noninteger-to-alphanumeric: error # not verified yet move-figurative-constant-to-numeric: ok move-figurative-space-to-numeric: ok move-figurative-quote-to-numeric: ok -multiple-file-tape-clause: obsolete # not verified yet +multiple-file-tape-clause: obsolete # not verified yet next-sentence-phrase: ok -odo-without-to: ok # not verified yet -padding-character-clause: obsolete # not verified yet -section-segments: ignore # not verified yet -stop-literal-statement: obsolete # not verified yet +odo-without-to: ok # not verified yet +padding-character-clause: obsolete # not verified yet +section-segments: ignore # not verified yet +stop-literal-statement: obsolete # not verified yet stop-identifier-statement: unconformable stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable -usage-type: unconformable +usage-type: unconformable synchronized-clause: ok sync-left-right: skip special-names-clause: ok top-level-occurs-clause: ok -value-of-clause: obsolete # not verified yet +value-of-clause: obsolete # not verified yet numeric-boolean: unconformable hexadecimal-boolean: unconformable national-literals: unconformable hexadecimal-national-literals: unconformable national-character-literals: unconformable # TO-DO: Add separate config option for H"..." to be unsupported,numeric,non-numeric(acu) -acu-literals: ok +acu-literals: ok hp-octal-literals: unconformable ebcdic-symbolic-characters: no word-continuation: ok @@ -258,7 +258,7 @@ constant-78: ok constant-01: unconformable perform-varying-without-by: unconformable program-prototypes: unconformable -numeric-value-for-edited-item: error # not verified yet +numeric-value-for-edited-item: error # not verified yet reference-out-of-declaratives: ok call-convention-mnemonic: unconformable call-convention-linkage: unconformable @@ -266,13 +266,13 @@ using-optional: unconformable incorrect-conf-sec-order: error define-constant-directive: unconformable free-redefines-position: unconformable -records-mismatch-record-clause error # not verified yet +records-mismatch-record-clause: error # not verified yet record-delimiter: ignore sequential-delimiters: unconformable record-delim-with-fixed-recs: ok -missing-statement: ok # gets a warning in some places but not in PERFORM -missing-period: warning #when format not in {fixed,free} -zero-length-literals: unconformable # not verified yet +missing-statement: ok # gets a warning in some places but not in PERFORM +missing-period: warning # when format not in {fixed,free} +zero-length-literals: unconformable # not verified yet xml-generate-extra-phrases: unconformable continue-after: unconformable goto-entry: unconformable @@ -281,9 +281,9 @@ assign-using-variable: unconformable assign-ext-dyn: ok assign-disk-from: unconformable vsam-status: ignore -self-call-recursive: skip +self-call-recursive: skip record-contains-depending-clause: unconformable -defaultbyte: " " +defaultbyte: " " picture-l: unconformable # use fixed word list, synonyms and exceptions specified there diff --git a/config/bs2000-strict.conf b/config/bs2000-strict.conf index 4db799012..2c0a1fae8 100644 --- a/config/bs2000-strict.conf +++ b/config/bs2000-strict.conf @@ -35,8 +35,8 @@ format: cobol85 tab-width: 8 text-column: 72 word-length: 31 -literal-length: 180 # TO-DO: Check max hex string length is 360. -numeric-literal-length: 31 # TO-DO: Different rules for exponent-format floating-point literals. +literal-length: 180 # TO-DO: Check max hex string length is 360. +numeric-literal-length: 31 # TO-DO: Different rules for exponent-format floating-point literals. pic-length: 50 # Enable AREACHECK by default, for reference formats other than {fixed,free} @@ -55,7 +55,7 @@ assign-clause: external # 4. the literal "DATAFILE" # If no, the value of the assign clause is the file name. # -filename-mapping: yes # probably +filename-mapping: yes # probably # Alternate formatting of numeric fields pretty-display: no @@ -93,7 +93,7 @@ indirect-redefines: no binary-size: 2-4-8 # Numeric truncation according to ANSI -binary-truncate: yes # TO-DO: For BINARY, *not* for COMP or COMP-5! +binary-truncate: yes # TO-DO: For BINARY, *not* for COMP or COMP-5! # Binary byte order # Value: 'native', 'big-endian' @@ -114,7 +114,7 @@ ref-mod-zero-length: no perform-osvs: no # Compute intermediate decimal results like IBM OSVS -arithmetic-osvs: no # TO-DO: Maybe, but if intermediate item has more than 31 places, floating-point arithmetic is used. +arithmetic-osvs: no # TO-DO: Maybe, but if intermediate item has more than 31 places, floating-point arithmetic is used. # MOVE like IBM (mvc); left to right, byte by byte move-ibm: no @@ -123,11 +123,11 @@ move-ibm: no select-working: no # LOCAL-STORAGE SECTION implies RECURSIVE attribute -local-implies-recursive: no # not verified yet +local-implies-recursive: no # not verified yet # If yes, LINKAGE SECTION items remain allocated # between invocations. -sticky-linkage: no # TO-DO: Check! +sticky-linkage: no # TO-DO: Check! # If yes, allow non-matching level numbers relax-level-hierarchy: no @@ -186,7 +186,7 @@ implicit-assign-dynamic-var: no device-mnemonics: no # full clauses in XML PARSE - and adjusted XML-EVENTs -xml-parse-xmlss: no # only XMLPARSE"COMPAT" way +xml-parse-xmlss: no # only XMLPARSE"COMPAT" way # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -195,10 +195,10 @@ screen-section-rules: std dpc-in-data: xml # Bounds against which to check subscripts (full, max, record) -subscript-check: max # not verified, may need "record" +subscript-check: max # not verified, may need "record" # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: no +init-justify: no # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', @@ -207,7 +207,7 @@ init-justify: no alter-statement: obsolete comment-paragraphs: unconformable control-division: unconformable -partial-replace-when-literal-src: unconformable # not verified yet +partial-replace-when-literal-src: unconformable # not verified yet call-overflow: ok data-records-clause: obsolete debugging-mode: ok @@ -232,10 +232,10 @@ stop-identifier-statement: unconformable stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable # TYPEDEF is reserved but unused -usage-type: unconformable +usage-type: unconformable synchronized-clause: ok sync-left-right: skip -special-names-clause: error # not verified yet +special-names-clause: error # not verified yet top-level-occurs-clause: unconformable value-of-clause: obsolete numeric-boolean: unconformable @@ -258,17 +258,17 @@ reference-out-of-declaratives: error program-prototypes: unconformable call-convention-mnemonic: unconformable call-convention-linkage: unconformable -using-optional: unconformable +using-optional: unconformable numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: unconformable free-redefines-position: unconformable -records-mismatch-record-clause error # not verified yet +records-mismatch-record-clause: error # not verified yet record-delimiter: ignore sequential-delimiters: unconformable record-delim-with-fixed-recs: unconformable missing-statement: warning # not verified yet -missing-period: error #when format not in {fixed,free}, not verified yet +missing-period: error # when format not in {fixed,free}, not verified yet zero-length-literals: unconformable xml-generate-extra-phrases: unconformable continue-after: unconformable @@ -278,9 +278,9 @@ assign-using-variable: ok assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: ok -self-call-recursive: skip +self-call-recursive: skip record-contains-depending-clause: unconformable -defaultbyte: 0 # not verified yet, but likely to be as IBM +defaultbyte: 0 # not verified yet, but likely to be as IBM picture-l: unconformable # use fixed word list, synonyms and exceptions specified there diff --git a/config/cobol2002.conf b/config/cobol2002.conf index 1943f9218..6548f790c 100644 --- a/config/cobol2002.conf +++ b/config/cobol2002.conf @@ -34,8 +34,8 @@ tab-width: 8 text-column: 72 word-length: 31 literal-length: 160 -numeric-literal-length: 31 -pic-length: 50 +numeric-literal-length: 31 +pic-length: 50 # Enable AREACHECK by default, for reference formats other than {fixed,free} areacheck: no @@ -119,10 +119,10 @@ arithmetic-osvs: no move-ibm: no # SELECT RELATIVE KEY and ASSIGN fields must be in WORKING-STORAGE -select-working: no +select-working: no # LOCAL-STORAGE SECTION implies RECURSIVE attribute -local-implies-recursive: no +local-implies-recursive: no # If yes, LINKAGE SECTION items remain allocated # between invocations. @@ -185,7 +185,7 @@ implicit-assign-dynamic-var: no device-mnemonics: no # full clauses in XML PARSE - and adjusted XML-EVENTs -xml-parse-xmlss: no # not supported at all +xml-parse-xmlss: no # not supported at all # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -197,7 +197,7 @@ dpc-in-data: xml subscript-check: full # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: no +init-justify: no # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', @@ -211,8 +211,8 @@ call-overflow: archaic data-records-clause: unconformable debugging-mode: obsolete use-for-debugging: unconformable -listing-statements: skip # may be a user-defined word -title-statement: skip # may be a user-defined word +listing-statements: skip # may be a user-defined word +title-statement: skip # may be a user-defined word entry-statement: unconformable goto-statement-without-name: unconformable label-records-clause: unconformable @@ -231,7 +231,7 @@ stop-identifier-statement: unconformable stop-error-statement: unconformable same-as-clause: ok type-to-clause: ok -usage-type: unconformable +usage-type: unconformable synchronized-clause: ok sync-left-right: ok special-names-clause: error @@ -242,7 +242,7 @@ hexadecimal-boolean: ok national-literals: ok hexadecimal-national-literals: ok national-character-literals: unconformable -acu-literals: unconformable +acu-literals: unconformable hp-octal-literals: unconformable ebcdic-symbolic-characters: no word-continuation: archaic @@ -257,17 +257,17 @@ reference-out-of-declaratives: error program-prototypes: ok call-convention-mnemonic: unconformable call-convention-linkage: unconformable -using-optional: ok +using-optional: ok numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: error free-redefines-position: unconformable -records-mismatch-record-clause error +records-mismatch-record-clause: error record-delimiter: ok sequential-delimiters: ok record-delim-with-fixed-recs: unconformable missing-statement: error -missing-period: error #when format not in {fixed,free} +missing-period: error # when format not in {fixed,free} zero-length-literals: unconformable xml-generate-extra-phrases: unconformable continue-after: unconformable @@ -277,9 +277,9 @@ assign-using-variable: ok assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: unconformable -self-call-recursive: skip +self-call-recursive: skip record-contains-depending-clause: unconformable -defaultbyte: none # initial storage is undefined +defaultbyte: none # initial storage is undefined picture-l: unconformable # archaic in COBOL2002 and currently not available as dialect features: diff --git a/config/cobol2014.conf b/config/cobol2014.conf index c24530200..7f1492468 100644 --- a/config/cobol2014.conf +++ b/config/cobol2014.conf @@ -34,8 +34,8 @@ tab-width: 8 text-column: 72 word-length: 31 literal-length: 8191 -numeric-literal-length: 31 -pic-length: 63 +numeric-literal-length: 31 +pic-length: 63 # Enable AREACHECK by default, for reference formats other than {fixed,free} areacheck: no @@ -119,10 +119,10 @@ arithmetic-osvs: no move-ibm: no # SELECT RELATIVE KEY and ASSIGN fields must be in WORKING-STORAGE -select-working: no +select-working: no # LOCAL-STORAGE SECTION implies RECURSIVE attribute -local-implies-recursive: no +local-implies-recursive: no # If yes, LINKAGE SECTION items remain allocated # between invocations. @@ -185,7 +185,7 @@ implicit-assign-dynamic-var: yes device-mnemonics: no # full clauses in XML PARSE - and adjusted XML-EVENTs -xml-parse-xmlss: no # not supported at all +xml-parse-xmlss: no # not supported at all # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -197,7 +197,7 @@ dpc-in-data: xml subscript-check: full # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: no +init-justify: no # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', @@ -211,8 +211,8 @@ call-overflow: archaic data-records-clause: unconformable debugging-mode: unconformable use-for-debugging: unconformable -listing-statements: skip # may be a user-defined word -title-statement: skip # may be a user-defined word +listing-statements: skip # may be a user-defined word +title-statement: skip # may be a user-defined word entry-statement: unconformable goto-statement-without-name: unconformable label-records-clause: unconformable @@ -232,7 +232,7 @@ stop-identifier-statement: unconformable stop-error-statement: unconformable same-as-clause: ok type-to-clause: ok -usage-type: unconformable +usage-type: unconformable synchronized-clause: ok sync-left-right: ok special-names-clause: error @@ -243,7 +243,7 @@ hexadecimal-boolean: ok national-literals: ok hexadecimal-national-literals: ok national-character-literals: unconformable -acu-literals: unconformable +acu-literals: unconformable hp-octal-literals: unconformable word-continuation: archaic ebcdic-symbolic-characters: no @@ -257,17 +257,17 @@ reference-out-of-declaratives: error program-prototypes: ok call-convention-mnemonic: unconformable call-convention-linkage: unconformable -using-optional: ok +using-optional: ok numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: error free-redefines-position: unconformable -records-mismatch-record-clause error +records-mismatch-record-clause: error record-delimiter: ok sequential-delimiters: ok record-delim-with-fixed-recs: unconformable missing-statement: error -missing-period: error #when format not in {fixed,free} +missing-period: error # when format not in {fixed,free} zero-length-literals: ok xml-generate-extra-phrases: unconformable continue-after: unconformable @@ -277,9 +277,9 @@ assign-using-variable: ok assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: unconformable -self-call-recursive: skip +self-call-recursive: skip record-contains-depending-clause: unconformable -defaultbyte: none # initial storage is undefined +defaultbyte: none # initial storage is undefined picture-l: unconformable # use fixed word list, synonyms and exceptions specified there diff --git a/config/cobol85.conf b/config/cobol85.conf index dd9ed5e66..f05669281 100644 --- a/config/cobol85.conf +++ b/config/cobol85.conf @@ -34,8 +34,8 @@ tab-width: 8 text-column: 72 word-length: 30 literal-length: 160 -numeric-literal-length: 18 -pic-length: 30 +numeric-literal-length: 18 +pic-length: 30 # Enable AREACHECK by default, for reference formats other than {fixed,free} areacheck: yes @@ -119,10 +119,10 @@ arithmetic-osvs: no move-ibm: no # SELECT RELATIVE KEY and ASSIGN fields must be in WORKING-STORAGE -select-working: no +select-working: no # LOCAL-STORAGE SECTION implies RECURSIVE attribute -local-implies-recursive: no +local-implies-recursive: no # If yes, LINKAGE SECTION items remain allocated # between invocations. @@ -132,7 +132,7 @@ sticky-linkage: no relax-level-hierarchy: no # If yes, evaluate constant expressions at compile time -constant-folding: yes # we may set this to "no" for "old compilers" +constant-folding: yes # we may set this to "no" for "old compilers" # Allow Hex 'F' for NUMERIC test of signed PACKED DECIMAL field hostsign: no @@ -185,7 +185,7 @@ implicit-assign-dynamic-var: yes device-mnemonics: no # full clauses in XML PARSE - and adjusted XML-EVENTs -xml-parse-xmlss: no # not supported at all +xml-parse-xmlss: no # not supported at all # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -197,7 +197,7 @@ dpc-in-data: xml subscript-check: full # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: no +init-justify: no # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', @@ -211,8 +211,8 @@ call-overflow: ok data-records-clause: obsolete debugging-mode: ok use-for-debugging: obsolete -listing-statements: skip # may be a user-defined word -title-statement: skip # may be a user-defined word +listing-statements: skip # may be a user-defined word +title-statement: skip # may be a user-defined word entry-statement: unconformable goto-statement-without-name: obsolete label-records-clause: obsolete @@ -231,9 +231,9 @@ stop-identifier-statement: unconformable stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable -usage-type: unconformable +usage-type: unconformable synchronized-clause: skip -sync-left-right: ok # TODO: verify +sync-left-right: ok # TODO: verify special-names-clause: error top-level-occurs-clause: unconformable value-of-clause: obsolete @@ -242,7 +242,7 @@ hexadecimal-boolean: unconformable national-literals: unconformable hexadecimal-national-literals: unconformable national-character-literals: unconformable -acu-literals: unconformable +acu-literals: unconformable hp-octal-literals: unconformable ebcdic-symbolic-characters: no word-continuation: ok @@ -253,21 +253,21 @@ symbolic-constant: unconformable constant-78: unconformable constant-01: unconformable perform-varying-without-by: unconformable -reference-out-of-declaratives: error # not verified yet +reference-out-of-declaratives: error # not verified yet program-prototypes: unconformable call-convention-mnemonic: unconformable call-convention-linkage: unconformable -using-optional: unconformable +using-optional: unconformable numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: error free-redefines-position: unconformable -records-mismatch-record-clause error +records-mismatch-record-clause: error record-delimiter: ok sequential-delimiters: ok record-delim-with-fixed-recs: unconformable missing-statement: error -missing-period: error #when format not in {fixed,free} +missing-period: error # when format not in {fixed,free} zero-length-literals: unconformable xml-generate-extra-phrases: unconformable continue-after: unconformable @@ -277,9 +277,9 @@ assign-using-variable: unconformable assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: unconformable -self-call-recursive: skip +self-call-recursive: skip record-contains-depending-clause: unconformable -defaultbyte: none # initial storage is undefined +defaultbyte: none # initial storage is undefined picture-l: unconformable # obsolete in COBOL85 and currently not available as dialect features: diff --git a/config/default.conf b/config/default.conf index 2bb1f985c..c4510e71c 100644 --- a/config/default.conf +++ b/config/default.conf @@ -139,10 +139,10 @@ arithmetic-osvs: no move-ibm: no # SELECT RELATIVE KEY and ASSIGN fields must be in WORKING-STORAGE -select-working: no +select-working: no # LOCAL-STORAGE SECTION implies RECURSIVE attribute -local-implies-recursive: no +local-implies-recursive: no # If yes, LINKAGE SECTION items remain allocated # between invocations. @@ -202,7 +202,7 @@ move-non-numeric-lit-to-numeric-is-zero: no implicit-assign-dynamic-var: yes # If yes, ACCEPT and DISPLAY statements accept device names using mnemonics -device-mnemonics: no +device-mnemonics: no # full clauses in XML PARSE - and adjusted XML-EVENTs xml-parse-xmlss: yes @@ -217,7 +217,7 @@ dpc-in-data: xml subscript-check: full # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: no +init-justify: no # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', @@ -231,8 +231,8 @@ call-overflow: archaic data-records-clause: obsolete debugging-mode: ok use-for-debugging: ok -listing-statements: skip # may be a user-defined word -title-statement: skip # may be a user-defined word +listing-statements: skip # may be a user-defined word +title-statement: skip # may be a user-defined word entry-statement: ok goto-statement-without-name: obsolete label-records-clause: obsolete @@ -251,9 +251,9 @@ stop-identifier-statement: obsolete stop-error-statement: unconformable same-as-clause: ok type-to-clause: ok -usage-type: ok +usage-type: ok synchronized-clause: ok -sync-left-right: ok # TODO: implement, now raises PENDING warning +sync-left-right: ok # TODO: implement, now raises PENDING warning special-names-clause: ok top-level-occurs-clause: ok value-of-clause: obsolete @@ -278,17 +278,17 @@ reference-out-of-declaratives: warning program-prototypes: ok call-convention-mnemonic: ok call-convention-linkage: ok -using-optional: ok +using-optional: ok numeric-value-for-edited-item: ok incorrect-conf-sec-order: ok define-constant-directive: archaic free-redefines-position: warning -records-mismatch-record-clause warning +records-mismatch-record-clause: warning record-delimiter: ok sequential-delimiters: ok record-delim-with-fixed-recs: ok missing-statement: warning -missing-period: warning #when format not in {fixed,free} +missing-period: warning # when format not in {fixed,free} zero-length-literals: ok xml-generate-extra-phrases: ok continue-after: ok @@ -298,10 +298,10 @@ assign-using-variable: ok assign-ext-dyn: ok assign-disk-from: ok vsam-status: ignore -self-call-recursive: warning +self-call-recursive: warning record-contains-depending-clause: unconformable -defaultbyte: init # GC inits as INITIALIZE ALL TO VALUE THEN TO DEFAULT, - # with INDEXED BY variables initialized to 1 +defaultbyte: init # GC inits as INITIALIZE ALL TO VALUE THEN TO DEFAULT, + # with INDEXED BY variables initialized to 1 picture-l: ok # use complete word list; synonyms and exceptions are specified below diff --git a/config/gcos-strict.conf b/config/gcos-strict.conf index 82acacf1c..558e673a0 100644 --- a/config/gcos-strict.conf +++ b/config/gcos-strict.conf @@ -22,7 +22,7 @@ name: "GCOS" # Value: enum (see default.conf and cobc/cobc.h for details) -standard-define 7 # Builds on COBOL-85 +standard-define 7 # Builds on COBOL-85 # Default source reference-format (see default.conf for details) format: cobol85 @@ -184,7 +184,7 @@ implicit-assign-dynamic-var: no device-mnemonics: yes # full clauses in XML PARSE - and adjusted XML-EVENTs -xml-parse-xmlss: no # not supported at all +xml-parse-xmlss: no # not supported at all # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -193,10 +193,10 @@ screen-section-rules: std dpc-in-data: xml # Bounds against which to check subscripts (full, max, record) -subscript-check: max # not verified, may need "record" +subscript-check: max # not verified, may need "record" # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: yes # TODO: verify +init-justify: yes # TODO: verify # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', @@ -205,7 +205,7 @@ init-justify: yes # TODO: verify alter-statement: obsolete comment-paragraphs: obsolete control-division: ok -partial-replace-when-literal-src: skip # i.e, do not replace if results in spaces only +partial-replace-when-literal-src: skip # i.e, do not replace if results in spaces only call-overflow: archaic data-records-clause: obsolete debugging-mode: ok @@ -256,7 +256,7 @@ reference-out-of-declaratives: error program-prototypes: unconformable call-convention-mnemonic: unconformable call-convention-linkage: unconformable -using-optional: unconformable +using-optional: unconformable numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: error @@ -266,7 +266,7 @@ record-delimiter: ok sequential-delimiters: ok record-delim-with-fixed-recs: unconformable missing-statement: error -missing-period: error # when format not in {fixed,free} +missing-period: error # when format not in {fixed,free} zero-length-literals: unconformable xml-generate-extra-phrases: unconformable continue-after: unconformable @@ -278,7 +278,7 @@ assign-disk-from: unconformable vsam-status: unconformable self-call-recursive: skip record-contains-depending-clause: obsolete -defaultbyte: 0 +defaultbyte: 0 picture-l: ok # use fixed word list, synonyms and exceptions specified there diff --git a/config/ibm-strict.conf b/config/ibm-strict.conf index 0d664d768..41c6b4727 100644 --- a/config/ibm-strict.conf +++ b/config/ibm-strict.conf @@ -27,15 +27,15 @@ name: "IBM COBOL" standard-define 2 # Default source reference-format (see default.conf for details) -format: cobol85 # CHECKME +format: cobol85 # CHECKME # Value: int tab-width: 8 text-column: 72 word-length: 30 literal-length: 160 -numeric-literal-length: 31 # for ARITH(EXTENDED), otherwise 18 -pic-length: 50 +numeric-literal-length: 31 # for ARITH(EXTENDED), otherwise 18 +pic-length: 50 # Enable AREACHECK by default, for reference formats other than {fixed,free} areacheck: yes @@ -121,7 +121,7 @@ move-ibm: yes select-working: no # LOCAL-STORAGE SECTION implies RECURSIVE attribute -local-implies-recursive: no +local-implies-recursive: no # If yes, LINKAGE SECTION items remain allocated # between invocations. @@ -131,18 +131,18 @@ sticky-linkage: yes relax-level-hierarchy: yes # If yes, evaluate constant expressions at compile time -constant-folding: yes # not verified yet +constant-folding: yes # not verified yet # Allow Hex 'F' for NUMERIC test of signed PACKED DECIMAL field hostsign: yes # If yes, set WITH UPDATE clause as default for ACCEPT dest-item, # except if WITH NO UPDATE clause is used -accept-update: no # not verified yet +accept-update: no # not verified yet # If yes, set WITH AUTO clause as default for ACCEPT dest-item, # except if WITH TAB clause is used -accept-auto: no # not verified yet +accept-auto: no # not verified yet # If yes, DISPLAYs and ACCEPTs are, by default, done on the CRT (i.e., using # curses). @@ -193,10 +193,10 @@ screen-section-rules: std dpc-in-data: xml # Bounds against which to check subscripts (full, max, record) -subscript-check: max # TODO: "record" +subscript-check: max # TODO: "record" # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: yes +init-justify: yes # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', @@ -231,7 +231,7 @@ stop-identifier-statement: unconformable stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable -usage-type: unconformable +usage-type: unconformable synchronized-clause: ok sync-left-right: skip special-names-clause: error @@ -242,7 +242,7 @@ hexadecimal-boolean: unconformable national-literals: ok hexadecimal-national-literals: unconformable national-character-literals: unconformable -acu-literals: unconformable +acu-literals: unconformable hp-octal-literals: unconformable ebcdic-symbolic-characters: no word-continuation: ok @@ -252,21 +252,21 @@ renames-uncommon-levels: unconformable constant-78: unconformable constant-01: unconformable perform-varying-without-by: unconformable -reference-out-of-declaratives: error # not verified yet +reference-out-of-declaratives: error # not verified yet program-prototypes: unconformable call-convention-mnemonic: unconformable call-convention-linkage: unconformable -using-optional: unconformable +using-optional: unconformable numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: unconformable free-redefines-position: unconformable -records-mismatch-record-clause ok # IBM: "if not matching use the record size" +records-mismatch-record-clause: ok # IBM: "if not matching use the record size" record-delimiter: ignore sequential-delimiters: unconformable record-delim-with-fixed-recs: unconformable missing-statement: warning # not verified yet -missing-period: warning #when format not in {fixed,free}, not verified yet +missing-period: warning # when format not in {fixed,free}, not verified yet zero-length-literals: unconformable xml-generate-extra-phrases: ok continue-after: unconformable @@ -276,9 +276,9 @@ assign-using-variable: unconformable assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: ok -self-call-recursive: skip +self-call-recursive: skip record-contains-depending-clause: unconformable -defaultbyte: 0 +defaultbyte: 0 picture-l: unconformable # use fixed word list, synonyms and exceptions specified there diff --git a/config/lax.conf-inc b/config/lax.conf-inc index b9475b27c..6f473d08d 100644 --- a/config/lax.conf-inc +++ b/config/lax.conf-inc @@ -88,9 +88,9 @@ stop-literal-statement: +obsolete stop-identifier-statement: ok same-as-clause: ok type-to-clause: ok -usage-type: ok +usage-type: ok synchronized-clause: +ignore -sync-left-right: +ignore # better use "skip" here? +sync-left-right: +ignore # better use "skip" here? special-names-clause: +warning top-level-occurs-clause: ok value-of-clause: +obsolete @@ -113,7 +113,7 @@ reference-out-of-declaratives: +warning program-prototypes: ok call-convention-mnemonic: ok call-convention-linkage: ok -using-optional: +warning +using-optional: +warning numeric-value-for-edited-item: +warning incorrect-conf-sec-order: +warning define-constant-directive: +obsolete diff --git a/config/mf-strict.conf b/config/mf-strict.conf index 4c0000f89..ee5d8b8fb 100644 --- a/config/mf-strict.conf +++ b/config/mf-strict.conf @@ -34,11 +34,11 @@ tab-width: 8 text-column: 72 # Maximum word-length for COBOL words / Programmer defined words # current max (COB_MAX_WORDLEN): 63 -#word-length: 127 +# word-length: 127 word-length: 63 literal-length: 8192 -numeric-literal-length: 18 -pic-length: 50 +numeric-literal-length: 18 +pic-length: 50 # Enable AREACHECK by default, for reference formats other than {fixed,free} areacheck: no @@ -124,7 +124,7 @@ move-ibm: no select-working: no # LOCAL-STORAGE SECTION implies RECURSIVE attribute -local-implies-recursive: yes +local-implies-recursive: yes # If yes, LINKAGE SECTION items remain allocated # between invocations. @@ -134,18 +134,18 @@ sticky-linkage: no relax-level-hierarchy: yes # If yes, evaluate constant expressions at compile time -constant-folding: yes # not verified yet +constant-folding: yes # not verified yet # Allow Hex 'F' for NUMERIC test of signed PACKED DECIMAL field hostsign: no # If yes, set WITH UPDATE clause as default for ACCEPT dest-item, # except if WITH NO UPDATE clause is used -accept-update: no # not verified yet +accept-update: no # not verified yet # If yes, set WITH AUTO clause as default for ACCEPT dest-item, # except if WITH TAB clause is used -accept-auto: no # not verified yet +accept-auto: no # not verified yet # If yes, DISPLAYs and ACCEPTs are, by default, done on the CRT (i.e., using # curses). @@ -199,7 +199,7 @@ dpc-in-data: xml subscript-check: max # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: no +init-justify: no # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', @@ -233,19 +233,19 @@ stop-identifier-statement: unconformable stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable # only supports USAGE type-name -usage-type: ok -synchronized-clause: skip # only active with IBMCOMP=OK (active with dialects IBM + RM) -sync-left-right: skip # commentary only +usage-type: ok +synchronized-clause: skip # only active with IBMCOMP=OK (active with dialects IBM + RM) +sync-left-right: skip # commentary only special-names-clause: error top-level-occurs-clause: ok value-of-clause: obsolete -numeric-boolean: ok # this can be changed by the BINLINT directive (default is NUMERIC=OK) -hexadecimal-boolean: unconformable +numeric-boolean: ok # this can be changed by the BINLINT directive (default is NUMERIC=OK) +hexadecimal-boolean: unconformable national-literals: ok hexadecimal-national-literals: ok national-character-literals: unconformable # TO-DO: Add separate config option for H"..." to be unsupported,numeric(rm/mf),non-numeric -acu-literals: unconformable +acu-literals: unconformable hp-octal-literals: unconformable ebcdic-symbolic-characters: no word-continuation: ok @@ -256,21 +256,21 @@ symbolic-constant: unconformable constant-78: ok constant-01: unconformable perform-varying-without-by: unconformable -reference-out-of-declaratives: warning # not verified yet +reference-out-of-declaratives: warning # not verified yet program-prototypes: ok call-convention-mnemonic: ok call-convention-linkage: unconformable -using-optional: ok +using-optional: ok numeric-value-for-edited-item: error incorrect-conf-sec-order: ok define-constant-directive: unconformable free-redefines-position: ok -records-mismatch-record-clause ok # follows IBM "if not matching use the record size" +records-mismatch-record-clause: ok # follows IBM "if not matching use the record size" record-delimiter: ok sequential-delimiters: ok record-delim-with-fixed-recs: ok -missing-statement: ok # according to tests, documentation partially disagrees -missing-period: warning # when format not in {fixed,free} +missing-statement: ok # according to tests, documentation partially disagrees +missing-period: warning # when format not in {fixed,free} zero-length-literals: unconformable xml-generate-extra-phrases: ok continue-after: unconformable @@ -280,9 +280,9 @@ assign-using-variable: unconformable assign-ext-dyn: ok assign-disk-from: ok vsam-status: ignore -self-call-recursive: skip +self-call-recursive: skip record-contains-depending-clause: unconformable -defaultbyte: " " +defaultbyte: " " picture-l: unconformable # use fixed word list, synonyms and exceptions specified there diff --git a/config/mvs-strict.conf b/config/mvs-strict.conf index 4f6034575..fe928cb75 100644 --- a/config/mvs-strict.conf +++ b/config/mvs-strict.conf @@ -27,15 +27,15 @@ name: "IBM COBOL for MVS & VM" standard-define 3 # Default source reference-format (see default.conf for details) -format: cobol85 # CHECKME +format: cobol85 # CHECKME # Value: int tab-width: 8 text-column: 72 -word-length: 30 # not verified yet -literal-length: 160 # not verified yet -numeric-literal-length: 18 # not verified yet -pic-length: 50 +word-length: 30 # not verified yet +literal-length: 160 # not verified yet +numeric-literal-length: 18 # not verified yet +pic-length: 50 # Enable AREACHECK by default, for reference formats other than {fixed,free} areacheck: yes @@ -121,7 +121,7 @@ move-ibm: yes select-working: no # LOCAL-STORAGE SECTION implies RECURSIVE attribute -local-implies-recursive: no +local-implies-recursive: no # If yes, LINKAGE SECTION items remain allocated # between invocations. @@ -131,18 +131,18 @@ sticky-linkage: yes relax-level-hierarchy: yes # If yes, evaluate constant expressions at compile time -constant-folding: yes # not verified yet +constant-folding: yes # not verified yet # Allow Hex 'F' for NUMERIC test of signed PACKED DECIMAL field hostsign: yes # If yes, set WITH UPDATE clause as default for ACCEPT dest-item, # except if WITH NO UPDATE clause is used -accept-update: no # not verified yet +accept-update: no # not verified yet # If yes, set WITH AUTO clause as default for ACCEPT dest-item, # except if WITH TAB clause is used -accept-auto: no # not verified yet +accept-auto: no # not verified yet # If yes, DISPLAYs and ACCEPTs are, by default, done on the CRT (i.e., using # curses). @@ -184,7 +184,7 @@ implicit-assign-dynamic-var: no device-mnemonics: yes # full clauses in XML PARSE - and adjusted XML-EVENTs -xml-parse-xmlss: no # not supported at all +xml-parse-xmlss: no # not supported at all # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -193,10 +193,10 @@ screen-section-rules: std dpc-in-data: xml # Bounds against which to check subscripts (full, max, record) -subscript-check: max # TODO: "record" +subscript-check: max # TODO: "record" # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: yes +init-justify: yes # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', @@ -206,7 +206,7 @@ alter-statement: obsolete comment-paragraphs: obsolete partial-replace-when-literal-src: unconformable control-division: unconformable -call-overflow: ok # not verified yet +call-overflow: ok # not verified yet data-records-clause: obsolete debugging-mode: ok use-for-debugging: obsolete @@ -217,7 +217,7 @@ goto-statement-without-name: obsolete label-records-clause: obsolete memory-size-clause: obsolete move-noninteger-to-alphanumeric: error -move-figurative-constant-to-numeric: error # not verified yet +move-figurative-constant-to-numeric: error # not verified yet move-figurative-space-to-numeric: error # not verified yet move-figurative-quote-to-numeric: error # not verified yet multiple-file-tape-clause: obsolete @@ -230,18 +230,18 @@ stop-identifier-statement: unconformable stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable -usage-type: unconformable +usage-type: unconformable special-names-clause: error synchronized-clause: ok sync-left-right: skip top-level-occurs-clause: unconformable value-of-clause: obsolete numeric-boolean: unconformable -hexadecimal-boolean: unconformable +hexadecimal-boolean: unconformable national-literals: unconformable hexadecimal-national-literals: unconformable national-character-literals: unconformable -acu-literals: unconformable +acu-literals: unconformable hp-octal-literals: unconformable ebcdic-symbolic-characters: no word-continuation: ok @@ -252,21 +252,21 @@ symbolic-constant: unconformable constant-78: ok constant-01: unconformable perform-varying-without-by: unconformable -reference-out-of-declaratives: error # not verified yet +reference-out-of-declaratives: error # not verified yet program-prototypes: unconformable call-convention-mnemonic: unconformable call-convention-linkage: unconformable -using-optional: unconformable +using-optional: unconformable numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: unconformable free-redefines-position: unconformable -records-mismatch-record-clause ok # not verified but IBM has "if not matching use the record size" +records-mismatch-record-clause: ok # not verified but IBM has "if not matching use the record size" record-delimiter: ignore sequential-delimiters: unconformable record-delim-with-fixed-recs: unconformable missing-statement: warning # not verified yet -missing-period: warning #when format not in {fixed,free}, not verified yet +missing-period: warning # when format not in {fixed,free}, not verified yet zero-length-literals: unconformable xml-generate-extra-phrases: unconformable continue-after: unconformable @@ -276,9 +276,9 @@ assign-using-variable: unconformable assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: ok -self-call-recursive: skip +self-call-recursive: skip record-contains-depending-clause: unconformable -defaultbyte: 0 # not verified yet, but likely to be as IBM +defaultbyte: 0 # not verified yet, but likely to be as IBM picture-l: unconformable # use fixed word list, synonyms and exceptions specified there diff --git a/config/realia-strict.conf b/config/realia-strict.conf index 6f4dfb901..1e40d19e1 100644 --- a/config/realia-strict.conf +++ b/config/realia-strict.conf @@ -24,25 +24,25 @@ name: "CA Realia II" # Value: enum (see default.conf and cobc/cobc.h for details) -standard-define 7 # Uses COBOL-85 currently +standard-define 7 # Uses COBOL-85 currently # Default source reference-format (see default.conf for details) -format: cobol85 # CHECKME +format: cobol85 # CHECKME # Value: int tab-width: 8 text-column: 72 -word-length: 60 # to check +word-length: 60 # to check literal-length: 160 -numeric-literal-length: 18 # to check -pic-length: 100 # to check +numeric-literal-length: 18 # to check +pic-length: 100 # to check # Enable AREACHECK by default, for reference formats other than {fixed,free} areacheck: yes # Default assign type # Value: 'dynamic', 'external' -assign-clause: dynamic # to check +assign-clause: dynamic # to check # If yes, file names are resolved at run time using # environment variables. @@ -53,7 +53,7 @@ assign-clause: dynamic # to check # 4. the literal "DATAFILE" # If no, the value of the assign clause is the file name. # -filename-mapping: yes # to check +filename-mapping: yes # to check # Alternate formatting of numeric fields pretty-display: yes @@ -91,17 +91,17 @@ indirect-redefines: no binary-size: 2-4-8 # Numeric truncation according to ANSI -binary-truncate: no # to check +binary-truncate: no # to check # Binary byte order # Value: 'native', 'big-endian' -binary-byteorder: big-endian # to check +binary-byteorder: big-endian # to check # Allow larger REDEFINES items other than 01 non-external -larger-redefines: error # not verified yet +larger-redefines: error # not verified yet # Allow certain syntax variations (eg. REDEFINES position) -relax-syntax-checks: no # to check +relax-syntax-checks: no # to check # Allow zero length reference-modification # (only checked with active EC-BOUND-REF-MOD) @@ -109,32 +109,32 @@ ref-mod-zero-length: no # Perform type OSVS - If yes, the exit point of any currently # executing perform is recognized if reached. -perform-osvs: no # to check +perform-osvs: no # to check # Compute intermediate decimal results like IBM OSVS -arithmetic-osvs: no # to check +arithmetic-osvs: no # to check # MOVE like IBM (mvc); left to right, byte by byte -move-ibm: no # to check +move-ibm: no # to check # SELECT RELATIVE KEY and ASSIGN fields must be in WORKING-STORAGE -select-working: yes # yes for ASSIGN, to check for RELATIVE KEY +select-working: yes # yes for ASSIGN, to check for RELATIVE KEY # LOCAL-STORAGE SECTION implies RECURSIVE attribute -local-implies-recursive: no +local-implies-recursive: no # If yes, LINKAGE SECTION items remain allocated # between invocations. sticky-linkage: no # If yes, allow non-matching level numbers -relax-level-hierarchy: no # not verified yet +relax-level-hierarchy: no # not verified yet # If yes, evaluate constant expressions at compile time constant-folding: no # Allow Hex 'F' for NUMERIC test of signed PACKED DECIMAL field -hostsign: no # not verified yet +hostsign: no # not verified yet # If yes, set WITH UPDATE clause as default for ACCEPT dest-item, # except if WITH NO UPDATE clause is used @@ -188,7 +188,7 @@ implicit-assign-dynamic-var: no device-mnemonics: no # full clauses in XML PARSE - and adjusted XML-EVENTs -xml-parse-xmlss: no # not supported at all +xml-parse-xmlss: no # not supported at all # What rules to apply to SCREEN SECTION items clauses screen-section-rules: xopen @@ -197,10 +197,10 @@ screen-section-rules: xopen dpc-in-data: xml # Bounds against which to check subscripts (full, max, record) -subscript-check: full # not verified yet +subscript-check: full # not verified yet # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: no +init-justify: no # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', @@ -208,8 +208,8 @@ init-justify: no alter-statement: obsolete comment-paragraphs: ok -control-division: unconformable # not verified yet -partial-replace-when-literal-src: unconformable # not verified yet +control-division: unconformable # not verified yet +partial-replace-when-literal-src: unconformable # not verified yet call-overflow: ok data-records-clause: ignore debugging-mode: unconformable @@ -220,12 +220,12 @@ entry-statement: ok goto-statement-without-name: ok label-records-clause: ok memory-size-clause: ignore -move-noninteger-to-alphanumeric: error # not verified yet -move-figurative-constant-to-numeric: ok # not verified yet -move-figurative-space-to-numeric: ok # not verified yte -move-figurative-quote-to-numeric: ok # not verified yet +move-noninteger-to-alphanumeric: error # not verified yet +move-figurative-constant-to-numeric: ok # not verified yet +move-figurative-space-to-numeric: ok # not verified yte +move-figurative-quote-to-numeric: ok # not verified yet multiple-file-tape-clause: ignore -next-sentence-phrase: archaic # not verified yet +next-sentence-phrase: archaic # not verified yet odo-without-to: unconformable padding-character-clause: ignore section-segments: unconformable @@ -234,10 +234,10 @@ stop-identifier-statement: unconformable stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable -usage-type: unconformable -special-names-clause: error # not verified yet +usage-type: unconformable +special-names-clause: error # not verified yet synchronized-clause: ok -sync-left-right: ignore # can raise a warning upon request +sync-left-right: ignore # can raise a warning upon request top-level-occurs-clause: unconformable value-of-clause: ignore numeric-boolean: unconformable @@ -257,22 +257,22 @@ symbolic-constant: unconformable constant-78: unconformable constant-01: unconformable perform-varying-without-by: unconformable -reference-out-of-declaratives: ok # not verified yet +reference-out-of-declaratives: ok # not verified yet program-prototypes: unconformable call-convention-mnemonic: unconformable call-convention-linkage: unconformable -using-optional: unconformable -numeric-value-for-edited-item: error # not verified yet +using-optional: unconformable +numeric-value-for-edited-item: error # not verified yet incorrect-conf-sec-order: error define-constant-directive: unconformable free-redefines-position: unconformable -records-mismatch-record-clause: error # not verified yet +records-mismatch-record-clause: error # not verified yet record-delimiter: ignore sequential-delimiters: unconformable record-delim-with-fixed-recs: error missing-statement: warning -missing-period: warning #when format not in {fixed,free}, not verified yet -zero-length-literals: unconformable # not verified yet +missing-period: warning # when format not in {fixed,free}, not verified yet +zero-length-literals: unconformable # not verified yet xml-generate-extra-phrases: unconformable continue-after: unconformable goto-entry: unconformable @@ -281,9 +281,9 @@ assign-using-variable: ok assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: ok -self-call-recursive: skip +self-call-recursive: skip record-contains-depending-clause: unconformable -defaultbyte: 0 # not verified, but likely like IBM +defaultbyte: 0 # not verified, but likely like IBM picture-l: unconformable # use fixed word list, synonyms and exceptions specified there diff --git a/config/rm-strict.conf b/config/rm-strict.conf index 4811394f9..0af678a73 100644 --- a/config/rm-strict.conf +++ b/config/rm-strict.conf @@ -27,18 +27,18 @@ name: "RM-COBOL" standard-define 6 # Default source reference-format (see default.conf for details) -format: cobol85 # CHECKME +format: cobol85 # CHECKME # TO-DO: Allow configuring WHEN-COMPILED date format (see p. 22). # Value: int -tab-width: 8 # not verified yet -text-column: 72 # TO-DO: add >>IMP MARGIN-R (see p. 50) +tab-width: 8 # not verified yet +text-column: 72 # TO-DO: add >>IMP MARGIN-R (see p. 50) # Maximum word-length for COBOL words / Programmer defined words # current max (COB_MAX_WORDLEN): 63 -#word-length: 240 +# word-length: 240 word-length: 63 -# external-word-length: 30 # TO-DO: Add! +# external-word-length: 30 # TO-DO: Add! literal-length: 65535 numeric-literal-length: 30 pic-length: 30 @@ -48,7 +48,7 @@ areacheck: yes # Default assign type # Value: 'dynamic', 'external' -assign-clause: dynamic # TO-DO: Verify +assign-clause: dynamic # TO-DO: Verify # If yes, file names are resolved at run time using # environment variables. @@ -71,7 +71,7 @@ complex-odo: yes odoslide: no # Allow REDEFINES to other than last equal level number -indirect-redefines: yes # "restriction removed in version 12+" +indirect-redefines: yes # "restriction removed in version 12+" # Binary byte size - defines the allocated bytes according to PIC # Value: signed unsigned bytes @@ -104,10 +104,10 @@ binary-truncate: yes binary-byteorder: big-endian # Allow larger REDEFINES items other than 01 non-external -larger-redefines: ok # (see p. 134) +larger-redefines: ok # (see p. 134) # Allow certain syntax variations (eg. REDEFINES position) -relax-syntax-checks: yes # TO-DO: For REDEFINES position, at least. +relax-syntax-checks: yes # TO-DO: For REDEFINES position, at least. # Allow zero length reference-modification # (only checked with active EC-BOUND-REF-MOD) @@ -115,7 +115,7 @@ ref-mod-zero-length: no # Perform type OSVS - If yes, the exit point of any currently # executing perform is recognized if reached. -perform-osvs: yes # according to MF docs; +perform-osvs: yes # according to MF docs; # CHECKME: R/M docs say (see p. 374) "Any potentially undefined (i.e. overlapping) PERFORMS prohibited" # Compute intermediate decimal results like IBM OSVS @@ -128,7 +128,7 @@ move-ibm: no select-working: no # LOCAL-STORAGE SECTION implies RECURSIVE attribute -local-implies-recursive: no +local-implies-recursive: no # If yes, LINKAGE SECTION items remain allocated # between invocations. @@ -138,7 +138,7 @@ sticky-linkage: yes relax-level-hierarchy: no # If yes, evaluate constant expressions at compile time -constant-folding: yes # not verified yet +constant-folding: yes # not verified yet # Allow Hex 'F' for NUMERIC test of signed PACKED DECIMAL field hostsign: no @@ -181,7 +181,7 @@ binary-comp-1: yes numeric-pointer: no # not verified yet # auto-adjust to zero like MicroFocus does -move-non-numeric-lit-to-numeric-is-zero: no # not verified yet +move-non-numeric-lit-to-numeric-is-zero: no # not verified yet # If yes, implicitly define a variable for an ASSIGN DYNAMIC which does not # match an existing data item. @@ -191,7 +191,7 @@ implicit-assign-dynamic-var: no device-mnemonics: no # full clauses in XML PARSE - and adjusted XML-EVENTs -xml-parse-xmlss: no # not supported at all +xml-parse-xmlss: no # not supported at all # What rules to apply to SCREEN SECTION items clauses screen-section-rules: rm @@ -203,7 +203,7 @@ dpc-in-data: xml subscript-check: max # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: no +init-justify: no # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', @@ -212,19 +212,19 @@ init-justify: no alter-statement: obsolete comment-paragraphs: obsolete control-division: unconformable -partial-replace-when-literal-src: unconformable # not verified yet +partial-replace-when-literal-src: unconformable # not verified yet call-overflow: ok data-records-clause: obsolete debugging-mode: ok use-for-debugging: obsolete -listing-statements: skip # may be a user-defined word -title-statement: skip # may be a user-defined word +listing-statements: skip # may be a user-defined word +title-statement: skip # may be a user-defined word entry-statement: unconformable goto-statement-without-name: obsolete label-records-clause: obsolete memory-size-clause: obsolete move-noninteger-to-alphanumeric: error -move-figurative-constant-to-numeric: ok # not verified yet +move-figurative-constant-to-numeric: ok # not verified yet move-figurative-space-to-numeric: ok # not verified yet move-figurative-quote-to-numeric: ok # not verified yet multiple-file-tape-clause: obsolete @@ -237,8 +237,8 @@ stop-identifier-statement: ok stop-error-statement: unconformable same-as-clause: ok type-to-clause: unconformable -usage-type: unconformable -special-names-clause: error # not verified yet +usage-type: unconformable +special-names-clause: error # not verified yet synchronized-clause: ok sync-left-right: ok top-level-occurs-clause: unconformable @@ -249,7 +249,7 @@ national-literals: unconformable hexadecimal-national-literals: unconformable national-character-literals: unconformable # TO-DO: Add separate config option for H"..." to be unsupported,numeric(rm/mf),non-numeric -acu-literals: unconformable +acu-literals: unconformable hp-octal-literals: unconformable ebcdic-symbolic-characters: no word-continuation: ok @@ -260,11 +260,11 @@ symbolic-constant: unconformable constant-78: ok constant-01: unconformable perform-varying-without-by: unconformable -reference-out-of-declaratives: error # TO-DO: error when referring to non-USE-statement DECLARATIVE sections +reference-out-of-declaratives: error # TO-DO: error when referring to non-USE-statement DECLARATIVE sections program-prototypes: unconformable call-convention-mnemonic: unconformable call-convention-linkage: unconformable -using-optional: unconformable +using-optional: unconformable numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: unconformable @@ -274,7 +274,7 @@ record-delimiter: ok sequential-delimiters: ok record-delim-with-fixed-recs: ok missing-statement: warning # not verified yet -missing-period: warning #when format not in {fixed,free}, not verified yet +missing-period: warning # when format not in {fixed,free}, not verified yet zero-length-literals: unconformable xml-generate-extra-phrases: unconformable continue-after: unconformable @@ -284,9 +284,9 @@ assign-using-variable: unconformable assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: unconformable -self-call-recursive: skip +self-call-recursive: skip record-contains-depending-clause: unconformable -defaultbyte: " " # not verified, but possibly like ACU/MF +defaultbyte: " " # not verified, but possibly like ACU/MF picture-l: unconformable # obsolete in COBOL85 and currently not available as dialect features: diff --git a/config/xopen.conf b/config/xopen.conf index 22b2a1451..8bb576113 100644 --- a/config/xopen.conf +++ b/config/xopen.conf @@ -46,8 +46,8 @@ tab-width: 8 text-column: 72 word-length: 30 literal-length: 160 -numeric-literal-length: 18 -pic-length: 30 +numeric-literal-length: 18 +pic-length: 30 # Enable AREACHECK by default, for reference formats other than {fixed,free} areacheck: yes @@ -132,10 +132,10 @@ arithmetic-osvs: no move-ibm: no # SELECT RELATIVE KEY and ASSIGN fields must be in WORKING-STORAGE -select-working: no +select-working: no # LOCAL-STORAGE SECTION implies RECURSIVE attribute -local-implies-recursive: no +local-implies-recursive: no # If yes, LINKAGE SECTION items remain allocated # between invocations. @@ -198,7 +198,7 @@ implicit-assign-dynamic-var: no device-mnemonics: no # full clauses in XML PARSE - and adjusted XML-EVENTs -xml-parse-xmlss: no # not supported at all +xml-parse-xmlss: no # not supported at all # What rules to apply to SCREEN SECTION items clauses screen-section-rules: xopen @@ -210,7 +210,7 @@ dpc-in-data: xml subscript-check: full # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: no +init-justify: no # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', @@ -228,15 +228,15 @@ control-division: unconformable call-overflow: ok data-records-clause: warning # should not be used ... debugging-mode: ok -use-for-debugging: unconformable # complete module removed -listing-statements: skip # may be a user-defined word -title-statement: skip # may be a user-defined word +use-for-debugging: unconformable # complete module removed +listing-statements: skip # may be a user-defined word +title-statement: skip # may be a user-defined word entry-statement: unconformable goto-statement-without-name: warning # should not be used ... label-records-clause: warning # should not be used ... memory-size-clause: warning # should not be used ... move-noninteger-to-alphanumeric: error -move-figurative-constant-to-numeric: archaic # not verified yet +move-figurative-constant-to-numeric: archaic # not verified yet move-figurative-space-to-numeric: error move-figurative-quote-to-numeric: archaic # not verified yet multiple-file-tape-clause: warning # should not be used ... @@ -250,7 +250,7 @@ stop-identifier-statement: unconformable stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable -usage-type: unconformable +usage-type: unconformable synchronized-clause: warning # should not be used ... will prevent portability sync-left-right: ok special-names-clause: error @@ -272,21 +272,21 @@ symbolic-constant: unconformable constant-78: unconformable constant-01: unconformable perform-varying-without-by: unconformable -reference-out-of-declaratives: error # not verified yet +reference-out-of-declaratives: error # not verified yet program-prototypes: unconformable call-convention-mnemonic: unconformable call-convention-linkage: unconformable -using-optional: unconformable +using-optional: unconformable numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: error free-redefines-position: unconformable -records-mismatch-record-clause error # actually the complete clause is excluded from X/Open... +records-mismatch-record-clause: error # actually the complete clause is excluded from X/Open... record-delimiter: warning # should not be used ... sequential-delimiters: ok record-delim-with-fixed-recs: unconformable missing-statement: error -missing-period: error #when format not in {fixed,free} +missing-period: error # when format not in {fixed,free} zero-length-literals: unconformable xml-generate-extra-phrases: unconformable continue-after: unconformable @@ -296,9 +296,9 @@ assign-using-variable: unconformable assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: unconformable -self-call-recursive: skip +self-call-recursive: skip record-contains-depending-clause: obsolete -defaultbyte: none # "not specifically defined in Standard COBOL" +defaultbyte: none # "not specifically defined in Standard COBOL" picture-l: unconformable # obsolete in COBOL85 and currently not available as dialect features: diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 00cd916fe..7fdcb3a72 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,83 @@ +2024-07-11 Chuck Haatvedt + + * screenio.c (cob_sys_scr_dump, cob_sys_scr_restore) fixed C90 warnings + +2024-07-11 Chuck Haatvedt + + * screenio.c (cob_sys_scr_dump, cob_sys_scr_restore) fixed C90 warnings + Also fixed issue when build without curses + * move.c (indirect_move) fixed C90 warnings + * profiling.c (profile_setup_clock) fixed C90 warnings + +2024-07-10 Chuck Haatvedt + + fix errors in cob_optimized_move_display_to_edited introduced + with changes at revision R5285. The errors showed up in the + NIST tests in group NC. + + * move.c (optimized_move_display_to_edited): fixed bugs + (indirect_move): fixed bug when calculating scale of + the intermediate cob field + + +2024-07-02 Chuck Haatvedt + + * numeric.c (cob_add_bcd) fixed check for default ROUNDED option + to resolve bug 934 + +2024-06-10 Chuck Haatvedt + + * screenio.c (cob_sys_scr_dump, cob_sys_scr_restore) added new functions + * common.h added exports for the two new functions + * system.def: added as system library call CBL_GC_SCR_DUMP, + CBL_GC_SCR_RESTORE + +2024-05-30 Chuck Haatvedt + + fix errors caught by the Sanitizer functionality of GCC. This + change did not resolve all of the issues found as some of them + were in Berkeley DB and some were intentional in the memory + corruption logic which has been implemented in the runtime. + + * move.c (the cob_move_display_to_packed function was rewritten to + fix the out of bounds memory addressing issues and also to make + the code simpler. + * numeric.c (the function count_leading_zeros was changed to fix + an out of bounds memory addressing issue + +2024-05-30 Chuck Haatvedt + + fix errors in filio.c when building with VISAM 2.2. This issue + occurred when using a partial key with a sequential read previous. + + * fileio.c (indexed_start_internal), (indexed_start) + and (indexed_read_next): added a new field, partial_key_length, + to the indexfile structure for use in these functions. + This will allow the saved partial key to be used in the + positioning logic. + Also the BDB logic was changed to return a status code of "35" + when encountering a missing directory for OUTPUT on INDEXED file. + +2024-05-30 Chuck Haatvedt + + fix errors in cob_move_display_to_edited and simplify the code + this was done by cloning the function to an optimized version + and making the changes to the calling functions to support it + Basically this involves changing the intermediate cob_field to + match the attributes of the target edited field instead of the + sending field. + + * move.c (optimized_move_display_to_edited): added new function + (cob_move): when move numeric-display to numeric-edited added logic + to check if an indirect move is needed + (indirect_move): when the destination field is numeric-edited and + the function source is binary, packed or display then the attributes + need to generated to match destination attributes instead of the + source attributes + * termio.c (pretty_display_numeric), mlio.c (get_num): + changed to use the attributes of the receiving field + 2024-05-15 Simon Sobisch * profiling.c: fix compile warnings diff --git a/libcob/common.h b/libcob/common.h index eb7ed2e88..b24458ac8 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -2174,6 +2174,8 @@ COB_EXPIMP int cob_sys_clear_screen (void); COB_EXPIMP int cob_sys_sound_bell (void); COB_EXPIMP int cob_sys_get_scr_size (unsigned char *, unsigned char *); COB_EXPIMP int cob_sys_set_scr_size (unsigned char *, unsigned char *); +COB_EXPIMP int cob_sys_scr_dump (unsigned char *); +COB_EXPIMP int cob_sys_scr_restore (unsigned char *); COB_EXPIMP int cob_sys_get_char (unsigned char *); COB_EXPIMP int cob_get_text (char *, int); COB_EXPIMP int cob_get_scr_cols (void); diff --git a/libcob/fileio.c b/libcob/fileio.c index ec8dcb88e..870a4de42 100644 --- a/libcob/fileio.c +++ b/libcob/fileio.c @@ -1,21 +1,21 @@ /* - Copyright (C) 2002-2012, 2014-2024 Free Software Foundation, Inc. - Written by Keisuke Nishida, Roger While, Simon Sobisch, Ron Norman + Copyright (C) 2002-2012, 2014-2024 Free Software Foundation, Inc. + Written by Keisuke Nishida, Roger While, Simon Sobisch, Ron Norman - This file is part of GnuCOBOL. + This file is part of GnuCOBOL. - The GnuCOBOL runtime library is free software: you can redistribute it - and/or modify it under the terms of the GNU Lesser General Public License - as published by the Free Software Foundation, either version 3 of the - License, or (at your option) any later version. + The GnuCOBOL runtime library is free software: you can redistribute it + and/or modify it under the terms of the GNU Lesser 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 Lesser General Public License for more details. + 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 Lesser General Public License for more details. - You should have received a copy of the GNU Lesser General Public License - along with GnuCOBOL. If not, see . + You should have received a copy of the GNU Lesser General Public License + along with GnuCOBOL. If not, see . */ @@ -185,6 +185,7 @@ struct indexfile { int readdone; /* A 'read' has been successfully done */ int startiscur; /* The 'start' record is current */ int wrkhasrec; /* 'recwrk' holds the next|prev record */ + int partial_key_length; /* new field for partial key on START verb */ struct keydesc key[1]; /* Table of key information */ /* keydesc is defined in (d|c|vb)isam.h */ }; @@ -202,7 +203,7 @@ indexed_keylen (const struct keydesc *key) } /* Save key for given index into 'savekey' - Return total length of the key */ + Return total length of the key */ static int indexed_savekey (struct indexfile *fh, unsigned char *data, int idx) { @@ -221,7 +222,7 @@ indexed_savekey (struct indexfile *fh, unsigned char *data, int idx) } /* Copy key for given index from 'savekey' back to recwrk - Return total length of the key */ + Return total length of the key */ static int indexed_restorekey (struct indexfile *fh, unsigned char *data, int idx) { @@ -240,7 +241,7 @@ indexed_restorekey (struct indexfile *fh, unsigned char *data, int idx) } /* Compare key for given index 'savekey' to recwrk - Return compare status */ + Return compare status */ static int indexed_cmpkey (struct indexfile *fh, unsigned char *data, int idx, int partlen) { @@ -264,7 +265,7 @@ indexed_cmpkey (struct indexfile *fh, unsigned char *data, int idx, int partlen) } /* Build 'keydesc' from 'cob_file_key' - Return total length of the key */ + Return total length of the key */ static int indexed_keydesc (cob_file *f, struct keydesc *kd, cob_file_key *key) { @@ -328,7 +329,7 @@ indexed_keydesc (cob_file *f, struct keydesc *kd, cob_file_key *key) } /* Compare 'keydesc' to 'keydesc' - Return 0 if equal, else 1 */ + Return 0 if equal, else 1 */ static int indexed_keycmp (struct keydesc *k1, struct keydesc *k2) { @@ -726,7 +727,7 @@ struct indexed_file { }; /* collation aware key comparision, - currently only used for BDB, likely used in general later */ + currently only used for BDB, likely used in general later */ static int indexed_key_compare (const unsigned char *k1, const unsigned char *k2, size_t sz, const unsigned char *col) @@ -757,7 +758,7 @@ bdb_keylen (cob_file *f, int idx) } /* Save key for given index from 'record' into 'keyarea', - returns total length of the key */ + returns total length of the key */ static int bdb_savekey (cob_file *f, unsigned char *keyarea, unsigned char *record, int idx) { @@ -798,7 +799,7 @@ bdb_setkey (cob_file *f, int idx) } /* Compare key for given index 'keyarea' to 'record'. - returns compare status */ + returns compare status */ static int bdb_cmpkey (cob_file *f, unsigned char *keyarea, unsigned char *record, int idx, int partlen) { @@ -834,7 +835,7 @@ bdb_cmpkey (cob_file *f, unsigned char *keyarea, unsigned char *record, int idx, } /* Is given key data all SUPPRESS char, - returns 1 if key has all SUPPRESS char */ + returns 1 if key has all SUPPRESS char */ static int bdb_suppresskey (cob_file *f, int idx) { @@ -914,7 +915,7 @@ bdb_close_index (cob_file *f, int index) static int bdb_bt_compare (DB *db, const DBT *k1, const DBT *k2 #if DB_VERSION_MAJOR >= 6 /* ABI break in DB_VERSION_FAMILY 12 ... */ - , size_t *locp + , size_t *locp #endif ) { @@ -980,9 +981,9 @@ dummy_start (cob_file *f, const int cond, cob_field *key) } /* Check for DD_xx, dd_xx, xx environment variables for a filename - or a part specified with 'src'; - returns either the value or NULL if not found in the environment - Note: MF only checks for xx if the variable started with a $, + or a part specified with 'src'; + returns either the value or NULL if not found in the environment + Note: MF only checks for xx if the variable started with a $, ACUCOBOL only checks for xx in general ... */ static char * cob_chk_file_env (const char *src) @@ -1096,7 +1097,7 @@ looks_absolute (char *src) } /* checks for special ACUCOBOL-case: file that start with hyphen [note: -P not supported] - no translation at all, name starts after first non-space */ + no translation at all, name starts after first non-space */ static int has_acu_hyphen (char *src) { @@ -1436,7 +1437,7 @@ save_status (cob_file *f, cob_field *fnstatus, const int status) cobglobptr->cob_exception_code = 0; } else { #if 0 /* correct thing to do, but then also needs to have codegen adjusted - --> module-incompatibility --> 4.x */ + --> module-incompatibility --> 4.x */ cob_set_exception (eop_status); #else cob_set_exception (COB_EC_I_O_EOP); @@ -1459,7 +1460,7 @@ save_status (cob_file *f, cob_field *fnstatus, const int status) /* Regular file */ /* Translate errno status to COBOL status, - Note: always sets either an error or the given default value */ + Note: always sets either an error or the given default value */ static int errno_cob_sts (const int default_status) { @@ -2204,7 +2205,7 @@ open_next (cob_file *f) int fmode = O_BINARY; /* without this ftell does not work on some systems */ #ifdef _WIN32 /* win32 seems to resolve the file descriptor from the file handler - on fclose - and then aborts because it was closed directly before */ + on fclose - and then aborts because it was closed directly before */ if (f->file) { fclose (f->file); } else { @@ -2262,8 +2263,8 @@ open_next (cob_file *f) /* Read record size into f->record->size - returns -1 if no data was read, zero for success and - and an io status otherwise */ + returns -1 if no data was read, zero for success and + and an io status otherwise */ static int set_sequential_variable_length (cob_file *f) { int bytesread; @@ -2628,7 +2629,7 @@ lineseq_read (cob_file *f, const int read_opts) } } #if 0 /* From trunk - CHECKME: When should this be done? - Only for LS_VALIDATE / LS_NULLS? */ + Only for LS_VALIDATE / LS_NULLS? */ /* Skip NEW PAGE on reading */ if (n == '\f') { continue; @@ -3750,7 +3751,7 @@ get_dupno (cob_file *f, const cob_u32_t i) } /* read file with all alternate keys that don't allow duplicates - to check if records exist already, returns 1 if true */ + to check if records exist already, returns 1 if true */ static int check_alt_keys (cob_file *f, const int rewrite) { @@ -4707,13 +4708,14 @@ indexed_open (cob_file *f, char *filename, case DB_LOCK_NOTGRANTED: return COB_STATUS_61_FILE_SHARING; case ENOENT: + case ENOTDIR: if (mode == COB_OPEN_EXTEND || mode == COB_OPEN_OUTPUT) { - return COB_STATUS_30_PERMANENT_ERROR; + return COB_STATUS_35_NOT_EXISTS; } if (f->flag_optional) { if (mode == COB_OPEN_I_O) { - return COB_STATUS_30_PERMANENT_ERROR; + return COB_STATUS_35_NOT_EXISTS; } f->open_mode = mode; f->flag_nonexistent = 1; @@ -4905,6 +4907,24 @@ indexed_start (cob_file *f, const int cond, cob_field *key) return COB_STATUS_23_KEY_NOT_EXISTS; } k = cob_findkey_attr (f, key, &fullkeylen, &partlen); + + /************************************************************/ + /* */ + /* here we are storing the partial key length in the */ + /* indexfile structure so that the indexed read next */ + /* functions can position the file based on the partial */ + /* key length. */ + /* */ + /* note the indexed_cmpkey function expects a partial key */ + /* length of zero if it is to use the full key length. */ + /* */ + /************************************************************/ + + if (fullkeylen == partlen) + fh->partial_key_length = 0; + else + fh->partial_key_length = partlen; + if (k < 0) { return COB_STATUS_23_KEY_NOT_EXISTS; } @@ -5198,7 +5218,7 @@ indexed_read_next (cob_file *f, const int read_opts) case COB_GE: domoveback = 0; while (ISERRNO == 0 - && indexed_cmpkey (fh, f->record->data, f->curkey, 0) == 0) { + && indexed_cmpkey(fh, f->record->data, f->curkey, fh->partial_key_length) == 0) { isread (fh->isfd, (void *)f->record->data, ISPREV); domoveback = 1; } @@ -5209,7 +5229,7 @@ indexed_read_next (cob_file *f, const int read_opts) case COB_LE: domoveback = 0; while (ISERRNO == 0 - && indexed_cmpkey (fh, f->record->data, f->curkey, 0) == 0) { + && indexed_cmpkey(fh, f->record->data, f->curkey, fh->partial_key_length) == 0) { isread (fh->isfd, (void *)f->record->data, ISNEXT); domoveback = 1; } @@ -5222,13 +5242,13 @@ indexed_read_next (cob_file *f, const int read_opts) isread (fh->isfd, (void *)f->record->data, ISPREV); #endif while (ISERRNO == 0 - && indexed_cmpkey (fh, f->record->data, f->curkey, 0) >= 0) { + && indexed_cmpkey(fh, f->record->data, f->curkey, fh->partial_key_length) >= 0) { isread (fh->isfd, (void *)f->record->data, ISPREV); } break; case COB_GT: while (ISERRNO == 0 - && indexed_cmpkey (fh, f->record->data, f->curkey, 0) <= 0) { + && indexed_cmpkey(fh, f->record->data, f->curkey, fh->partial_key_length) <= 0) { isread (fh->isfd, (void *)f->record->data, ISNEXT); } break; @@ -5278,12 +5298,12 @@ indexed_read_next (cob_file *f, const int read_opts) } else { switch (fh->startcond) { case COB_LE: - if (indexed_cmpkey (fh, f->record->data, f->curkey, 0) > 0) + if(indexed_cmpkey(fh, f->record->data, f->curkey, fh->partial_key_length) > 0) domoveback = 1; else domoveback = 0; while (ISERRNO == 0 - && indexed_cmpkey (fh, f->record->data, f->curkey, 0) == 0) { + && indexed_cmpkey(fh, f->record->data, f->curkey, fh->partial_key_length) == 0) { isread (fh->isfd, (void *)f->record->data, ISNEXT); domoveback = 1; } @@ -5293,19 +5313,19 @@ indexed_read_next (cob_file *f, const int read_opts) break; case COB_LT: while (ISERRNO == 0 - && indexed_cmpkey (fh, f->record->data, f->curkey, 0) >= 0) { + && indexed_cmpkey(fh, f->record->data, f->curkey, fh->partial_key_length) >= 0) { isread (fh->isfd, (void *)f->record->data, ISPREV); } break; case COB_GT: while (ISERRNO == 0 - && indexed_cmpkey (fh, f->record->data, f->curkey, 0) <= 0) { + && indexed_cmpkey(fh, f->record->data, f->curkey, fh->partial_key_length) <= 0) { isread (fh->isfd, (void *)f->record->data, ISNEXT); } break; case COB_GE: while (ISERRNO == 0 - && indexed_cmpkey (fh, f->record->data, f->curkey, 0) < 0) { + && indexed_cmpkey(fh, f->record->data, f->curkey, fh->partial_key_length) < 0) { isread (fh->isfd, (void *)f->record->data, ISNEXT); } break; @@ -7006,7 +7026,7 @@ cob_delete_file (cob_file *f, cob_field *fnstatus) } /* Return index number for given key and set length attributes, - storing resulting key field in file's last_key */ + storing resulting key field in file's last_key */ int cob_findkey (cob_file *f, cob_field *kf, int *fullkeylen, int *partlen) { @@ -7044,7 +7064,7 @@ cob_savekey (cob_file *f, int idx, unsigned char *data) /* System routines */ /* stores the field's rtrimmed string content into a fresh allocated - string, which later needs to be passed to cob_free */ + string, which later needs to be passed to cob_free */ static void * cob_str_from_fld (const cob_field *f) { @@ -7311,7 +7331,7 @@ cob_sys_close_file (unsigned char *file_handle) } /* entry point and processing for library routine CBL_FLUSH_FILE - (flush bytestream file handle, got from CBL_OPEN_FILE) */ + (flush bytestream file handle, got from CBL_OPEN_FILE) */ int cob_sys_flush_file (unsigned char *file_handle) { @@ -7353,7 +7373,7 @@ cob_sys_delete_file (unsigned char *file_name) } /* entry point and processing for library routine CBL_COPY_FILE, - does a direct read + write of the complete file */ + does a direct read + write of the complete file */ int cob_sys_copy_file (unsigned char *fname1, unsigned char *fname2) { @@ -8389,7 +8409,7 @@ cob_file_sort_using (cob_file *sort_file, cob_file *data_file) } /* SORT/MERGE: add all records from GIVING file 'data_file' to 'sort_file', - with optional external file handler 'callfh' */ + with optional external file handler 'callfh' */ void cob_file_sort_using_extfh (cob_file *sort_file, cob_file *data_file, int (*callfh)(unsigned char *opcode, FCD3 *fcd)) @@ -8439,7 +8459,7 @@ cob_file_sort_using_extfh (cob_file *sort_file, cob_file *data_file, /* SORT/MERGE: WRITE all records from 'sort_file' to all USING files 'fbase', - with using their optional external file handlers 'callfh' */ + with using their optional external file handlers 'callfh' */ static void cob_file_sort_giving_internal (cob_file *sort_file, const size_t giving_cnt, cob_file **fbase, int (**callfh)(unsigned char *opcode, FCD3 *fcd)) @@ -8588,7 +8608,7 @@ cob_file_sort_giving (cob_file *sort_file, const size_t varcnt, ...) } /* SORT: WRITE all records from 'sort_file' to all passed USING files, - with using their optional external file handlers */ + with using their optional external file handlers */ void cob_file_sort_giving_extfh (cob_file *sort_file, const size_t varcnt, ...) { @@ -8610,7 +8630,7 @@ cob_file_sort_giving_extfh (cob_file *sort_file, const size_t varcnt, ...) } /* SORT: close of internal sort file 'f' and deallocation - of temporary storage */ + of temporary storage */ void cob_file_sort_close (cob_file *f) { @@ -8725,8 +8745,8 @@ cob_get_filename_print (cob_file* file, const int show_resolved_name) } /* Initialization/Termination - cobsetpr-values with type ENV_PATH or ENV_STR - like bdb_home and cob_file_path are taken care in cob_exit_common()! + cobsetpr-values with type ENV_PATH or ENV_STR + like bdb_home and cob_file_path are taken care in cob_exit_common()! */ const char *implicit_close_of_msgid = NULL; @@ -9535,7 +9555,7 @@ free_fcd2 (FCD2 *fcd2) } /* Convert FCD2 into FCD3 format, note: explicit no checks here - as those have to be in EXTFH3 / fileio later */ + as those have to be in EXTFH3 / fileio later */ static FCD3 * fcd2_to_fcd3 (FCD2 *fcd2) { @@ -10042,7 +10062,7 @@ cob_extfh_delete ( } /* COBOL wrapper for EXTFH call to prevent warnings about FCD3 structure - with additional checks */ + with additional checks */ int cob_sys_extfh (const void *opcode_ptr, void *fcd_ptr) { @@ -10421,8 +10441,8 @@ EXTFH3 (unsigned char *opcode, FCD3 *fcd) STCOMPX4(f->record_max,fcd->curRecLen); update_file_to_fcd (f, fcd, fnstatus); #if 0 /* Simon: general mapping needed, depending - on a compile time switch (also for other dialects) - --> no "single place extension" here */ + on a compile time switch (also for other dialects) + --> no "single place extension" here */ if (f->organization == COB_ORG_INDEXED && memcmp (f->file_status, "61", 2) == 0) {/* 61 --> 9A for MF */ memcpy (fcd->fileStatus,"9A", 2); @@ -10439,8 +10459,8 @@ EXTFH3 (unsigned char *opcode, FCD3 *fcd) } update_file_to_fcd (f, fcd, fnstatus); #if 0 /* Simon: general mapping needed, depending - on a compile time switch (also for other dialects) - --> no "single place extension" here */ + on a compile time switch (also for other dialects) + --> no "single place extension" here */ if (f->organization == COB_ORG_INDEXED && memcmp (f->file_status, "61", 2) == 0) {/* 61 --> 9A for MF */ memcpy (fcd->fileStatus,"9A", 2); @@ -10458,8 +10478,8 @@ EXTFH3 (unsigned char *opcode, FCD3 *fcd) } update_file_to_fcd (f, fcd, fnstatus); #if 0 /* Simon: general mapping needed, depending - on a compile time switch (also for other dialects) - --> no "single place extension" here */ + on a compile time switch (also for other dialects) + --> no "single place extension" here */ if (f->organization == COB_ORG_INDEXED && memcmp (f->file_status, "61", 2) == 0) {/* 61 --> 9A for MF */ memcpy (fcd->fileStatus,"9A", 2); @@ -10475,8 +10495,8 @@ EXTFH3 (unsigned char *opcode, FCD3 *fcd) } update_file_to_fcd (f, fcd, fnstatus); #if 0 /* Simon: general mapping needed, depending - on a compile time switch (also for other dialects) - --> no "single place extension" here */ + on a compile time switch (also for other dialects) + --> no "single place extension" here */ if (f->organization == COB_ORG_INDEXED && memcmp (f->file_status, "61", 2) == 0) {/* 61 --> 9A for MF */ memcpy (fcd->fileStatus,"9A", 2); diff --git a/libcob/mlio.c b/libcob/mlio.c index f6a657b46..67c52e443 100644 --- a/libcob/mlio.c +++ b/libcob/mlio.c @@ -1,5 +1,5 @@ /* - Copyright (C) 2018-2020, 2022-2023 Free Software Foundation, Inc. + Copyright (C) 2018-2020, 2022-2024 Free Software Foundation, Inc. Written by Edward Hart, Simon Sobisch This file is part of GnuCOBOL. @@ -229,7 +229,7 @@ is_empty (const cob_field * const f) } /* strdup-like wrapper for get_trimmed_data, returns a pointer to - fresh allocated memory pointing to a copy of the specified + fresh allocated memory pointing to a copy of the specified data with specified size as string (+ trailing NULL) */ static void * copy_data_as_string (const char* data, const size_t size) @@ -354,9 +354,9 @@ static void * get_num (cob_field * const f, void * (*strndup_func)(const char *, size_t), const char decimal_point) { - size_t num_integer_digits + const size_t num_integer_digits = cob_max_int (0, COB_FIELD_DIGITS (f) - COB_FIELD_SCALE (f)); - size_t num_decimal_digits + const size_t num_decimal_digits = cob_max_int (0, COB_FIELD_SCALE (f)); cob_field_attr attr; cob_field edited_field; @@ -367,9 +367,14 @@ get_num (cob_field * const f, void * (*strndup_func)(const char *, size_t), /* Initialize attribute for nicely edited version of f */ attr.type = COB_TYPE_NUMERIC_EDITED; - attr.flags = COB_FLAG_JUSTIFIED; - attr.scale = COB_FIELD_SCALE (f); - attr.digits = COB_FIELD_DIGITS (f); + attr.flags = COB_FIELD_HAVE_SIGN (f) ? + (COB_FLAG_JUSTIFIED | COB_FLAG_HAVE_SIGN) : + (COB_FLAG_JUSTIFIED); + attr.scale = (COB_FIELD_SCALE (f) < 0) ? 0 : COB_FIELD_SCALE (f); + attr.digits = (unsigned short)(num_integer_digits + num_decimal_digits); + if (num_integer_digits == 0) + attr.digits++; + attr.pic = get_pic_for_num_field (num_integer_digits, num_decimal_digits); diff --git a/libcob/move.c b/libcob/move.c index da157583f..36e820f84 100644 --- a/libcob/move.c +++ b/libcob/move.c @@ -1,22 +1,22 @@ /* - Copyright (C) 2002-2012, 2014-2020, 2022-2024 Free Software Foundation, Inc. - Written by Keisuke Nishida, Roger While, Simon Sobisch, Ron Norman, - Edwart Hard + Copyright (C) 2002-2012, 2014-2020, 2022-2024 Free Software Foundation, Inc. + Written by Keisuke Nishida, Roger While, Simon Sobisch, Ron Norman, + Edwart Hard - This file is part of GnuCOBOL. + This file is part of GnuCOBOL. - The GnuCOBOL runtime library is free software: you can redistribute it - and/or modify it under the terms of the GNU Lesser General Public License - as published by the Free Software Foundation, either version 3 of the - License, or (at your option) any later version. + The GnuCOBOL runtime library is free software: you can redistribute it + and/or modify it under the terms of the GNU Lesser 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 Lesser General Public License for more details. + 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 Lesser General Public License for more details. - You should have received a copy of the GNU Lesser General Public License - along with GnuCOBOL. If not, see . + You should have received a copy of the GNU Lesser General Public License + along with GnuCOBOL. If not, see . */ @@ -102,42 +102,42 @@ static const cob_s64_t cob_exp10_ll[19] = { /* translation table for BCD byte (2 digits) to integer; - identical defined in numeric.c */ + identical defined in numeric.c */ static const unsigned char pack_to_bin [] = { #if 0 /* invalid BCD nibbles as zero */ - 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, - 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 0, 0, 0, 0, 0, 0, - 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 0, 0, 0, 0, 0, 0, - 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 0, 0, 0, 0, 0, 0, - 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 0, 0, 0, 0, 0, 0, - 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 0, 0, 0, 0, 0, 0, - 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 0, 0, 0, 0, 0, 0, - 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 0, 0, 0, 0, 0, 0, - 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 0, 0, 0, 0, 0, 0, - 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 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, 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, - 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, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, + 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 0, 0, 0, 0, 0, 0, + 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 0, 0, 0, 0, 0, 0, + 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 0, 0, 0, 0, 0, 0, + 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 0, 0, 0, 0, 0, 0, + 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 0, 0, 0, 0, 0, 0, + 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 0, 0, 0, 0, 0, 0, + 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 0, 0, 0, 0, 0, 0, + 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 0, 0, 0, 0, 0, 0, + 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 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, 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, + 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 #else /* invalid BCD nibbles as translated since at least OC 1.1 */ - 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, - 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, - 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 25, - 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, - 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, - 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, - 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, - 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, - 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, - 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, - 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, - 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, - 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, - 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, - 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, - 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165 + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, + 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, + 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 25, + 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, + 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, + 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, + 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, + 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, + 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, + 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, + 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, + 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, + 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, + 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, + 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, + 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165 #endif }; @@ -474,106 +474,199 @@ cob_move_alphanum_to_alphanum (cob_field *f1, cob_field *f2) void cob_move_display_to_packed (cob_field *f1, cob_field *f2) { - unsigned char *data1 = COB_FIELD_DATA (f1); - const int sign = COB_GET_SIGN_ADJUST (f1); - const short scale1 = COB_FIELD_SCALE (f1); - const short scale2 = COB_FIELD_SCALE (f2); - const int target_no_sign_nibble = COB_FIELD_NO_SIGN_NIBBLE (f2); - unsigned short digits1; - unsigned short digits2; - register unsigned int i; - - register unsigned char *p; - - /* 99P -> 3 digits, scale -1 --> real digits are less */ - if (scale1 >= 0) { - digits1 = COB_FIELD_DIGITS (f1); - } else { - digits1 = COB_FIELD_DIGITS (f1) + scale1; - } - if (scale2 >= 0) { - digits2 = COB_FIELD_DIGITS (f2); - } else { - digits2 = COB_FIELD_DIGITS (f2) + scale2; - } - - if (target_no_sign_nibble) { - i = digits2 % 2; - } else { - i = 1 - digits2 % 2; - } - - /* note: the overhead of checking for leading ZERO and zero-like data - is higher than just setting it below - so not done here */ - - /* skip not available positions */ - p = data1 + (digits1 - scale1) - (digits2 - scale2); - while (p < data1) { - p++; i++; /* note: both p and i are about digits */ - } + /************************************************************/ + /* */ + /* The logic used by this function is to find the offset */ + /* from the decimal point for first position in both the */ + /* sending and receiving fields. Note that NO special */ + /* logic is required to handle the presence of a "p" in */ + /* the PICTURE clause. */ + /* */ + /* Once the offsets are found we can use the difference */ + /* in the offsets to position the pointers in each of the */ + /* fields. */ + /* */ + /* If the offsets are the same then we can start packing */ + /* starting at the beginning of both fields. */ + /* */ + /* If the offset of the sending field is greater than */ + /* that of the receiving field then we need to adjust the */ + /* position of the sending field point to the right by */ + /* the difference in the offsets. */ + /* */ + /* If the offset of the receiving field is greater than */ + /* that of the sending field then the logic is a bit more */ + /* complicated in that each time thru the packing loop we */ + /* pack TWO DIGITS. So we divide the offset by 2 to */ + /* adjust the position of the pointer to the packed field */ + /* to the correct byte where the digit will be placed. */ + /* Also we need to determine if the first digit to be */ + /* packed will go into the HIGH ORDER nibble or the LOW */ + /* ORDER nibble. If the difference in the offsets is ODD, */ + /* then the first digit will need to go into the LOW */ + /* ORDER nibble, so we set a switch for that. */ + /* */ + /* Before starting the packing loop we need to check if */ + /* the first digit has to go into the LOW ORDER nibble, */ + /* if so we need to do that first. */ + /* */ + /* Also after completing the packing loop, we need to */ + /* check if there is a digit left to be packed, if so we */ + /* need to put it into the HIGH ORDER nibble of the next */ + /* location in the receiving field. */ + /* */ + /* Then we need to clear the PAD nibble if present and */ + /* set the sign nibble if the receiving field is signed. */ + /* */ + /************************************************************/ + + const int sign = COB_GET_SIGN_ADJUST (f1); + const short scale1 = COB_FIELD_SCALE (f1); + const short scale2 = COB_FIELD_SCALE (f2); + const int target_no_sign_nibble = COB_FIELD_NO_SIGN_NIBBLE (f2); + unsigned int f1_digits, f2_digits; + unsigned int start_in_low_nibble = 0; + int f1_offset, f2_offset; + + register unsigned char *p, *p_end, *q, *q_end; + + + /************************************************************/ + /* */ + /* Note that when calculating the offsets of the first */ + /* position in each field we need to use the number of */ + /* digits in the actual data field not the number of */ + /* digits returned by the COB_FIELD_DIGITS function. */ + /* */ + /* Note that this logic works whether or not there is a */ + /* "P" any where in the PICTURE clause. */ + /* */ + /************************************************************/ + + if (COB_FIELD_SIGN_SEPARATE (f1)) + f1_digits = f1->size - 1; + else + f1_digits = f1->size; + + p = COB_FIELD_DATA (f1); + p_end = p + f1_digits - 1; + + f1_offset = f1_digits - scale1 - 1; + + + if (target_no_sign_nibble) + f2_digits = f2->size << 1; + else + f2_digits = (f2->size << 1) - 1; + + q = f2->data; + q_end = q + f2->size - 1; + + f2_offset = f2_digits - scale2 - 1; + + /************************************************************/ + /* */ + /* if the packed field has a sign nibble then the offset */ + /* has to be one greater than the number of digits in */ + /* both fields since the offset is the position in */ + /* the receiving field */ + /* */ + /************************************************************/ + + /************************************************************/ + /* */ + /* At this point we are ready to position the pointers to */ + /* the sending and receiving fields. Note that if the */ + /* offsets are equal then no positioning is needed and we */ + /* can just start packing data */ + /* */ /* zero out target, then transfer data */ + /* */ + /************************************************************/ + memset (f2->data, 0, f2->size); + + if (f1_offset > f2_offset) + p = p + (f1_offset - f2_offset); + else if (f1_offset < f2_offset) { - register unsigned char *q = f2->data + i / 2; - const unsigned int i_end = (unsigned int)f2->size; /* a packed field always has small size */ - /* FIXME: get rid of that, adjust i_end to handle both truncation of the source to the right - and zero-fill because of scale differences (zero-fill wa s already done) */ - const unsigned char *p_end = data1 + digits1; - - if (i % 2 == 1) { - *q++ = COB_D2I (*p++); - i++; - } - - /* note: from this point on the variable "i" represents the target bytes, - not the digits any more (therefore we divide by 2) */ - i = i / 2; - - /* note: for performance reasons we write "full bytes" only, this means that for COMP-3 - we'll read 1 byte "too much = after" from the DISPLAY data; - it is believed that this won't raise a SIGBUS anywhere, but we will need to "clean" - the half-byte before setting the sign */ - - /* check for necessary loop (until we not need the p_end check) */ - if (i_end - i < (unsigned int)(p_end - p + 1) / 2) { - while (i < i_end) { - *q = ((*p << 4) & 0xFF) /* -> dropping the higher bits = no use in COB_D2I */ - + COB_D2I (*(p + 1)); - q++; - i++; - p += 2; + /************************************************************/ + /* if the difference in offsets is odd then the first */ + /* digit will need to pack into the low order nibble */ + /* otherwise it can start packing into the high order */ + /* nibble */ + /************************************************************/ + if ((f2_offset - f1_offset) & 1) + start_in_low_nibble = 1; + q = q + ((f2_offset - f1_offset ) >> 1); + } + + /************************************************************/ + /* */ + /* Now both pointers have been set to start the packing */ + /* of digits. Note that first we have to check to see if */ + /* the first digit to be packed has to be positioned in */ + /* the lower order nibble before we can start the packing */ + /* loop */ + /* */ + /************************************************************/ + + if (start_in_low_nibble && (p <= p_end) && (q <= q_end)) + { + *q = (*p) & 0x0F; + q++; + p++; } - } else { - while (p < p_end) { - *q = ((*p << 4) & 0xFF) /* -> dropping the higher bits = no use in COB_D2I */ + + /************************************************************/ + /* */ + /* Now we can start the packing loop !! */ + /* */ + /* Note that we exit when the display pointer NOT LESS */ + /* than the last digit in the sending field. */ + /* */ + /************************************************************/ + + while ((p < p_end) && (q <= q_end)) + { + *q = (unsigned char) (*p << 4) /* -> dropping the higher bits = no use in COB_D2I */ + COB_D2I (*(p + 1)); + p = p + 2; q++; - p += 2; - } - } - /* clean bottom nibble if we packed one extra digit past the end of the input */ - if (p > p_end) { - *(q - 1) &= 0xf0; - } + } + + /************************************************************/ + /* */ + /* Now we need to check if there is 1 digit left to pack */ + /* */ + /************************************************************/ + + if ((p == p_end) && (q <= q_end)) + { + *q = (unsigned char) (*p << 4) & 0xF0; } COB_PUT_SIGN_ADJUSTED (f1, sign); + if (COB_FIELD_DIGITS(f2) < f2_digits) + { + *(f2->data) &= 0x0f; + } + if (target_no_sign_nibble) { - return; + return; } - /* note: for zero-fill like MOVE 2.1 TO C3-9v9999 we only go to the second position and - therefore have to set 'p' to the most-right place in the target field*/ - p = f2->data + f2->size - 1; if (!COB_FIELD_HAVE_SIGN (f2)) { - *p |= 0x0F; + *q_end |= 0x0F; } else if (sign < 0) { - *p = (*p & 0xF0) | 0x0D; + *q_end = (*q_end & 0xF0) | 0x0D; } else { - *p = (*p & 0xF0) | 0x0C; + *q_end = (*q_end & 0xF0) | 0x0C; } + + return; } void @@ -703,7 +796,7 @@ cob_move_fp_to_fp (cob_field *src, cob_field *dst) /* move from one to the other binary field ignoring the scale - --> these must match */ + --> these must match */ static void cob_move_binary_to_binary (cob_field *f1, cob_field *f2) { @@ -871,187 +964,262 @@ cob_move_binary_to_display (cob_field *f1, cob_field *f2) /* create numeric edited field, note: non-display fields get "unpacked" first via indirect_move, then be edited - from display using this function */ + from display using this function */ static void -cob_move_display_to_edited (cob_field *f1, cob_field *f2) +optimized_move_display_to_edited (cob_field *f1, cob_field *f2) { - register unsigned char *dst = f2->data; - register unsigned char *src; - const cob_pic_symbol *p; - unsigned char *min = COB_FIELD_DATA (f1); - unsigned char *max = min + COB_FIELD_SIZE (f1); - unsigned char *end = f2->data + f2->size; - unsigned char *decimal_point = NULL; - /* note: can't use the "adjust" variant here as we don't convert to digit - to explicit keep invalid data "as is"; - CHECKME for using a buffer instead of original data */ - const int sign = COB_GET_SIGN (f1); - int neg = (sign < 0) ? 1 : 0; - int count = 0; - int count_sign = 1; - int count_curr = 1; - int trailing_sign = 0; - int trailing_curr = 0; - int is_zero = 1; - int suppress_zero = 1; - int sign_first = 0; - int p_is_left = 0; - int has_b = 0; - int repeat; - int n; - unsigned char pad = ' '; - unsigned char x; - unsigned char c; - unsigned char sign_symbol = 0; - unsigned char curr_symbol = 0; - const unsigned char dec_symbol = COB_MODULE_PTR->decimal_point == ',' - ? ',' : '.'; - const unsigned char currency = COB_MODULE_PTR->currency_symbol; - int floating_insertion = 0; - unsigned char *last_fixed_insertion_pos = NULL; - unsigned char last_fixed_insertion_char = '\0'; - - /* Setup counters (only before decimal point) */ - /* - TO-DO: This is computed in cb_build_picture; add computed results to - cb_field / new overlay cb_field_edited and use those. - */ + /************************************************************/ + /* this is a special "optimized" version of the */ + /* cob_move_display_to_edited function. The scale and */ + /* digits of the f2 field must be the same as the f1 */ + /* field. */ + /* */ + /* it is only called from the indirect_move function when */ + /* the destination field is type */ + /* COB_TYPE_NUMERIC_EDITED */ + /* */ + /* create numeric edited field, note: non-display fields */ + /* get "unpacked" first via indirect_move, then be edited */ + /* from display using this function */ + /* */ + /* This requires that the input field MUST be signed */ + /* separate (which is trailing). Also the source field */ + /* must contain the exact same number of digits as the */ + /* destination.. */ + /* */ + /* This ensures that we can make a single pass thru the */ + /* picture symbols and not have to worry about padding or */ + /* insertation after the loop thru the picture symbols. */ + /* */ + /* The reason for this change has more to do with */ + /* reducing the complexity of the code than performance. */ + /* Although it may result in a slight performance gain as */ + /* well. */ + /* */ + /************************************************************/ + + register unsigned char *dst = f2->data; + register unsigned char *src = f1->data; + const cob_pic_symbol *p; + unsigned char *src_end = src + f1->size - 1; + unsigned char *dst_end = f2->data + f2->size; + + unsigned char *prev_float_char = NULL; + unsigned char *sign_position = NULL; + int neg = 0; + int is_zero = 1; + int suppress_zero = 1; + int have_decimal_point = 0; + int have_check_protect = 0; + int n; + int cntr_currency = 0; + int cntr_sign_neg = 0; + int cntr_sign_pos = 0; + unsigned char pad = ' '; + unsigned char c; + unsigned char float_char = 0x00; + const unsigned char dec_symbol = COB_MODULE_PTR->decimal_point == ',' + ? ',' : '.'; + const unsigned char currency = COB_MODULE_PTR->currency_symbol; + +#if 1 /* Sanity check to ensure that the data types of both the fields have the + correct attributes, if not then something is brokend and needs to be fixed */ + if (!(COB_FIELD_TYPE (f2) == COB_TYPE_NUMERIC_EDITED + && COB_FIELD_DIGITS (f1) == COB_FIELD_DIGITS (f2) + && COB_FIELD_SCALE (f1) == COB_FIELD_SCALE (f2) + && COB_FIELD_HAVE_SIGN (f1) == COB_FIELD_HAVE_SIGN (f2) + && ((COB_FIELD_HAVE_SIGN (f1) && (!COB_FIELD_SIGN_LEADING (f1) && COB_FIELD_SIGN_SEPARATE (f1))) + || !COB_FIELD_HAVE_SIGN (f1)))) { + cob_runtime_error ("optimized_move_display_to_edited: invalid argument"); + } +#endif + + + /************************************************************/ + /* Currently this will require two passes of the symbol */ + /* table to find the float char.... */ + /* */ + /* this logic to find the floating char if one exits */ + /* should be moved to COBC in GC40. This would require */ + /* some structure changes so for now it is needed here. */ + /************************************************************/ + + c = 0x00; + for (p = COB_FIELD_PIC (f2); p->symbol; ++p) { c = p->symbol; - repeat = p->times_repeated; - if (c == '9' || c == 'Z' || c == '*') { - count += repeat; - count_sign = 0; - count_curr = 0; - } else if (count_curr && c == currency) { - count += repeat; - } else if (count_sign && (c == '+' || c == '-')) { - count += repeat; - } else if (c == 'P') { - if (count == 0) { - p_is_left = 1; + n = p->times_repeated; + if ((c == '9') + || (c == 'Z') + || (c == '*') + || (c == 'C') + || (c == 'D')) { + break; + } else if (c == '-') { + cntr_sign_neg += n; + if (cntr_sign_neg > 1) break; + } else if (c == '+') { + cntr_sign_pos += n; + if (cntr_sign_pos > 1) break; + } else if (c == currency) { + cntr_currency += n; + if (cntr_currency > 1) break; + } + } + + switch (c) { + case '-' : float_char = c; break; + case '+' : float_char = c; break; + case '*' : pad = c; break; + default: + if (c == currency) { + float_char = c; break; - } else { - count += repeat; - count_sign = 0; - count_curr = 0; } - } else if (c == 'V' || c == dec_symbol) { - break; + } + + /* first check for BLANK WHEN ZERO attribute */ + if (COB_FIELD_BLANK_ZERO(f2)) { + for(; (src <= src_end) ; src++) { + if (*src != '0') break; } + if (src > src_end) { + memset(dst, (int)' ', (size_t)f2->size); + return; + } + src = f1->data; } - /* now insert data to destination */ - src = max - COB_FIELD_SCALE (f1) - count; + if (COB_FIELD_HAVE_SIGN(f1)) + neg = (*src_end == '-') ? 1 : 0; + for (p = COB_FIELD_PIC (f2); p->symbol; ++p) { c = p->symbol; n = p->times_repeated; - for (; n > 0; n--, ++dst) { + if (c == 'P') + continue; + for (; n > 0; n--) { + if (dst >= dst_end) { + cob_runtime_error ("optimized_move_display_to_edited: overflow in destination field"); + break; + } switch (c) { case '9': - x = (min <= src && src < max) ? *src++ : (src++, '0'); - if (x != '0') { + suppress_zero = 0; + *dst = *src; + if (*src != '0') { is_zero = 0; } - suppress_zero = 0; - trailing_sign = 1; - trailing_curr = 1; - *dst = x; + src++; + dst++; break; case 'Z': - case '*': - x = (min <= src && src < max) ? *src++ : (src++, '0'); - if (x != '0') { + *dst = *src; + pad = ' '; + if (*src != '0') { is_zero = suppress_zero = 0; + } else { + if (suppress_zero && (!have_decimal_point)) + *dst = pad; } - trailing_sign = 1; - trailing_curr = 1; - pad = (c == '*') ? '*' : ' '; - *dst = suppress_zero ? pad : x; + src++; + dst++; break; - case '+': - case '-': - x = (min <= src && src < max) ? *src++ : (src++, '0'); - if (x != '0') { + case '*': + *dst = *src; + have_check_protect = 1; + if (*src != '0') { is_zero = suppress_zero = 0; - } - if (trailing_sign) { - /* Check negative and not zero */ - if (neg && !is_zero) { - *dst = '-'; - } else if (c == '+') { - *dst = '+'; - } else { - *dst = ' '; - } - --end; - } else if (dst == f2->data || suppress_zero) { - *dst = pad; - sign_symbol = c; - if (!curr_symbol) { - ++sign_first; - } } else { - *dst = x; + if (suppress_zero && (!have_decimal_point)) + *dst = pad; } + src++; + dst++; + break; - if (n > 1 || last_fixed_insertion_char == c) { - floating_insertion = 1; - } else if (!trailing_sign) { - if (last_fixed_insertion_pos) { - *last_fixed_insertion_pos = last_fixed_insertion_char; - } - last_fixed_insertion_pos = dst; - last_fixed_insertion_char = c; + case '+': + case '-': + if (c != float_char) { + *dst = c; + sign_position = dst; + dst++; + break; + } else if (prev_float_char == NULL) { + *dst = c; + prev_float_char = dst; + sign_position = dst; + dst++; + break; + } else if ((*src == '0') && (suppress_zero)) { + *prev_float_char = ' '; + prev_float_char = dst; + sign_position = dst; + *dst = c; + dst++; + src++; + break; + } else { + *dst = *src; + is_zero = suppress_zero = 0; + dst++; + src++; + break; } - break; case '.': case ',': if (c == dec_symbol) { *dst = dec_symbol; - decimal_point = dst; + have_decimal_point = 1; } else { if (suppress_zero) { - *dst = pad; + if (prev_float_char) { + *dst = *prev_float_char; + *prev_float_char = pad; + prev_float_char = dst; + if (*dst == '-' || *dst == '+') + sign_position = dst; + } + else + *dst = pad; } else { *dst = c; } } + dst++; break; case 'V': - --dst; - decimal_point = dst; break; case '0': case '/': *dst = c; + dst++; break; case 'B': - if (suppress_zero) { + if (suppress_zero && prev_float_char) { + *dst = *prev_float_char; + *prev_float_char = pad; + prev_float_char = dst; + } else if (have_check_protect) { *dst = pad; } else { - *dst = 'B'; - has_b = 1; + *dst = ' '; } + dst++; 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') { @@ -1062,152 +1230,88 @@ cob_move_display_to_edited (cob_field *f1, cob_field *f2) } else { memset (dst, ' ', (size_t)2); } - dst++; + dst += 2; 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 */ + cob_runtime_error ("optimized_move_display_to_edited: invalid PIC character %c", c); + *dst = '?'; /* Invalid PIC */ break; - } - /* LCOV_EXCL_STOP */ - - x = (min <= src && src < max) ? *src++ : (src++, '0'); - if (x != '0') { - is_zero = suppress_zero = 0; - } - if (trailing_curr) { - *dst = currency; - --end; - } else if (dst == f2->data || suppress_zero) { - *dst = pad; - curr_symbol = currency; + } else if (c != float_char) { + *dst = c; + dst++; + break; + } else if (prev_float_char == NULL) { + *dst = c; + prev_float_char = dst; + dst++; + break; + } else if ((*src == '0') && (suppress_zero) && (!have_decimal_point)) { + *prev_float_char = ' '; + prev_float_char = dst; + *dst = c; + dst++; + src++; + break; } else { - *dst = x; + *dst = *src; + if (*src != '0') { + is_zero = 0; + suppress_zero = 0; + } + dst++; + src++; + break; } - 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; + /* LCOV_EXCL_STOP */ + } /* END OF SWITCH STATEMENT */ + } /* END OF INNER FOR LOOP */ + } /* END OF OUTER FOR LOOP */ + + /************************************************************/ + /* after the edited string is built from the mask */ + /* then the sign mask has to be adjusted according to */ + /* the actual sign of the data. */ + /************************************************************/ + + /* if we have not printed any digits set destination to spaces and return */ + + if (suppress_zero){ + if (pad == '*'){ + for(dst = f2->data; dst < dst_end; dst++) { + if (*dst != dec_symbol){ + *dst = '*'; } - break; } + } else { + memset(f2->data, ' ', f2->size); + return; } } - if (sign_symbol) { - /* Check negative and not zero */ - if (neg && !is_zero) { - sign_symbol = '-'; - } else if (sign_symbol != '+') { - sign_symbol = ' '; - } + if (sign_position == NULL) + return; + + if ((neg) && (*sign_position == '+')){ + *sign_position = (is_zero) ? '+' : '-'; + return; } - if (suppress_zero || (is_zero && COB_FIELD_BLANK_ZERO (f2))) { - /* All digits are zeros */ - if (pad == ' ' || COB_FIELD_BLANK_ZERO (f2)) { - memset (f2->data, ' ', f2->size); - } else { - for (dst = f2->data; dst < f2->data + f2->size; ++dst) { - if (*dst != dec_symbol) { - *dst = pad; - } - } - } - } else { - /* Put zero after the decimal point if necessary */ - if (decimal_point) { - for (dst = decimal_point + 1; dst < end; ++dst) { - switch (*dst) { - case '0': - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - 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 '/': - case 'B': - break; - default: - *dst = '0'; + if ((neg) && (*sign_position == '-')){ + *sign_position = (is_zero) ? ' ' : '-'; + return; } - } - } - /* Put sign or currency symbol at the beginning */ - if (sign_symbol || curr_symbol) { - if (floating_insertion) { - /* use memrchr here as soon as gnulib is used */ - for (dst = end - 1; dst > f2->data; --dst) { - if (*dst == ' ') { - break; - } - } - if (sign_symbol && curr_symbol) { - /* - Only one of $ and +/- can be floating - in any given picture, so the symbol - which comes after the other must be - the one which floats. - */ - if (sign_first) { - *dst = curr_symbol; - } else { - *dst = sign_symbol; - } - } else if (sign_symbol) { - *dst = sign_symbol; - } else { - *dst = curr_symbol; - } - } else { - if (last_fixed_insertion_char == currency) { - *last_fixed_insertion_pos = curr_symbol; - } else { /* + or - */ - *last_fixed_insertion_pos = sign_symbol; - } - } - } - /* 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 { - has_b = 0; /* non-starting characters seen */ - } - } - } - } + if ((*sign_position == '-') && (!neg)) + *sign_position = ' '; - COB_PUT_SIGN (f1, sign); } + static void cob_move_edited_to_display (cob_field *f1, cob_field *f2) { @@ -1331,10 +1435,52 @@ indirect_move (void (*func) (cob_field *src, cob_field *dst), cob_field *src, cob_field *dst, const size_t size, const int scale) { + /************************************************************/ + /* */ + /* this function was modified to call a new version of */ + /* the optimized_move_display_to_edited function */ + /* which is much simpler. However it requires the */ + /* intermediate numeric_display field created below to be */ + /* signed separate with the scale and number of digits to */ + /* match the final destination field. */ + /* */ + /* Note that this function requires that the sign flag on */ + /* the final destination field be set correctly. This */ + /* required changes to the pretty_display_numeric */ + /* function in termio.c, Also the get_num function in */ + /* mlio.c had to change as well. Both of these changes */ + /* involved setting the sign flag correctly on the */ + /* destination field. */ + /* */ + /************************************************************/ + cob_field field; cob_field_attr attr; - - if (size <= 2 * COB_MAX_DIGITS) { + size_t temp_size; + unsigned short digits; + unsigned char buff[COB_MAX_DIGITS + 1] = { 0 }; + + if (COB_FIELD_TYPE(dst) == COB_TYPE_NUMERIC_EDITED) { + temp_size = COB_FIELD_DIGITS(dst) + 1; + digits = (unsigned short)temp_size - 1; + if (COB_FIELD_HAVE_SIGN(dst)) { + COB_FIELD_INIT (temp_size, buff, &attr); + COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, + digits, + COB_FIELD_SCALE(dst), + (COB_FLAG_HAVE_SIGN | COB_FLAG_SIGN_SEPARATE), + NULL); + } else { + COB_FIELD_INIT (temp_size - 1, buff, &attr); + COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, + digits, + COB_FIELD_SCALE(dst), + 0, + NULL); + } + func (src, &field); + optimized_move_display_to_edited (&field, dst); + } else if (size <= 2 * COB_MAX_DIGITS) { unsigned char buff[2 * COB_MAX_DIGITS] = { 0 }; COB_FIELD_INIT (size, buff, &attr); COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, (unsigned short) size, (short) scale, @@ -1507,7 +1653,17 @@ cob_move (cob_field *src, cob_field *dst) cob_move_display_to_binary (src, dst); return; case COB_TYPE_NUMERIC_EDITED: - cob_move_display_to_edited (src, dst); + if (COB_FIELD_DIGITS(src) == COB_FIELD_DIGITS(dst) + && COB_FIELD_SCALE(src) == COB_FIELD_SCALE(dst) + && COB_FIELD_HAVE_SIGN(src) == COB_FIELD_HAVE_SIGN(dst) + && ((COB_FIELD_HAVE_SIGN(src) && (!COB_FIELD_SIGN_LEADING(src) && COB_FIELD_SIGN_SEPARATE (src))) + || COB_FIELD_HAVE_SIGN(src) == 0)) { + optimized_move_display_to_edited(src, dst); + } else { + indirect_move (cob_move_display_to_display, src, dst, + (size_t)(COB_FIELD_DIGITS(src)), + COB_FIELD_SCALE (src)); + } return; case COB_TYPE_ALPHANUMERIC_EDITED: if (COB_FIELD_SCALE (src) < 0 @@ -1928,12 +2084,27 @@ packed_get_long_long (cob_field *field) if (COB_FIELD_NO_SIGN_NIBBLE (field)) { /* Unpack COMP-6 to integer */ + /************************************************************/ + /* if the scale is negative we need to determine if the */ + /* number of digits in the data plus the number of P's is */ + /* greater than the number of digits in the field. */ + /************************************************************/ + if (scale < 0) + { + if (((field->size * 2) - scale) > COB_FIELD_DIGITS (field)) + val = *d++ & 0x0F; + else + val = 0; + } + else + { const size_t offset = COB_FIELD_DIGITS (field) % 2; if (offset == 1) { val = *d++ & 0x0F; } else { val = 0; } + } if (val == 0) { /* Skip leading ZEROs */ while (d <= d_end @@ -1945,6 +2116,20 @@ packed_get_long_long (cob_field *field) val = val * 100 + pack_to_bin[*d++]; } } else { + /************************************************************/ + /* if the scale is negative we need to determine if the */ + /* number of digits in the data plus the number of P's is */ + /* greater than the number of digits in the field. */ + /************************************************************/ + if (scale < 0) + { + if (((field->size * 2) - 1 - scale) > COB_FIELD_DIGITS (field)) + val = *d++ & 0x0F; + else + val = 0; + } + else + { /* Unpack PACKED-DECIMAL / COMP-3 to integer */ const size_t offset = 1 - COB_FIELD_DIGITS (field) % 2; if (offset == 1) { @@ -1952,6 +2137,7 @@ packed_get_long_long (cob_field *field) } else { val = 0; } + } if (val == 0) { /* Skip leading ZEROs */ while (d < d_end diff --git a/libcob/numeric.c b/libcob/numeric.c index 0f4b0dfc9..fe1425429 100644 --- a/libcob/numeric.c +++ b/libcob/numeric.c @@ -2683,7 +2683,7 @@ cob_move_bcd (cob_field *f1, cob_field *f2) } } else { memcpy (fld2, fld1 + fld1_size - llen, llen); - if (fld1_sign) { + if (fld1_sign && llen) { *(fld2 + llen - 1) &= 0xF0; } } @@ -2919,7 +2919,11 @@ static COB_INLINE COB_A_INLINE int count_leading_zeros (unsigned char *ptr_char, int len) { int cntr = 0; - while (*ptr_char++ == 0x00 && cntr++ < len); + while (cntr < len && *ptr_char == 0x00) + { + cntr++; + ptr_char++; + } return cntr; } @@ -3084,7 +3088,7 @@ cob_add_bcd (cob_field *fdst, if ((used_original_scale <= dst_scale) || (used_scale < dest_scale) || (opt & COB_STORE_TRUNCATION) - || !(opt & ~COB_STORE_MASK)) { + || !(opt & (~COB_STORE_MASK | COB_STORE_ROUND))) { check_rounding = 0; check_all_zeros = 0; all_zeros = 0; diff --git a/libcob/profiling.c b/libcob/profiling.c index 0ce3b888d..7a47f2c08 100644 --- a/libcob/profiling.c +++ b/libcob/profiling.c @@ -117,6 +117,10 @@ get_ns_time (void) static void prof_setup_clock () { +#ifdef HAVE_CLOCK_GETTIME + struct timespec ts; +#endif + #ifdef _WIN32 /* Should always succeed on Windows XP and above, but might fail on Windows 2000. Not available on Windows 9x & NT. */ @@ -130,7 +134,6 @@ prof_setup_clock () #ifdef HAVE_CLOCK_GETTIME /* only CLOCK_REALTIME is guaranteed to be defined (and work), not all defined clocks are guaranteed to work */ - struct timespec ts; #ifdef CLOCK_MONOTONIC_RAW if (clock_gettime (CLOCK_MONOTONIC_RAW, &ts) == 0) { clockid = CLOCK_MONOTONIC_RAW; diff --git a/libcob/screenio.c b/libcob/screenio.c index 8f743bbd8..cb76dcace 100644 --- a/libcob/screenio.c +++ b/libcob/screenio.c @@ -4915,6 +4915,66 @@ cob_sys_set_scr_size (unsigned char *line, unsigned char *col) } return 0; #endif +} + + /* save the current stdscr screen to a file */ +int +cob_sys_scr_dump(unsigned char *parm) +{ +#ifdef WITH_EXTENDED_SCREENIO + int result; + FILE *filep; + const char *filename = cob_get_param_str_buffered (1); + + COB_CHK_PARMS (CBL_GC_SCR_DUMP, 1); + init_cob_screen_if_needed (); + + if (filename && (filep = fopen(filename, "wb")) != NULL) + { + refresh(); + result = putwin(stdscr, filep); + fclose(filep); + return result; + } + + return ERR; +#else + return -1; +#endif + +} + + + /* restore the current stdscr screen from a file */ +int cob_sys_scr_restore(unsigned char *parm) +{ +#ifdef WITH_EXTENDED_SCREENIO + int result; + FILE *filep; + const char *filename = cob_get_param_str_buffered (1); + + COB_CHK_PARMS (CBL_GC_SCR_RESTORE, 1); + init_cob_screen_if_needed (); + + if (filename && (filep = fopen(filename, "rb")) != NULL) + { + WINDOW *replacement = getwin(filep); + fclose(filep); + + if (replacement) + { + result = overwrite(replacement, stdscr); + refresh(); + delwin(replacement); + return result; + } + } + + return ERR; +#else + return -1; +#endif + } int diff --git a/libcob/system.def b/libcob/system.def index 201f7e676..969dd2b78 100644 --- a/libcob/system.def +++ b/libcob/system.def @@ -42,6 +42,8 @@ COB_SYSTEM_GEN ("CBL_FLUSH_FILE", 1, 1, cob_sys_flush_file) COB_SYSTEM_GEN ("CBL_GET_CSR_POS", 1, 1, cob_sys_get_csr_pos) COB_SYSTEM_GEN ("CBL_GET_CURRENT_DIR", 3, 3, cob_sys_get_current_dir) COB_SYSTEM_GEN ("CBL_GET_SCR_SIZE", 2, 2, cob_sys_get_scr_size) +COB_SYSTEM_GEN ("CBL_GC_SCR_DUMP", 1, 1, cob_sys_scr_dump) +COB_SYSTEM_GEN ("CBL_GC_SCR_RESTORE", 1, 1, cob_sys_scr_restore) COB_SYSTEM_GEN ("CBL_IMP", 3, 3, cob_sys_imp) COB_SYSTEM_GEN ("CBL_NIMP", 3, 3, cob_sys_nimp) COB_SYSTEM_GEN ("CBL_NOR", 3, 3, cob_sys_nor) diff --git a/libcob/termio.c b/libcob/termio.c index bbb5e9cf9..c44d31ce4 100644 --- a/libcob/termio.c +++ b/libcob/termio.c @@ -109,7 +109,7 @@ static void pretty_display_numeric (cob_field *f, FILE *fp) { unsigned short digits; - const signed short scale = COB_FIELD_SCALE (f); + signed short scale = COB_FIELD_SCALE (f); const int has_sign = COB_FIELD_HAVE_SIGN (f) ? 1 : 0; int size; /* Note: while we only need one pair, the double one works around a bug in @@ -161,17 +161,17 @@ pretty_display_numeric (cob_field *f, FILE *fp) p->times_repeated = scale; ++p; } else { + scale = 0; p->symbol = '9'; p->times_repeated = digits; ++p; } - if (has_sign) { - if (COB_FIELD_SIGN_SEPARATE (f) - && !COB_FIELD_SIGN_LEADING (f)) { - p->symbol = '+'; - p->times_repeated = 1; - ++p; - } + if (has_sign + && COB_FIELD_SIGN_SEPARATE (f) + && !COB_FIELD_SIGN_LEADING (f)) { + p->symbol = '+'; + p->times_repeated = 1; + ++p; } p->symbol = '\0'; @@ -181,7 +181,8 @@ pretty_display_numeric (cob_field *f, FILE *fp) cob_field field; cob_field_attr attr; COB_FIELD_INIT (size, COB_TERM_BUFF, &attr); - COB_ATTR_INIT (COB_TYPE_NUMERIC_EDITED, digits, scale, 0, + COB_ATTR_INIT (COB_TYPE_NUMERIC_EDITED, digits, scale, + has_sign ? (COB_FLAG_HAVE_SIGN | COB_FLAG_SIGN_SEPARATE): 0, (const cob_pic_symbol*)pic); cob_move (f, &field); diff --git a/tests/testsuite.src/data_packed.at b/tests/testsuite.src/data_packed.at index 2c8f3e415..9ebc95d4e 100644 --- a/tests/testsuite.src/data_packed.at +++ b/tests/testsuite.src/data_packed.at @@ -28743,6 +28743,45 @@ AT_CHECK([$COBCRUN_DIRECT ./prog2], [0], [], []) AT_CLEANUP +AT_SETUP([BCD ADD and SUBTRACT, DEFAULT ROUNDING MODE]) +AT_KEYWORDS([fundamental arithmetic PACKED-DECIMAL ROUNDED]) + +# This test was created to test the default rounding mode + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. GAG1. + * + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SOURCE-COMPUTER. VAX-11. + OBJECT-COMPUTER. VAX-11. + SPECIAL-NAMES. + * DECIMAL-POINT IS COMMA. + * + DATA DIVISION. + WORKING-STORAGE SECTION. + 1 TOTO. + 2 RESULT PIC S9(13)V9(2) COMP-3. + 2 RESULT-5 PIC S9(13)V9(5) COMP-3. + + PROCEDURE DIVISION. + DEBUT. + MOVE 3.14659 TO RESULT-5. + MOVE ZERO TO RESULT. + ADD RESULT-5 TO RESULT ROUNDED. + IF RESULT NOT EQUAL 3.15 + DISPLAY "RESULT " RESULT. + GOBACK. +]) + + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + AT_SETUP([BCD ADD and SUBTRACT, all ROUNDED MODEs]) AT_KEYWORDS([fundamental arithmetic SUBTRACT MODE COMP-3 COMP-6 PACKED-DECIMAL AWAY-FROM-ZERO NEAREST-AWAY-FROM-ZERO diff --git a/tests/testsuite.src/run_file.at b/tests/testsuite.src/run_file.at index ae8dc8e43..2fc93cadf 100644 --- a/tests/testsuite.src/run_file.at +++ b/tests/testsuite.src/run_file.at @@ -580,7 +580,7 @@ AT_DATA([prog.cob], [ PROCEDURE DIVISION. * OPEN OUTPUT FILE0 - IF WSFS NOT = "30" + IF WSFS NOT = "35" DISPLAY "STATUS OPENO " WSFS. * STOP RUN. diff --git a/tests/testsuite.src/run_fundamental.at b/tests/testsuite.src/run_fundamental.at index 53ec55967..69d7cd99c 100644 --- a/tests/testsuite.src/run_fundamental.at +++ b/tests/testsuite.src/run_fundamental.at @@ -447,6 +447,1684 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], []) AT_CLEANUP +AT_SETUP([MOVE to edited item (4)]) +AT_KEYWORDS([fundamental editing]) + +AT_DATA([prog.cob], [ + *@OPTIONS MAIN(MAIN) + IDENTIFICATION DIVISION. + + PROGRAM-ID. NUM-EDIT. + ****************************************************************** + *AUTHOR. MICHAEL F GLEASON. * + * TESTING RESULTS OF NUMERIC EDIT * + ****************************************************************** + + ENVIRONMENT DIVISION. + + CONFIGURATION SECTION. + + ****************************************************************** + * * + * THIS PROGRAM WILL ONLY DISPLAY MESSAGES IF THE * + * COMPILER IS GENERATING AN INCORRECT RESULT. * + * * + * IF YOU WISH TO SEE ALL THE DISPLAYS, THEN * + * UNCOMMENT THE SOURCE-COMPUTER LINE BELOW. * + * * + ****************************************************************** + + ****************************************************************** + *SOURCE-COMPUTER. IBM-PC WITH DEBUGGING MODE. + ****************************************************************** + OBJECT-COMPUTER. IBM-PC. + + ****************************************************************** + *REPOSITORY. * + *FUNCTION ALL INTRINSIC. * + ****************************************************************** + + DATA DIVISION. + + WORKING-STORAGE SECTION. + + 01 MISC-WORKING-STORAGE. + 05 WS-COUNT PIC 9(03) VALUE 0. + 05 PIC9V99 PIC S9(09)V99 COMP-3. + 05 MSG PIC X(50). + 05 MSG-1 PIC X(50). + 05 WS-CARDS-BANK-TOT PIC S9(9) COMP-3 VALUE 100. + 05 WS-CARDS-BANK PIC --,---,--9. + 05 EX-1 PIC ---,---,--9. + 05 EX-2 PIC $,$$$,$$9.99CR. + 05 EX-3 PIC ZZ,ZZZ,ZZ9DB. + 05 EX-4 PIC ZZ,ZZZ,ZZ9CR. + 05 EX-5 PIC $,$$$,$$9.99-. + 05 EX-6 PIC +$$$,$$$,$$9. + 05 EX-7 PIC -$,$$$,$$9.99. + 05 EX-8 PIC +$,$$$,$$9.99. + 05 EX-9 PIC +$ZZZZ9.99. *> PROG GUIDE EXMPL + 05 EX-10 PIC -$ZZZZ9.99. + 05 EX-11 PIC ++++,+++,++9. + 05 EX-12 PIC 9BB999BB999B9999. + 05 EX-13 PIC $$$$$//99//99CR. + 05 EX-13-2 PIC $$$$$/B/90/B/90CR. + 05 identifier-1 PIC S9(09) COMP-3. + 05 identifier-2 PIC ----,---,--9. + 05 A-PHONE-NUMBER PIC 9(11) VALUE 15128006789. + 05 Year-Month-Day PIC 9(4)/9(2)/9(2). + 05 YYYY-MM-DD PIC 9(10) VALUE 20240401. + 05 EX-14 PIC +$Z,,B0B,,9.909. + 05 EX-15 PIC ****,***,***.**. + + PROCEDURE DIVISION. + + 000-BEGIN-TEST. + + ****************************************************************** + *TEST-1 * + ****************************************************************** + D DISPLAY "Results for Year-Month-Day " + D "when input is an identifier" + D DISPLAY "PIC 9(4)/9(2)/9(2)." + MOVE YYYY-MM-DD TO Year-Month-Day + IF Year-Month-Day EQUAL "2024/04/01" + MOVE "PASS" TO MSG-1 + D DISPLAY "2024/04/01 IS WHAT I EXPECTED" + ELSE + MOVE "FAIL" TO MSG-1 + ADD 1 TO WS-COUNT + DISPLAY "TEST-1 EXPECTING 2024/04/01. WHAT I GOT WAS " + Year-Month-Day "." + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *TEST-2 * + ****************************************************************** + D DISPLAY "Results identifier-2 for WS-CARDS-BANK" + D DISPLAY "PIC --,---,--9." + MOVE "PASS" TO MSG-1 + MOVE -10 TO WS-CARDS-BANK-TOT + MOVE WS-CARDS-BANK-TOT TO WS-CARDS-BANK + IF WS-CARDS-BANK = " -10" + MOVE SPACE TO MSG + D DISPLAY "-10 " WS-CARDS-BANK MSG + ELSE + MOVE " <---<<< EXPECTING ' -10'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-2 -10 " WS-CARDS-BANK MSG + END-IF + ****************************************************************** + *TEST-3 * + ****************************************************************** + MOVE -100 TO WS-CARDS-BANK-TOT + MOVE WS-CARDS-BANK-TOT TO WS-CARDS-BANK + IF WS-CARDS-BANK = " -100" + MOVE SPACE TO MSG + D DISPLAY "-100 " WS-CARDS-BANK MSG + ELSE + MOVE " <---<<< EXPECTING ' -100'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-3 -100 " WS-CARDS-BANK MSG + END-IF + ****************************************************************** + *TEST-4 * + ****************************************************************** + MOVE -1000 TO WS-CARDS-BANK-TOT + MOVE WS-CARDS-BANK-TOT TO WS-CARDS-BANK + IF WS-CARDS-BANK = " -1,000" + MOVE SPACE TO MSG + D DISPLAY "-1000 " WS-CARDS-BANK + ELSE + MOVE " <---<<< EXPECTING ' -1,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-4 -1000 " WS-CARDS-BANK MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *TEST-5 * + ****************************************************************** + D DISPLAY "MOVE identifier-1 TO identifier-2" + D DISPLAY "PIC ----,---,--9." + MOVE "PASS" TO MSG-1 + MOVE -123456789 TO identifier-1 + MOVE identifier-1 TO identifier-2 + IF identifier-2 = "-123,456,789" + MOVE SPACE TO MSG + D DISPLAY "identifier-1 -123456789 identifier-2 " + D identifier-2 MSG + ELSE + MOVE " <---<<< EXPECTING '-123,456,789'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-5 identifier-1 -123456789 identifier-2 " + identifier-2 MSG + END-IF + ****************************************************************** + *TEST-6 * + ****************************************************************** + MOVE -123 TO identifier-1 + MOVE identifier-1 TO identifier-2 + IF identifier-2 = " -123" + MOVE SPACE TO MSG + D DISPLAY "identifier-1 -123 identifier-2 " + D identifier-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' -123'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-6 identifier-1 -123 identifier-2 " + identifier-2 MSG + END-IF + ****************************************************************** + *TEST-7 * + ****************************************************************** + MOVE -1234 TO identifier-1 + MOVE identifier-1 TO identifier-2 + IF identifier-2 = " -1,234" + MOVE SPACE TO MSG + D DISPLAY "identifier-1 -1234 identifier-2 " + D identifier-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' -1,234'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-7 identifier-1 -1234 identifier-2 " + identifier-2 MSG + END-IF + ****************************************************************** + *TEST-8 * + ****************************************************************** + MOVE -123 TO identifier-2 + IF identifier-2 = " -123" + MOVE SPACE TO MSG + D DISPLAY "literal-1 -123 identifier-2 " + D identifier-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' -123'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-8 literal-1 -123 identifier-2 " + identifier-2 MSG + END-IF + D DISPLAY "literal-1 -123 identifier-2 " + ****************************************************************** + *TEST-9 * + ****************************************************************** + MOVE -1234 TO identifier-2 + IF identifier-2 = " -1,234" + MOVE SPACE TO MSG + D DISPLAY "literal-1 -1234 identifier-2 " + D identifier-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' -1,234'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-9 literal-1 -1234 identifier-2 " + identifier-2 MSG + END-IF + ****************************************************************** + *TEST-10 * + ****************************************************************** + MOVE 123456789 TO identifier-1 + MOVE identifier-1 TO identifier-2 + IF identifier-2 = " 123,456,789" + MOVE SPACE TO MSG + D DISPLAY "identifier-1 123456789 identifier-2 " + D identifier-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' 123,456,789'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-10 identifier-1 123456789 identifier-2 " + identifier-2 MSG + END-IF + ****************************************************************** + *TEST-11 * + ****************************************************************** + MOVE 12 TO identifier-1 + MOVE identifier-1 TO identifier-2 + IF identifier-2 = " 12" + MOVE SPACE TO MSG + D DISPLAY "identifier-1 12 identifier-2 " + D identifier-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' 12'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-11 identifier-1 12 identifier-2 " + identifier-2 MSG + END-IF + ****************************************************************** + *TEST-12 * + ****************************************************************** + MOVE 123 TO identifier-1 + MOVE identifier-1 TO identifier-2 + IF identifier-2 = " 123" + MOVE SPACE TO MSG + D DISPLAY "identifier-1 123 identifier-2 " + D identifier-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' 123'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-12 identifier-1 123 identifier-2 " + identifier-2 MSG + END-IF + ****************************************************************** + *TEST-13 * + ****************************************************************** + MOVE 1234 TO identifier-1 + MOVE identifier-1 TO identifier-2 + IF identifier-2 = " 1,234" + MOVE SPACE TO MSG + D DISPLAY "identifier-1 1234 identifier-2 " + D identifier-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' 1,234'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-13 identifier-1 1234 identifier-2 " + identifier-2 MSG + END-IF + ****************************************************************** + *TEST-14 * + ****************************************************************** + MOVE 123 TO identifier-2 + IF identifier-2 = " 123" + MOVE SPACE TO MSG + D DISPLAY "literal-1 123 identifier-2 " + D identifier-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' 123'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-14 literal-1 123 identifier-2 " + identifier-2 MSG + END-IF + ****************************************************************** + *TEST-15 * + ****************************************************************** + MOVE 1234 TO identifier-2 + IF identifier-2 = " 1,234" + MOVE SPACE TO MSG + D DISPLAY "literal-1 1234 identifier-2 " + D identifier-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' 1,234'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-15 literal-1 1234 identifier-2 " + identifier-2 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-1A * + ****************************************************************** + D DISPLAY "Results for EX-1 when input is a literal" + D DISPLAY "PIC ---,---,--9." + MOVE "PASS" TO MSG-1 + MOVE -10 TO EX-1 + IF EX-1 = " -10" + MOVE SPACE TO MSG + D DISPLAY "-10 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' -10'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.01 -10 " EX-1 MSG + END-IF + + MOVE -100 TO EX-1 + IF EX-1 = " -100" + MOVE SPACE TO MSG + D DISPLAY "-100 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' -100'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.02 -100 " EX-1 MSG + END-IF + + MOVE -1000 TO EX-1 + IF EX-1 = " -1,000" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' -1,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.03 -1000 " EX-1 MSG + END-IF + + MOVE -10000 TO EX-1 + IF EX-1 = " -10,000" + MOVE SPACE TO MSG + D DISPLAY "-10000 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' -10,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.04 -10000 " EX-1 MSG + END-IF + + MOVE 10 TO EX-1 + IF EX-1 = " 10" + MOVE SPACE TO MSG + D DISPLAY " 10 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' 10'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.05 10 " EX-1 MSG + END-IF + + MOVE 100 TO EX-1 + IF EX-1 = " 100" + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' 100'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.06 100 " EX-1 MSG + END-IF + + MOVE 1000 TO EX-1 + IF EX-1 = " 1,000" + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' 1,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.07 1000 " EX-1 MSG + END-IF + + MOVE 10000 TO EX-1 + IF EX-1 = " 10,000" + MOVE SPACE TO MSG + D DISPLAY " 10000 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' 10,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.08 10000 " EX-1 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-1B * + ****************************************************************** + D DISPLAY "Results for EX-1 when input is an identifier" + D DISPLAY "PIC ---,---,--9." + MOVE "PASS" TO MSG-1 + MOVE -10 TO identifier-1 + MOVE identifier-1 TO EX-1 + IF EX-1 = " -10" + MOVE SPACE TO MSG + D DISPLAY "-10 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' -10'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.09 -10 " EX-1 MSG + END-IF + + MOVE -100 TO identifier-1 + MOVE identifier-1 TO EX-1 + IF EX-1 = " -100" + MOVE SPACE TO MSG + D DISPLAY "-100 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' -100'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.10 -100 " EX-1 MSG + END-IF + + MOVE -1000 TO identifier-1 + MOVE identifier-1 TO EX-1 + IF EX-1 = " -1,000" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' -1,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.11 -1000 " EX-1 MSG + END-IF + + MOVE -10000 TO identifier-1 + MOVE identifier-1 TO EX-1 + IF EX-1 = " -10,000" + MOVE SPACE TO MSG + D DISPLAY "-10000 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' -10,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.12 -10000 " EX-1 MSG + END-IF + + MOVE 10 TO identifier-1 + MOVE identifier-1 TO EX-1 + IF EX-1 = " 10" + MOVE SPACE TO MSG + D DISPLAY " 10 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' 10'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.13 10 " EX-1 MSG + END-IF + + MOVE 100 TO identifier-1 + MOVE identifier-1 TO EX-1 + IF EX-1 = " 100" + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' 100'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.14 100 " EX-1 MSG + END-IF + + MOVE 1000 TO identifier-1 + MOVE identifier-1 TO EX-1 + IF EX-1 = " 1,000" + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' 1,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.15 1000 " EX-1 MSG + END-IF + + MOVE 10000 TO identifier-1 + MOVE identifier-1 TO EX-1 + IF EX-1 = " 10,000" + MOVE SPACE TO MSG + D DISPLAY " 10000 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' 10,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.16 10000 " EX-1 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-2 * + ****************************************************************** + D DISPLAY "Results for EX-2 when input is a literal" + D DISPLAY "PIC $,$$$,$$9.99CR." + MOVE "PASS" TO MSG-1 + MOVE 100 TO EX-2 + IF EX-2 = " $100.00 " + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' $100.00 '" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-2.01 100 " EX-2 MSG + END-IF + + MOVE -100 TO EX-2 + IF EX-2 = " $100.00CR" + MOVE SPACE TO MSG + D DISPLAY " -100 " EX-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' $100.00CR'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-2.02 -100 " EX-2 MSG + END-IF + + MOVE 1000 TO EX-2 + IF EX-2 = " $1,000.00 " + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' $1,000.00 '" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-2.03 1000 " EX-2 MSG + END-IF + + MOVE -1000 TO EX-2 + IF EX-2 = " $1,000.00CR" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' $1,000.00CR'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-2.04 -1000 " EX-2 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + D DISPLAY "Results for EX-2 when input is an identifier " + D DISPLAY "PIC $,$$$,$$9.99CR." + MOVE "PASS" TO MSG-1 + MOVE 100 TO identifier-1 + MOVE identifier-1 TO EX-2 + IF EX-2 = " $100.00 " + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' $100.00 '" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-2.05 100 " EX-2 MSG + END-IF + + MOVE -100 TO identifier-1 + MOVE identifier-1 TO EX-2 + IF EX-2 = " $100.00CR" + MOVE SPACE TO MSG + D DISPLAY " -100 " EX-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' $100.00CR'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-2.06 -100 " EX-2 MSG + END-IF + + MOVE 1000 TO identifier-1 + MOVE identifier-1 TO EX-2 + IF EX-2 = " $1,000.00 " + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' $1,000.00 '" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-2.07 1000 " EX-2 MSG + END-IF + + MOVE -1000 TO identifier-1 + MOVE identifier-1 TO EX-2 + IF EX-2 = " $1,000.00CR" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' $1,000.00CR'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-2.08 -1000 " EX-2 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-3 * + ****************************************************************** + D DISPLAY "Results for EX-3 when input is a literal" + D DISPLAY "PIC ZZ,ZZZ,ZZ9DB." + MOVE "PASS" TO MSG-1 + MOVE 100 TO EX-3 + IF EX-3 = " 100 " + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-3 MSG + ELSE + MOVE " <---<<< EXPECTING ' 100 '" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-3.01 100 " EX-3 MSG + END-IF + + MOVE -100 TO EX-3 + IF EX-3 = " 100DB" + MOVE SPACE TO MSG + D DISPLAY "-100 " EX-3 MSG + ELSE + MOVE " <---<<< EXPECTING ' 100DB'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-3.02 -100 " EX-3 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-4 * + ****************************************************************** + D DISPLAY "Results for EX-4 when input is a literal" + D DISPLAY "PIC ZZ,ZZZ,ZZ9CR." + MOVE "PASS" TO MSG-1 + MOVE 1000 TO EX-4 + IF EX-4 = " 1,000 " + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-4 MSG + ELSE + MOVE " <---<<< EXPECTING ' 1,000 '" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-4.01 1000 " EX-4 MSG + END-IF + + MOVE -1000 TO EX-4 + IF EX-4 = " 1,000CR" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-4 MSG + ELSE + MOVE " <---<<< EXPECTING ' 1,000CR'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-4.02 -1000 " EX-4 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-5 * + ****************************************************************** + D DISPLAY "Results for EX-5 when input is an identifier " + D DISPLAY "PIC $,$$$,$$9.99-." + MOVE "PASS" TO MSG-1 + MOVE -10 TO identifier-1 + MOVE identifier-1 TO EX-5 + IF EX-5 = " $10.00-" + MOVE SPACE TO MSG + D DISPLAY "-10 " EX-5 MSG + ELSE + MOVE " <---<<< EXPECTING ' $10.00-'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-5.01 -10 " EX-5 MSG + END-IF + + MOVE -100 TO identifier-1 + MOVE identifier-1 TO EX-5 + IF EX-5 = " $100.00-" + MOVE SPACE TO MSG + D DISPLAY "-100 " EX-5 MSG + ELSE + MOVE " <---<<< EXPECTING ' $100.00-'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-5.02 -100 " EX-5 MSG + END-IF + + MOVE -1000 TO identifier-1 + MOVE identifier-1 TO EX-5 + IF EX-5 = " $1,000.00-" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-5 MSG + ELSE + MOVE " <---<<< EXPECTING ' $1,000.00-'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-5.03 -1000 " EX-5 MSG + END-IF + + MOVE -10000 TO identifier-1 + MOVE identifier-1 TO EX-5 + IF EX-5 = " $10,000.00-" + MOVE SPACE TO MSG + D DISPLAY "-10000 " EX-5 MSG + ELSE + MOVE " <---<<< EXPECTING ' $10,000.00-'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-5.04 -10000 " EX-5 MSG + END-IF + + MOVE 10 TO identifier-1 + MOVE identifier-1 TO EX-5 + IF EX-5 = " $10.00 " + MOVE SPACE TO MSG + D DISPLAY " 10 " EX-5 MSG + ELSE + MOVE " <---<<< EXPECTING ' $10.00 '" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-5.05 10 " EX-5 MSG + END-IF + + MOVE 100 TO identifier-1 + MOVE identifier-1 TO EX-5 + IF EX-5 = " $100.00 " + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-5 MSG + ELSE + MOVE " <---<<< EXPECTING ' $100.00 '" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-5.06 100 " EX-5 MSG + END-IF + + MOVE 1000 TO identifier-1 + MOVE identifier-1 TO EX-5 + IF EX-5 = " $1,000.00 " + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-5 MSG + ELSE + MOVE " <---<<< EXPECTING ' $1,000.00 '" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-5.07 1000 " EX-5 MSG + END-IF + + MOVE 10000 TO identifier-1 + MOVE identifier-1 TO EX-5 + IF EX-5 = " $10,000.00 " + MOVE SPACE TO MSG + D DISPLAY " 10000 " EX-5 MSG + ELSE + MOVE " <---<<< EXPECTING ' $10,000.00 '" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-5.08 10000 " EX-5 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-6 * + ****************************************************************** + D DISPLAY "Results for EX-6 when input is an identifier" + D DISPLAY "PIC +$$$,$$$,$$9." + MOVE "PASS" TO MSG-1 + MOVE -10 TO identifier-1 + MOVE identifier-1 TO EX-6 + IF EX-6 = "- $10" + MOVE SPACE TO MSG + D DISPLAY "-10 " EX-6 MSG + ELSE + MOVE " <---<<< EXPECTING '- $10'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-6.01 -10 " EX-6 MSG + END-IF + + MOVE -100 TO identifier-1 + MOVE identifier-1 TO EX-6 + IF EX-6 = "- $100" + MOVE SPACE TO MSG + D DISPLAY "-100 " EX-6 MSG + ELSE + MOVE " <---<<< EXPECTING '- $100'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-6.02 -100 " EX-6 MSG + END-IF + + MOVE -1000 TO identifier-1 + MOVE identifier-1 TO EX-6 + IF EX-6 = "- $1,000" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-6 MSG + ELSE + MOVE " <---<<< EXPECTING '- $1,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-6.03 -1000 " EX-6 MSG + END-IF + + MOVE -10000 TO identifier-1 + MOVE identifier-1 TO EX-6 + IF EX-6 = "- $10,000" + MOVE SPACE TO MSG + D DISPLAY "-10000 " EX-6 MSG + ELSE + MOVE " <---<<< EXPECTING '- $10,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-6.04 -10000 " EX-6 MSG + END-IF + + MOVE 10 TO identifier-1 + MOVE identifier-1 TO EX-6 + IF EX-6 = "+ $10" + MOVE SPACE TO MSG + D DISPLAY " 10 " EX-6 MSG + ELSE + MOVE " <---<<< EXPECTING '+ $10'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-6.05 10 " EX-6 MSG + END-IF + + MOVE 100 TO identifier-1 + MOVE identifier-1 TO EX-6 + IF EX-6 = "+ $100" + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-6 MSG + ELSE + MOVE " <---<<< EXPECTING '+ $100'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-6.06 100 " EX-6 MSG + END-IF + + MOVE 1000 TO identifier-1 + MOVE identifier-1 TO EX-6 + IF EX-6 = "+ $1,000" + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-6 MSG + ELSE + MOVE " <---<<< EXPECTING '+ $1,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-6.07 1000 " EX-6 MSG + END-IF + + MOVE 10000 TO identifier-1 + MOVE identifier-1 TO EX-6 + IF EX-6 = "+ $10,000" + MOVE SPACE TO MSG + D DISPLAY " 10000 " EX-6 MSG + ELSE + MOVE " <---<<< EXPECTING '+ $10,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-6.08 10000 " EX-6 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-7 * + ****************************************************************** + D DISPLAY "Results for EX-7 when input is an identifier" + D DISPLAY "PIC -$,$$$,$$9.99." + MOVE "PASS" TO MSG-1 + MOVE -10 TO identifier-1 + MOVE identifier-1 TO EX-7 + IF EX-7 = "- $10.00" + MOVE SPACE TO MSG + D DISPLAY "-10 " EX-7 MSG + ELSE + MOVE " <---<<< EXPECTING '- $10.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-7.01 -10 " EX-7 MSG + END-IF + + MOVE -100 TO identifier-1 + MOVE identifier-1 TO EX-7 + IF EX-7 = "- $100.00" + MOVE SPACE TO MSG + D DISPLAY "-100 " EX-7 MSG + ELSE + MOVE " <---<<< EXPECTING '- $100.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-7.02 -100 " EX-7 MSG + END-IF + + MOVE -1000 TO identifier-1 + MOVE identifier-1 TO EX-7 + IF EX-7 = "- $1,000.00" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-7 MSG + ELSE + MOVE " <---<<< EXPECTING '- $1,000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-7.03 -1000 " EX-7 MSG + END-IF + + MOVE -10000 TO identifier-1 + MOVE identifier-1 TO EX-7 + IF EX-7 = "- $10,000.00" + MOVE SPACE TO MSG + D DISPLAY "-10000 " EX-7 MSG + ELSE + MOVE " <---<<< EXPECTING '- $10,000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-7.04 -10000 " EX-7 MSG + END-IF + + MOVE 10 TO identifier-1 + MOVE identifier-1 TO EX-7 + IF EX-7 = " $10.00" + MOVE SPACE TO MSG + D DISPLAY " 10 " EX-7 MSG + ELSE + MOVE " <---<<< EXPECTING ' $10.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-7.05 10 " EX-7 MSG + END-IF + + MOVE 100 TO identifier-1 + MOVE identifier-1 TO EX-7 + IF EX-7 = " $100.00" + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-7 MSG + ELSE + MOVE " <---<<< EXPECTING ' $100.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-7.06 100 " EX-7 MSG + END-IF + + MOVE 1000 TO identifier-1 + MOVE identifier-1 TO EX-7 + IF EX-7 = " $1,000.00" + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-7 MSG + ELSE + MOVE " <---<<< EXPECTING ' $1,000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-7.07 1000 " EX-7 MSG + END-IF + + MOVE 10000 TO identifier-1 + MOVE identifier-1 TO EX-7 + IF EX-7 = " $10,000.00" + MOVE SPACE TO MSG + D DISPLAY " 10000 " EX-7 MSG + ELSE + MOVE " <---<<< EXPECTING ' $10,000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-7.08 10000 " EX-7 MSG + END-IF + D DISPLAY "------------------"MSG-1 + ****************************************************************** + *EX-8 * + ****************************************************************** + D DISPLAY "Results for EX-8 when input is an identifier" + D DISPLAY "PIC +$,$$$,$$9.99." + MOVE "PASS" TO MSG-1 + MOVE -10 TO identifier-1 + MOVE identifier-1 TO EX-8 + IF EX-8 = "- $10.00" + MOVE SPACE TO MSG + D DISPLAY "-10 " EX-8 MSG + ELSE + MOVE " <---<<< EXPECTING '- $10.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-8.01 -10 " EX-8 MSG + END-IF + + MOVE -100 TO identifier-1 + MOVE identifier-1 TO EX-8 + IF EX-8 = "- $100.00" + MOVE SPACE TO MSG + D DISPLAY "-100 " EX-8 MSG + ELSE + MOVE " <---<<< EXPECTING '- $100.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-8.02 -100 " EX-8 MSG + END-IF + + MOVE -1000 TO identifier-1 + MOVE identifier-1 TO EX-8 + IF EX-8 = "- $1,000.00" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-8 MSG + ELSE + MOVE " <---<<< EXPECTING '- $1,000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-8.03 -1000 " EX-8 MSG + END-IF + + MOVE -10000 TO identifier-1 + MOVE identifier-1 TO EX-8 + IF EX-8 = "- $10,000.00" + MOVE SPACE TO MSG + D DISPLAY "-10000 " EX-8 MSG + ELSE + MOVE " <---<<< EXPECTING '- $10,000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-8.04 -10000 " EX-8 MSG + END-IF + + MOVE 10 TO identifier-1 + MOVE identifier-1 TO EX-8 + IF EX-8 = "+ $10.00" + MOVE SPACE TO MSG + D DISPLAY " 10 " EX-8 MSG + ELSE + MOVE " <---<<< EXPECTING '+ $10.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-8.05 10 " EX-8 MSG + END-IF + + MOVE 100 TO identifier-1 + MOVE identifier-1 TO EX-8 + IF EX-8 = "+ $100.00" + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-8 MSG + ELSE + MOVE " <---<<< EXPECTING '+ $100.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-8.06 100 " EX-8 MSG + END-IF + + MOVE 1000 TO identifier-1 + MOVE identifier-1 TO EX-8 + IF EX-8 = "+ $1,000.00" + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-8 MSG + ELSE + MOVE " <---<<< EXPECTING '+ $1,000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-8.07 1000 " EX-8 MSG + END-IF + + MOVE 10000 TO identifier-1 + MOVE identifier-1 TO EX-8 + IF EX-8 = "+ $10,000.00" + MOVE SPACE TO MSG + D DISPLAY " 10000 " EX-8 MSG + ELSE + MOVE " <---<<< EXPECTING '+ $10,000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-8.08 10000 " EX-8 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-9 * + ****************************************************************** + D DISPLAY "Results for EX-9 when input is an identifier" + D " and a literal" + D DISPLAY "PIC +$ZZZZ9.99. *> PROG GUIDE EXMPL" + D DISPLAY " The -$ signs don't float is correct" + D DISPLAY "According to P.G. the sign and $ should float" + D DISPLAY "In reality and by the COBOL STANDARDS, it doesn't" + MOVE "PASS" TO MSG-1 + MOVE 1 TO EX-9 + D DISPLAY "literal-1 1 " EX-9 + MOVE -1 TO EX-9 + D DISPLAY "literal-1 -1 " EX-9 + D " <---<<< Should be -$ when negative" + MOVE -10 TO identifier-1 + MOVE identifier-1 TO EX-9 + IF EX-9 = "-$ 10.00" + MOVE SPACE TO MSG + D DISPLAY "-10 " EX-9 MSG + ELSE + MOVE " <---<<< EXPECTING '-$ 10.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-9.01 -10 " EX-9 MSG + END-IF + + MOVE -100 TO identifier-1 + MOVE identifier-1 TO EX-9 + IF EX-9 = "-$ 100.00" + MOVE SPACE TO MSG + D DISPLAY "-100 " EX-9 MSG + ELSE + MOVE " <---<<< EXPECTING '-$ 100.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-9.02 -100 " EX-9 MSG + END-IF + + MOVE -1000 TO identifier-1 + MOVE identifier-1 TO EX-9 + IF EX-9 = "-$ 1000.00" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-9 MSG + ELSE + MOVE " <---<<< EXPECTING '-$ 1000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-9.03 -1000 " EX-9 MSG + END-IF + + MOVE -10000 TO identifier-1 + MOVE identifier-1 TO EX-9 + IF EX-9 = "-$10000.00" + MOVE SPACE TO MSG + D DISPLAY "-10000 " EX-9 MSG + ELSE + MOVE " <---<<< EXPECTING '-$10000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-9.04 -10000 " EX-9 MSG + END-IF + + MOVE 10 TO identifier-1 + MOVE identifier-1 TO EX-9 + IF EX-9 = "+$ 10.00" + MOVE SPACE TO MSG + D DISPLAY " 10 " EX-9 MSG + ELSE + MOVE " <---<<< EXPECTING '+$ 10.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-9.05 10 " EX-9 MSG + END-IF + + MOVE 100 TO identifier-1 + MOVE identifier-1 TO EX-9 + IF EX-9 = "+$ 100.00" + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-9 MSG + ELSE + MOVE " <---<<< EXPECTING '+$ 100.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-9.06 100 " EX-9 MSG + END-IF + + MOVE 1000 TO identifier-1 + MOVE identifier-1 TO EX-9 + IF EX-9 = "+$ 1000.00" + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-9 MSG + ELSE + MOVE " <---<<< EXPECTING '+$ 1000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-9.07 1000 " EX-9 MSG + END-IF + + MOVE 10000 TO identifier-1 + MOVE identifier-1 TO EX-9 + IF EX-9 = "+$10000.00" + MOVE SPACE TO MSG + D DISPLAY " 10000 " EX-9 MSG + ELSE + MOVE " <---<<< EXPECTING '+$10000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-9.08 10000 " EX-9 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-10 * + ****************************************************************** + D DISPLAY "Results for EX-10 when input is an identifier" + D " and a literal" + D DISPLAY "PIC -$ZZZZ9.99." + D DISPLAY " The -$ signs don't float is correct" + D DISPLAY "According to P.G. the sign and $ should float" + D DISPLAY "In reality and by the COBOL STANDARDS, it doesn't" + MOVE "PASS" TO MSG-1 + MOVE 1 TO EX-10 + D DISPLAY "literal-1 1 " EX-10 + D " <---<<< Should be just $ not -$ when positive" + MOVE -1 TO EX-10 + D DISPLAY "literal-1 -1 " EX-10 + MOVE -10 TO identifier-1 + MOVE identifier-1 TO EX-10 + IF EX-10 = "-$ 10.00" + MOVE SPACE TO MSG + D DISPLAY "-10 " EX-10 MSG + ELSE + MOVE " <---<<< EXPECTING '-$ 10.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-10.01 -10 " EX-10 MSG + END-IF + + MOVE -100 TO identifier-1 + MOVE identifier-1 TO EX-10 + IF EX-10 = "-$ 100.00" + MOVE SPACE TO MSG + D DISPLAY "-100 " EX-10 MSG + ELSE + MOVE " <---<<< EXPECTING '-$ 100.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-10.02 -100 " EX-10 MSG + END-IF + + MOVE -1000 TO identifier-1 + MOVE identifier-1 TO EX-10 + IF EX-10 = "-$ 1000.00" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-10 MSG + ELSE + MOVE " <---<<< EXPECTING '-$ 1000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-10.03 -1000 " EX-10 MSG + END-IF + + MOVE -10000 TO identifier-1 + MOVE identifier-1 TO EX-10 + IF EX-10 = "-$10000.00" + MOVE SPACE TO MSG + D DISPLAY "-10000 " EX-10 MSG + ELSE + MOVE " <---<<< EXPECTING '-$10000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-10.04 -10000 " EX-10 MSG + END-IF + + MOVE 10 TO identifier-1 + MOVE identifier-1 TO EX-10 + IF EX-10 = " $ 10.00" + MOVE SPACE TO MSG + D DISPLAY " 10 " EX-10 MSG + ELSE + MOVE " <---<<< EXPECTING ' $ 10.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-10.05 10 " EX-10 MSG + END-IF + + MOVE 100 TO identifier-1 + MOVE identifier-1 TO EX-10 + IF EX-10 = " $ 100.00" + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-10 MSG + ELSE + MOVE " <---<<< EXPECTING ' $ 100.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-10.06 100 " EX-10 MSG + END-IF + + MOVE 1000 TO identifier-1 + MOVE identifier-1 TO EX-10 + IF EX-10 = " $ 1000.00" + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-10 MSG + ELSE + MOVE " <---<<< EXPECTING ' $ 1000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-10.07 1000 " EX-10 MSG + END-IF + + MOVE 10000 TO identifier-1 + MOVE identifier-1 TO EX-10 + IF EX-10 = " $10000.00" + MOVE SPACE TO MSG + D DISPLAY " 10000 " EX-10 MSG + ELSE + MOVE " <---<<< EXPECTING ' $10000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-10.08 10000 " EX-10 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-11A * + ****************************************************************** + D DISPLAY "Results for EX-11 when input is a literal" + D DISPLAY "PIC ++++,+++,++9." + MOVE "PASS" TO MSG-1 + MOVE -10 TO EX-11 + IF EX-11 = " -10" + MOVE SPACE TO MSG + D DISPLAY "-10 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' -10'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.01 -10 " EX-11 MSG + END-IF + + MOVE -100 TO EX-11 + IF EX-11 = " -100" + MOVE SPACE TO MSG + D DISPLAY "-100 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' -100'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.02 -100 " EX-11 MSG + END-IF + + MOVE -1000 TO EX-11 + IF EX-11 = " -1,000" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' -1,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.03 -1000 " EX-11 MSG + END-IF + + MOVE -10000 TO EX-11 + IF EX-11 = " -10,000" + MOVE SPACE TO MSG + D DISPLAY "-10000 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' -10,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.04 -10000 " EX-11 MSG + END-IF + + MOVE 10 TO EX-11 + IF EX-11 = " +10" + MOVE SPACE TO MSG + D DISPLAY " 10 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' +10'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.05 10 " EX-11 MSG + END-IF + + MOVE 100 TO EX-11 + IF EX-11 = " +100" + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' +100'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.06 100 " EX-11 MSG + END-IF + + MOVE 1000 TO EX-11 + IF EX-11 = " +1,000" + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' +1,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.07 1000 " EX-11 MSG + END-IF + + MOVE 10000 TO EX-11 + IF EX-11 = " +10,000" + MOVE SPACE TO MSG + D DISPLAY " 10000 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' +10,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.08 10000 " EX-11 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-11B * + ****************************************************************** + D DISPLAY "Results for EX-11 when input is an identifier" + D DISPLAY "PIC ++++,+++,++9." + MOVE "PASS" TO MSG-1 + MOVE -10 TO identifier-1 + MOVE identifier-1 TO EX-11 + IF EX-11 = " -10" + MOVE SPACE TO MSG + D DISPLAY "-10 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' -10'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.09 -10 " EX-11 MSG + END-IF + D DISPLAY "-10 " EX-11 MSG + + MOVE -100 TO identifier-1 + MOVE identifier-1 TO EX-11 + IF EX-11 = " -100" + MOVE SPACE TO MSG + D DISPLAY "-100 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' -100'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.10 -100 " EX-11 MSG + END-IF + + MOVE -1000 TO identifier-1 + MOVE identifier-1 TO EX-11 + IF EX-11 = " -1,000" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' -1,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.11 -1000 " EX-11 MSG + END-IF + + MOVE -10000 TO identifier-1 + MOVE identifier-1 TO EX-11 + IF EX-11 = " -10,000" + MOVE SPACE TO MSG + D DISPLAY "-10000 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' -10,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.12 -10000 " EX-11 MSG + END-IF + + MOVE 10 TO identifier-1 + MOVE identifier-1 TO EX-11 + IF EX-11 = " +10" + MOVE SPACE TO MSG + D DISPLAY " 10 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' +10'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.13 10 " EX-11 MSG + END-IF + + MOVE 100 TO identifier-1 + MOVE identifier-1 TO EX-11 + IF EX-11 = " +100" + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' +100'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.14 100 " EX-11 MSG + END-IF + + MOVE 1000 TO identifier-1 + MOVE identifier-1 TO EX-11 + IF EX-11 = " +1,000" + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' +1,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.15 1000 " EX-11 MSG + END-IF + + MOVE 10000 TO identifier-1 + MOVE identifier-1 TO EX-11 + IF EX-11 = " +10,000" + MOVE SPACE TO MSG + D DISPLAY " 10000 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' +10,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.16 10000 " EX-11 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-12 * + ****************************************************************** + D DISPLAY "Results for EX-12 when input is an identifier" + D DISPLAY "PIC 9BB999BB999B9999." + MOVE A-PHONE-NUMBER TO EX-12 + MOVE "(" TO EX-12 (3:1) + MOVE ")" TO EX-12 (7:1) + IF EX-12 EQUAL "1 (512) 800 6789" + MOVE "PASS" TO MSG-1 + D DISPLAY "HURAH, '" EX-12 "' IS WHAT I WANTED." + ELSE + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-12.01 EXPECTING '1 (512) 800 6789' NOT '" + EX-12 "'" + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-13 * + ****************************************************************** + D DISPLAY "Results for EX-13 when input is an identifier" + D DISPLAY "PIC $$$$$//99//99CR" + MOVE -123456 TO identifier-1 + MOVE identifier-1 TO EX-13 + IF EX-13 EQUAL " $12//34//56CR" + MOVE "PASS" TO MSG-1 + D DISPLAY " $12//34//56CR IS WHAT I EXPECTED" + ELSE + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-13.01 EXPECTING ==> '$12//34//56CR' <==" + " WHAT I GOT WAS ==>'" + EX-13 "'<==" + END-IF + + MOVE 10 TO identifier-1 + MOVE identifier-1 TO EX-13 + IF EX-13 EQUAL " $//00//10 " + MOVE "PASS" TO MSG-1 + D DISPLAY " $//00//10 IS WHAT I EXPECTED" + ELSE + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-13.02 EXPECTING ==>' $//00//10 ' " + "WHAT I GOT WAS ==>'" + EX-13 "'<==" + D DISPLAY "------------------" MSG-1 + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-13-2 * + ****************************************************************** + D DISPLAY "Results for EX-13-2 when input is an identifier" + D DISPLAY "PIC $$$$$/B/90/B/90CR" + MOVE -12345 TO identifier-1 + MOVE identifier-1 TO EX-13-2 + IF EX-13-2 EQUAL " $123/ /40/ /50CR" + MOVE "PASS" TO MSG-1 + D DISPLAY " $123/ /40/ /50CR IS WHAT I EXPECTED" + D DISPLAY "------------------" MSG-1 + ELSE + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-13-2.1 EXPECTING $123/ /40/ /50CR " + "WHAT I GOT WAS ==>'" + EX-13-2(1:) "'<==" + D DISPLAY "------------------" MSG-1 + END-IF + ****************************************************************** + *EX-14 * + ****************************************************************** + MOVE -123456.7895 TO EX-14. + IF EX-14(1:) EQUAL "-$5,, 0 ,,6.708" + MOVE "PASS" TO MSG-1 + D DISPLAY "EX-14 ==> IS WHAT I EXPECTED '" EX-14(1:) "'" + D DISPLAY "------------------" MSG-1 + ELSE + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-14 ==> WHAT I EXPECTED '-$5,, 0 ,,6.708'" + DISPLAY "EX-14 ==> WHAT I GOT '" EX-14(1:) "'" + D DISPLAY "------------------" MSG-1 + END-IF + + ****************************************************************** + *EX-15 * + * It does not matter if a + or - amount is moved to this edit, * + * the result will be the same. * + ****************************************************************** + D DISPLAY "Results for EX-15 when input is an identifier" + D DISPLAY "PIC ****,***,***.**." + MOVE "PASS" TO MSG-1 + MOVE -123.45 TO PIC9V99 + MOVE PIC9V99 TO EX-15 + IF EX-15 = "*********123.45" + MOVE SPACE TO MSG + D DISPLAY "-123.45 " EX-15 MSG + ELSE + ADD 1 TO WS-COUNT + MOVE " <---<<< EXPECTING '*********123.45'" TO MSG + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-15.1 -123.45 " EX-15 MSG + END-IF + + MOVE -1234.56 TO PIC9V99 + MOVE PIC9V99 TO EX-15 + IF EX-15 = "*******1,234.56" + MOVE SPACE TO MSG + D DISPLAY "-1234.56 " EX-15 MSG + ELSE + ADD 1 TO WS-COUNT + MOVE " <---<<< EXPECTING '*******1,234.56'" TO MSG + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-15.2 -1234.56 " EX-15 MSG + END-IF + + MOVE -12345.67 TO PIC9V99 + MOVE PIC9V99 TO EX-15 + IF EX-15 = "******12,345.67" + MOVE SPACE TO MSG + D DISPLAY "-12345.67 " EX-15 MSG + ELSE + ADD 1 TO WS-COUNT + MOVE " <---<<< EXPECTING '******12,345.67'" TO MSG + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-15.3 -12345.67 " EX-15 MSG + END-IF + + MOVE 10 TO PIC9V99 + MOVE PIC9V99 TO EX-15 + IF EX-15 = "**********10.00" + MOVE SPACE TO MSG + D DISPLAY " 10 " EX-15 MSG + ELSE + ADD 1 TO WS-COUNT + MOVE " <---<<< EXPECTING '**********10.00'" TO MSG + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-15.4 10 " EX-15 MSG + END-IF + + MOVE 100 TO PIC9V99 + MOVE PIC9V99 TO EX-15 + IF EX-15 = "*********100.00" + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-15 MSG + ELSE + ADD 1 TO WS-COUNT + MOVE " <---<<< EXPECTING '*********100.00'" TO MSG + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-15.5 100 " EX-15 MSG + END-IF + + MOVE 100000000 TO PIC9V99 + MOVE PIC9V99 TO EX-15 + IF EX-15 = "*100,000,000.00" + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-15 MSG + ELSE + ADD 1 TO WS-COUNT + MOVE " <---<<< EXPECTING '*100,000,000.00'" TO MSG + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-15.6 100 " EX-15 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + * End of process. Display error total if not zero * + ****************************************************************** + IF WS-COUNT > ZERO + MOVE "TESTS FAILED" TO MSG-1 + DISPLAY "------------------" WS-COUNT SPACE MSG-1(1 : 12) + "------------------" + END-IF + + GOBACK. +]) + +AT_CHECK([$COMPILE -Wno-truncate prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], []) + +AT_CLEANUP + + AT_SETUP([MOVE to item with simple and floating insertion]) AT_KEYWORDS([fundamental edited editing]) @@ -459,6 +2137,9 @@ AT_DATA([prog.cob], [ 01 num-1 PIC -*B*99. 01 num-2 PIC $BB**,***.**. 01 num-3 PIC $BB--,---.--. + 01 num-4 PIC $,$$$,$$9.99CR. + 01 num-5 PIC --,---,--9. + 01 num-packed-1 PIC S9(9)V999 COMP-3. PROCEDURE DIVISION. MOVE -123 TO num-1 @@ -469,6 +2150,39 @@ AT_DATA([prog.cob], [ MOVE 1234.56 TO num-3 DISPLAY ">" num-3 "<" + + MOVE 456789 to num-4 + DISPLAY ">" num-4 "<" + + MOVE -100 to num-5 + DISPLAY ">" num-5 "<" + + MOVE -1000 to num-5 + DISPLAY ">" num-5 "<" + + MOVE -123 TO num-packed-1 + MOVE num-packed-1 TO num-1 + DISPLAY ">" num-1 "<" + + MOVE 1234.56 TO num-packed-1 + MOVE num-packed-1 TO num-2 + DISPLAY ">" num-2 "<" + + MOVE 1234.56 TO num-packed-1 + MOVE num-packed-1 TO num-3 + DISPLAY ">" num-3 "<" + + MOVE 123456789 to num-packed-1 + MOVE num-packed-1 TO num-4 + DISPLAY ">" num-4 "<" + + MOVE -100 to num-packed-1 + MOVE num-packed-1 TO num-5 + DISPLAY ">" num-5 "<" + + MOVE -1000 to num-packed-1 + MOVE num-packed-1 TO num-5 + DISPLAY ">" num-5 "<" . ]) @@ -477,6 +2191,15 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [>-**123< >$ *1,234.56< >$ 1,234.56< +> $456,789.00 < +> -100< +> -1,000< +>-**123< +>$ *1,234.56< +>$ 1,234.56< +> $456,789.00 < +> -100< +> -1,000< ]) AT_CLEANUP @@ -7133,7 +8856,7 @@ AT_DATA([prog.cob], [ *> MOVE -12345 TO SRC-FIELD-100 . MOVE SRC-FIELD-100 TO DST-FIELD-2 . - IF DST-FIELD-2 NOT = 1234005 + IF DST-FIELD-2 NOT = -1234005 DISPLAY '5: DST-FIELD-2 <' DST-FIELD-2 '> != 1234005' . *> MOVE -23456 TO SRC-FIELD-101 . @@ -7175,7 +8898,7 @@ AT_DATA([prog.cob], [ *> MOVE -12345 TO SRC-FIELD-400 . MOVE SRC-FIELD-400 TO DST-FIELD-2 . - IF DST-FIELD-2 NOT = 1234005 + IF DST-FIELD-2 NOT = -1234005 DISPLAY '13: DST-FIELD-2 <' DST-FIELD-2 '> != 1234005' . *> MOVE -23456 TO SRC-FIELD-401 . @@ -7280,7 +9003,7 @@ AT_SETUP([MOVE between USAGEs]) AT_KEYWORDS([fundamental COMP-1 COMP-2 COMP-3 COMP-4 COMP-5 COMP-6 DISPLAY BINARY PACKED-DECIMAL BINARY-C-LONG BINARY-CHAR BINARY-DOUBLE BINARY-INT -BINARY-LONG SIGNED UNSIGNED BINARY-LONG-LONG +BINARY-LONG SIGNED UNSIGNED BINARY-LONG-LONG BINARY-SHORT FLOAT-DECIMAL-16 FLOAT-DECIMAL-34 FLOAT-SHORT SIGNED-INT SIGNED-LONG SIGNED-SHORT UNSIGNED-INT UNSIGNED-LONG UNSIGNED-SHORT]) diff --git a/tests/testsuite.src/run_reportwriter.at b/tests/testsuite.src/run_reportwriter.at index 2ff781a44..78d781e23 100644 --- a/tests/testsuite.src/run_reportwriter.at +++ b/tests/testsuite.src/run_reportwriter.at @@ -1,4 +1,4 @@ -## Copyright (C) 2014-2021 Free Software Foundation, Inc. +## Copyright (C) 2014-2021, 2024 Free Software Foundation, Inc. ## Written by Ron Norman, Simon Sobisch ## ## This file is part of GnuCOBOL. @@ -3792,10 +3792,11 @@ AT_CLEANUP AT_SETUP([Sample Inventory Report]) AT_KEYWORDS([report runfile]) -AT_DATA([inp_data],[01Data Processing 02000500012388 -02Cow Milking 02000600054398 -03Grass Cutting 03000600054397 -03Lawn mowing 03000600054397 +AT_DATA([inp_data], +[01Data Processing 020005000123880 +02Cow Milking 020006000543980 +03Grass Cutting 030006000543970 +03Lawn mowing 030006000543970 ]) AT_DATA([prog.cob], [