--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/37-digit_Initialization_of_fundamental_types.out" }
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 01 foo1 pic 9(30)v9(7) value 123456789012345678901234567890.1234567.
+ 01 foo2 pic 9(30)v9(7) comp-3 value 123456789012345678901234567890.1234567.
+ 01 foo3 pic 9(30).9(7) value 123456789012345678901234567890.1234567.
+ 01 foo4 pic 9(30)v9(7) binary value 123456789012345678901234567890.1234567.
+ 01 foo5 pic 9(30)v9(7) comp-5 value 123456789012345678901234567890.1234567.
+ 01 foo6 pic 9(30)v9(7) binary-double
+ value 123456789012345678901234567890.1234567.
+ procedure division.
+ display foo1
+ display foo2
+ display foo3
+ display foo4
+ display foo5
+ display foo6
+ move 111111111122222222223333333333.7654321 to foo1 foo2 foo3 foo4 foo5 foo6
+ display foo1
+ display foo2
+ display foo3
+ display foo4
+ display foo5
+ display foo6
+ goback.
+ end program prog.
+
--- /dev/null
+123456789012345678901234567890.1234567
+123456789012345678901234567890.1234567
+123456789012345678901234567890.1234567
+123456789012345678901234567890.1234567
+123456789012345678901234567890.1234567
+123456789012345678901234567890.1234567
+111111111122222222223333333333.7654321
+111111111122222222223333333333.7654321
+111111111122222222223333333333.7654321
+111111111122222222223333333333.7654321
+111111111122222222223333333333.7654321
+111111111122222222223333333333.7654321
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/ACCEPT_FROM_ENVIRONMENT-NAME.out" }
+ identification division.
+ program-id. wrapper.
+ data division.
+ working-storage section.
+ 01 ename pic x(32).
+ 01 evalue pic x(32).
+ procedure division.
+ move "BAGPIPES" to ename
+ display ename upon environment-name.
+ accept evalue from environment-value
+ on exception display "No " function trim (ename) end-display
+ not on exception display "Got " function trim (ename) end-display
+ end-accept
+
+ display ename upon environment-name.
+ display "loud" upon environment-value.
+
+ display ename upon environment-name.
+ accept evalue from environment-value
+ on exception display "No " function trim (ename) end-display
+ not on exception display "Got " function trim (ename) end-display
+ end-accept
+ display """" function trim(evalue) """"
+
+ goback.
+ end program wrapper.
+
--- /dev/null
+No BAGPIPES
+Got BAGPIPES
+"loud"
+
--- /dev/null
+ *> { dg-do run }
+
+ ID DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 var1 PIC X100.
+ PROCEDURE DIVISION.
+ ACCEPT var1 FROM COMMAND-LINE(1).
+ DISPLAY var1.
+ GOBACK.
+
--- /dev/null
+ *> { dg-do run }
+
+ ID DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 var1 PIC 99.
+ PROCEDURE DIVISION.
+ ADD 1 2 TO 4 GIVING var1.
+ IF var1 NOT EQUAL 7
+ THEN
+ DISPLAY "Wrong answer, expected 7, got " var1 "."
+ END-IF.
+ GOBACK.
+
*> { dg-do run }
*> { dg-output-file "group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.out" }
-
identification division.
program-id. prog.
procedure division.
identification division.
program-id. reporter.
data division.
+ working-storage section.
+ 01.
+ 02 asciiv pic x(8) value X"2020202020202020".
+ 02 asciip redefines asciiv pointer.
+ 02 ebcdicv pic x(8) value X"4040404040404040".
+ 02 ebcdicp redefines ebcdicv pointer.
linkage section.
01 based-var based.
02 based-x pic x(24).
reportt2.
display " " """" based-x """" with no advancing
display space """" based-9 """" with no advancing
- display space based-p.
+ if based-p = asciip or ebcdicp
+ display " Pointer is Okay"
+ else
+ display space based-p
+ end-if
continue.
end program reporter.
initialize spaces
allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero)
(1) as allocated
- " " "000" 0x2020202020202020
+ " " "000" Pointer is Okay
initialize high-value
allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero)
0xffffffffffffffff
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/ALLOCATE_Rules_6_-_9._Without_OPTION_INITIALIZE_Without_-fdefaultbyte___ASCII_.out" }
+
+ identification division.
+ program-id. prog.
+ *> options. initialize working-storage X"35".
+ data division.
+ working-storage section.
+ 01 based-var based.
+ 02 based-x pic x(24) value "I am I, Don Quixote".
+ 02 based-9 pic 999 value 123.
+ 02 based-p pointer value NULL.
+ 01 allocated-pointer pointer.
+
+ procedure division.
+ *> Do a sanity check of the FREE operation:
+ allocate based-var
+ free based-var
+ if address of based-var not equal NULL
+ display "based-var should be NULL"
+ end-if
+ if address of based-x not equal NULL
+ display "based-x should be NULL"
+ end-if
+ if address of based-9 not equal NULL
+ display "based-9 should be NULL"
+ end-if
+ if address of based-p not equal NULL
+ display "based-p should be NULL"
+ end-if
+
+ display "allocate characters INITIALIZED (ISO 2023 Rule 6: defaultbyte if specified, else zero)"
+ allocate 35 characters initialized returning allocated-pointer
+ set address of based-var to allocated-pointer
+ perform reportt
+
+ display "allocate based-var initialized (ISO 2023 Rule 7: ALL TO VALUE)"
+ allocate based-var initialized
+ perform reportt
+ free based-var
+
+ display "allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero)"
+ allocate 35 characters returning allocated-pointer
+ set address of based-var to allocated-pointer
+ perform reportt
+ free allocated-pointer
+
+ display "allocate based-var (ISO 2023 Rule 9: pointers NULL, otherwise OPT_INIT)"
+ allocate based-var
+ perform reportt
+ free based-var
+
+ goback.
+
+ reportt.
+ display " (1) as allocated"
+ perform reportt2
+ display " (2) after ""initialize based-var"""
+ initialize based-var
+ perform reportt2
+ display " (3) after ""initialize based-var all to value"""
+ initialize based-var all to value
+ perform reportt2
+ continue.
+ reportt2.
+ display " " """" based-x """" with no advancing
+ display space """" based-9 """" with no advancing
+ display space based-p.
+ continue.
+ end program prog.
+
--- /dev/null
+allocate characters INITIALIZED (ISO 2023 Rule 6: defaultbyte if specified, else zero)
+ (1) as allocated
+ "" "000" 0x0000000000000000
+ (2) after "initialize based-var"
+ " " "000" 0x0000000000000000
+ (3) after "initialize based-var all to value"
+ "I am I, Don Quixote " "123" 0x0000000000000000
+allocate based-var initialized (ISO 2023 Rule 7: ALL TO VALUE)
+ (1) as allocated
+ "I am I, Don Quixote " "123" 0x0000000000000000
+ (2) after "initialize based-var"
+ " " "000" 0x0000000000000000
+ (3) after "initialize based-var all to value"
+ "I am I, Don Quixote " "123" 0x0000000000000000
+allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero)
+ (1) as allocated
+ "" "000" 0x0000000000000000
+ (2) after "initialize based-var"
+ " " "000" 0x0000000000000000
+ (3) after "initialize based-var all to value"
+ "I am I, Don Quixote " "123" 0x0000000000000000
+allocate based-var (ISO 2023 Rule 9: pointers NULL, otherwise OPT_INIT)
+ (1) as allocated
+ "" "000" 0x0000000000000000
+ (2) after "initialize based-var"
+ " " "000" 0x0000000000000000
+ (3) after "initialize based-var all to value"
+ "I am I, Don Quixote " "123" 0x0000000000000000
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/ALLOCATE_Rules_6_-_9._Without_OPTION_INITIALIZE_Without_-fdefaultbyte___EBCDIC_.out" }
+
+ identification division.
+ program-id. prog.
+ *> options. initialize working-storage X"F5".
+ data division.
+ working-storage section.
+ 01 based-var based.
+ 02 based-x pic x(24) value "I am I, Don Quixote".
+ 02 based-9 pic 999 value 123.
+ 02 based-p pointer value NULL.
+ 01 allocated-pointer pointer.
+
+ procedure division.
+ *> Do a sanity check of the FREE operation:
+ allocate based-var
+ free based-var
+ if address of based-var not equal NULL
+ display "based-var should be NULL"
+ end-if
+ if address of based-x not equal NULL
+ display "based-x should be NULL"
+ end-if
+ if address of based-9 not equal NULL
+ display "based-9 should be NULL"
+ end-if
+ if address of based-p not equal NULL
+ display "based-p should be NULL"
+ end-if
+
+ display "allocate characters INITIALIZED (ISO 2023 Rule 6: defaultbyte if specified, else zero)"
+ allocate 35 characters initialized returning allocated-pointer
+ set address of based-var to allocated-pointer
+ perform reportt
+
+ display "allocate based-var initialized (ISO 2023 Rule 7: ALL TO VALUE)"
+ allocate based-var initialized
+ perform reportt
+ free based-var
+
+ display "allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero)"
+ allocate 35 characters returning allocated-pointer
+ set address of based-var to allocated-pointer
+ perform reportt
+ free allocated-pointer
+
+ display "allocate based-var (ISO 2023 Rule 9: pointers NULL, otherwise OPT_INIT)"
+ allocate based-var
+ perform reportt
+ free based-var
+
+ goback.
+
+ reportt.
+ display " (1) as allocated"
+ perform reportt2
+ display " (2) after ""initialize based-var"""
+ initialize based-var
+ perform reportt2
+ display " (3) after ""initialize based-var all to value"""
+ initialize based-var all to value
+ perform reportt2
+ continue.
+ reportt2.
+ display " " """" based-x """" with no advancing
+ display space """" based-9 """" with no advancing
+ display space based-p.
+ continue.
+ end program prog.
+
--- /dev/null
+allocate characters INITIALIZED (ISO 2023 Rule 6: defaultbyte if specified, else zero)
+ (1) as allocated
+ "" "000" 0x0000000000000000
+ (2) after "initialize based-var"
+ " " "000" 0x0000000000000000
+ (3) after "initialize based-var all to value"
+ "I am I, Don Quixote " "123" 0x0000000000000000
+allocate based-var initialized (ISO 2023 Rule 7: ALL TO VALUE)
+ (1) as allocated
+ "I am I, Don Quixote " "123" 0x0000000000000000
+ (2) after "initialize based-var"
+ " " "000" 0x0000000000000000
+ (3) after "initialize based-var all to value"
+ "I am I, Don Quixote " "123" 0x0000000000000000
+allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero)
+ (1) as allocated
+ "" "000" 0x0000000000000000
+ (2) after "initialize based-var"
+ " " "000" 0x0000000000000000
+ (3) after "initialize based-var all to value"
+ "I am I, Don Quixote " "123" 0x0000000000000000
+allocate based-var (ISO 2023 Rule 9: pointers NULL, otherwise OPT_INIT)
+ (1) as allocated
+ "" "000" 0x0000000000000000
+ (2) after "initialize based-var"
+ " " "000" 0x0000000000000000
+ (3) after "initialize based-var all to value"
+ "I am I, Don Quixote " "123" 0x0000000000000000
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-options "-fdefaultbyte 51" }
+ *> { dg-output-file "group2/ALLOCATE_Rules_6_-_9_Without_OPTION_INITIALIZE_With_-fdefaultbyte___UTF16_.out" }
+
+ identification division.
+ program-id. prog.
+ *> options. initialize working-storage X"35".
+ data division.
+ working-storage section.
+ 01 based-var based.
+ 02 based-x pic x(24) value "I am I, Don Quixote".
+ 02 based-9 pic 999 value 123.
+ 02 based-p pointer value NULL.
+ 01 allocated-pointer pointer.
+
+ procedure division.
+ *> Do a sanity check of the FREE operation:
+ allocate based-var
+ free based-var
+ if address of based-var not equal NULL
+ display "based-var should be NULL"
+ end-if
+ if address of based-x not equal NULL
+ display "based-x should be NULL"
+ end-if
+ if address of based-9 not equal NULL
+ display "based-9 should be NULL"
+ end-if
+ if address of based-p not equal NULL
+ display "based-p should be NULL"
+ end-if
+
+ display "allocate characters INITIALIZED (ISO 2023 Rule 6: defaultbyte if specified, else zero)"
+ allocate 70 characters initialized returning allocated-pointer
+ set address of based-var to allocated-pointer
+ perform reportt
+
+ display "allocate based-var initialized (ISO 2023 Rule 7: ALL TO VALUE)"
+ allocate based-var initialized
+ perform reportt
+ free based-var
+
+ display "allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero)"
+ allocate 70 characters returning allocated-pointer
+ set address of based-var to allocated-pointer
+ perform reportt
+ free allocated-pointer
+
+ display "allocate based-var (ISO 2023 Rule 9: pointers NULL, otherwise OPT_INIT)"
+ allocate based-var
+ perform reportt
+ free based-var
+
+ goback.
+
+ reportt.
+ display " (1) as allocated"
+ perform reportt2
+ display " (2) after ""initialize based-var"""
+ initialize based-var
+ perform reportt2
+ display " (3) after ""initialize based-var all to value"""
+ initialize based-var all to value
+ perform reportt2
+ continue.
+ reportt2.
+ display " " """" function hex-of(based-x) """" with no advancing
+ display space """" function hex-of(based-9) """" with no advancing
+ display space based-p.
+ continue.
+ end program prog.
+
--- /dev/null
+allocate characters INITIALIZED (ISO 2023 Rule 6: defaultbyte if specified, else zero)
+ (1) as allocated
+ "333333333333333333333333333333333333333333333333" "333333" 0x3333333333333333
+ (2) after "initialize based-var"
+ "202020202020202020202020202020202020202020202020" "303030" 0x3333333333333333
+ (3) after "initialize based-var all to value"
+ "4920616D20492C20446F6E20517569786F74652020202020" "313233" 0x0000000000000000
+allocate based-var initialized (ISO 2023 Rule 7: ALL TO VALUE)
+ (1) as allocated
+ "4920616D20492C20446F6E20517569786F74652020202020" "313233" 0x0000000000000000
+ (2) after "initialize based-var"
+ "202020202020202020202020202020202020202020202020" "303030" 0x3333333333333333
+ (3) after "initialize based-var all to value"
+ "4920616D20492C20446F6E20517569786F74652020202020" "313233" 0x0000000000000000
+allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero)
+ (1) as allocated
+ "333333333333333333333333333333333333333333333333" "333333" 0x3333333333333333
+ (2) after "initialize based-var"
+ "202020202020202020202020202020202020202020202020" "303030" 0x3333333333333333
+ (3) after "initialize based-var all to value"
+ "4920616D20492C20446F6E20517569786F74652020202020" "313233" 0x0000000000000000
+allocate based-var (ISO 2023 Rule 9: pointers NULL, otherwise OPT_INIT)
+ (1) as allocated
+ "333333333333333333333333333333333333333333333333" "333333" 0x0000000000000000
+ (2) after "initialize based-var"
+ "202020202020202020202020202020202020202020202020" "303030" 0x3333333333333333
+ (3) after "initialize based-var all to value"
+ "4920616D20492C20446F6E20517569786F74652020202020" "313233" 0x0000000000000000
+
03 XBYTE PIC X.
03 FILLER PIC XXX.
PROCEDURE DIVISION.
- MOVE X"0D" TO XBYTE.
+ MOVE "A" TO XBYTE.
IF X ALPHABETIC-LOWER
DISPLAY "Fail - Not alphabetic lower"
END-DISPLAY
03 XBYTE PIC X.
03 FILLER PIC XXX.
PROCEDURE DIVISION.
- MOVE X"0D" TO XBYTE.
+ MOVE "a" TO XBYTE.
IF X ALPHABETIC-UPPER
DISPLAY "Fail - Not alphabetic upper"
END-DISPLAY
03 XBYTE PIC X.
03 FILLER PIC XXX.
PROCEDURE DIVISION.
- MOVE X"0D" TO XBYTE.
+ MOVE "1" TO XBYTE.
IF X ALPHABETIC
DISPLAY "Fail - Alphabetic"
END-DISPLAY
--- /dev/null
+ *> { dg-do run }
+ *> { dg-options "-Wno-any-length" }
+ *> { dg-output-file "group2/ANY_LENGTH__7_.out" }
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. callee.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 P2 PIC 99.
+ LINKAGE SECTION.
+ 01 P1 PIC X ANY LENGTH.
+ PROCEDURE DIVISION USING P1.
+ MOVE FUNCTION LENGTH (P1) TO P2.
+ DISPLAY "The incoming ANY LENGTH is " P2
+ DISPLAY "The incoming ANY LENGTH variable is " """" P1 """"
+ EXIT PROGRAM.
+ END PROGRAM callee.
+
--- /dev/null
+The incoming ANY LENGTH is 00
+The incoming ANY LENGTH variable is ""
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/Assorted_SPECIAL-NAMES_CLASS.out" }
+ identification division.
+ program-id. nat.
+ environment division.
+ configuration section.
+ special-names.
+ *> Note that working with numeric collation positions rather than
+ *> text characters gets extremely confusing and tricky in our
+ *> current paradigm, which is to convert everything to UTF32 in
+ *> order to make comparisons when things like multi-byte UTF-8
+ *> encoding is involved. Likewise the possibility of working in
+ *> UTF-16 and encountering double-word encodings. It's not easy
+ *> to declare what is "right". This code works with ASCII, EBCDIC,
+ *> and UTF-8 as the ALPHANUMERIC/DISPLAY encoding.
+
+ locale unicode is "utf16le"
+ CLASS HexNumber IS "0" THRU "9", "A" THRU "F",
+ "a" THRU "f"
+ CLASS RealName IS "A" THRU "Z",
+ "a" THRU "z"
+ CLASS JustJ IS "J"
+ CLASS AsciiZero IS 49
+ CLASS EbcdicZero IS 49
+ CLASS LooseDigit IS 49 THROUGH 58 241 THROUGH 250
+ CLASS IntChars IS "INJMLK"
+ .
+ object-computer.
+ gnu-linux
+ classification for national is unicode
+ .
+ data division.
+ working-storage section.
+ 01 J pic X value "J".
+ 01 K pic X value "K".
+ 01 S pic X value "S".
+ 01 hex-value pic X(4) value "FF00".
+ 01 name pic X(9) value "AOMalleyz".
+ 01 zed pic X value "0".
+ 01 four pic X value "4".
+ procedure division.
+ if J is JustJ
+ display "properly J IS J"
+ else
+ display "IMPROPERLY NOT J IS J"
+ end-if
+
+ if K is JustJ
+ display "IMPROPERLY K IS J"
+ else
+ display "properly not K IS J"
+ end-if
+
+ if hex-value is HexNumber
+ display "properly hex-value IS HexNumber"
+ else
+ display "IMPROPERLY not hex-value IS HexNumber"
+ end-if
+
+ if name is HexNumber
+ display "IMPROPERLY name IS HexNumber"
+ else
+ display "properly not name IS HexNumber"
+ end-if
+
+ if name is RealName
+ display "properly name IS RealName"
+ else
+ display "IMPROPERLY not name IS RealName"
+ end-if
+
+ if zed is EbcdicZero
+ display "properly zed IS EbcdicZero"
+ else
+ display "IMPROPERLY not zed IS EbcdicZero"
+ end-if
+ if zed is AsciiZero
+ display "properly zed IS AsciiZero"
+ else
+ display "IMPROPERLY not zed IS AsciiZero"
+ end-if
+
+ if four is LooseDigit
+ display "properly four IS LooseDigit"
+ else
+ display "IMPROPERLY not four IS LooseDigit"
+ end-if
+
+ if J is LooseDigit
+ display "IMPROPERLY J IS LooseDigit"
+ else
+ display "properly not J IS LooseDigit"
+ end-if
+
+ if J is IntChars
+ display "properly J IS IntChars"
+ else
+ display "IMPROPERLY not J IS IntChars"
+ end-if
+
+ if S is IntChars
+ display "IMPROPERLY S IS IntChars"
+ else
+ display "properly not S IS IntChars"
+ end-if
+
+ goback.
+ end program nat.
+
--- /dev/null
+properly J IS J
+properly not K IS J
+properly hex-value IS HexNumber
+properly not name IS HexNumber
+properly name IS RealName
+properly zed IS EbcdicZero
+properly zed IS AsciiZero
+properly four IS LooseDigit
+properly not J IS LooseDigit
+properly J IS IntChars
+properly not S IS IntChars
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/BINARY_and_COMP-5.out" }
+ identification division.
+ program-id. prog.
+ procedure division.
+ call "prog1"
+ call "prog2"
+ goback.
+ end program prog.
+
+ identification division.
+ program-id. prog1.
+ data division.
+ working-storage section.
+ 01.
+ 02 var-binary binary pic 9v9(10) .
+ 02 var-binaryp redefines var-binary pointer.
+ 02 var-comp comp pic 9v9(10) .
+ 02 var-compp redefines var-comp pointer.
+ 02 var-compu computational pic 9v9(10) .
+ 02 var-compup redefines var-compu pointer.
+ 02 var-comp4 comp-4 pic 9v9(10) .
+ 02 var-comp4p redefines var-comp4 pointer.
+ 02 var-compu4 computational-4 pic 9v9(10) .
+ 02 var-compu4p redefines var-compu4 pointer.
+
+ 02 var-comp5 comp-5 pic 9v9(10) .
+ 02 var-comp5p redefines var-comp5 pointer.
+ 02 var-compu5 computational-5 pic 9v9(10) .
+ 02 var-compu5p redefines var-compu5 pointer.
+
+ 02 var-sbinary binary pic s9v9(10) .
+ 02 var-sbinaryp redefines var-sbinary pointer.
+ 02 var-scomp comp pic s9v9(10) .
+ 02 var-scompp redefines var-scomp pointer.
+ 02 var-scompu computational pic s9v9(10) .
+ 02 var-scompup redefines var-scompu pointer.
+ 02 var-scomp4 comp-4 pic s9v9(10) .
+ 02 var-scomp4p redefines var-scomp4 pointer.
+ 02 var-scompu4 computational-4 pic s9v9(10) .
+ 02 var-scompu4p redefines var-scompu4 pointer.
+
+ 02 var-scomp5 comp-5 pic s9v9(10) .
+ 02 var-scomp5p redefines var-scomp5 pointer.
+ 02 var-scompu5 computational-5 pic s9v9(10) .
+ 02 var-scompu5p redefines var-scompu5 pointer.
+ procedure division.
+ move 0.0001193046 to var-binary var-comp var-compu
+ var-comp4 var-compu4 var-comp5
+ var-compu5
+ display " " var-binary " " var-comp " " var-compu " "
+ var-comp4 " " var-compu4 " "
+ var-comp5 " " var-compu5
+ move 0.0001193046 to var-sbinary var-scomp var-scompu
+ var-scomp4 var-scompu4 var-scomp5
+ var-scompu5
+ display var-sbinary " " var-scomp " " var-scompu " "
+ var-scomp4 " " var-scompu4 " "
+ var-scomp5 " " var-scompu5
+ move -0.0001193046 to var-sbinary var-scomp var-scompu
+ var-scomp4 var-scompu4 var-scomp5
+ var-scompu5
+ display var-sbinary " " var-scomp " " var-scompu " "
+ var-scomp4 " " var-scompu4 " "
+ var-scomp5 " " var-scompu5
+ display var-binaryp
+ display var-compp
+ display var-compup
+ display var-comp4p
+ display var-compu4p
+ display var-comp5p
+ display var-compu5p
+
+ display var-sbinaryp
+ display var-scompp
+ display var-scompup
+ display var-scomp4p
+ display var-scompu4p
+ display var-scomp5p
+ display var-scompu5p
+
+ goback.
+ end program prog1.
+
+ identification division.
+ program-id. prog2.
+ data division.
+ working-storage section.
+ 01.
+ 02 var-binary pic 9v9(10) binary .
+ 02 var-binaryp redefines var-binary pointer.
+ 02 var-comp pic 9v9(10) comp .
+ 02 var-compp redefines var-comp pointer.
+ 02 var-compu pic 9v9(10) computational .
+ 02 var-compup redefines var-compu pointer.
+ 02 var-comp4 pic 9v9(10) comp-4 .
+ 02 var-comp4p redefines var-comp4 pointer.
+ 02 var-compu4 pic 9v9(10) computational-4 .
+ 02 var-compu4p redefines var-compu4 pointer.
+
+ 02 var-comp5 pic 9v9(10) comp-5 .
+ 02 var-comp5p redefines var-comp5 pointer.
+ 02 var-compu5 pic 9v9(10) computational-5 .
+ 02 var-compu5p redefines var-compu5 pointer.
+
+ 02 var-sbinary pic s9v9(10) binary .
+ 02 var-sbinaryp redefines var-sbinary pointer.
+ 02 var-scomp pic s9v9(10) comp .
+ 02 var-scompp redefines var-scomp pointer.
+ 02 var-scompu pic s9v9(10) computational .
+ 02 var-scompup redefines var-scompu pointer.
+ 02 var-scomp4 pic s9v9(10) comp-4 .
+ 02 var-scomp4p redefines var-scomp4 pointer.
+ 02 var-scompu4 pic s9v9(10) computational-4 .
+ 02 var-scompu4p redefines var-scompu4 pointer.
+
+ 02 var-scomp5 pic s9v9(10) comp-5 .
+ 02 var-scomp5p redefines var-scomp5 pointer.
+ 02 var-scompu5 pic s9v9(10) computational-5 .
+ 02 var-scompu5p redefines var-scompu5 pointer.
+ procedure division.
+ move 0.0001193046 to var-binary var-comp var-compu
+ var-comp4 var-compu4 var-comp5
+ var-compu5
+ display " " var-binary " " var-comp " " var-compu " "
+ var-comp4 " " var-compu4 " "
+ var-comp5 " " var-compu5
+ move 0.0001193046 to var-sbinary var-scomp var-scompu
+ var-scomp4 var-scompu4 var-scomp5
+ var-scompu5
+ display var-sbinary " " var-scomp " " var-scompu " "
+ var-scomp4 " " var-scompu4 " "
+ var-scomp5 " " var-scompu5
+ move -0.0001193046 to var-sbinary var-scomp var-scompu
+ var-scomp4 var-scompu4 var-scomp5
+ var-scompu5
+ display var-sbinary " " var-scomp " " var-scompu " "
+ var-scomp4 " " var-scompu4 " "
+ var-scomp5 " " var-scompu5
+ display var-binaryp
+ display var-compp
+ display var-compup
+ display var-comp4p
+ display var-compu4p
+ display var-comp5p
+ display var-compu5p
+
+ display var-sbinaryp
+ display var-scompp
+ display var-scompup
+ display var-scomp4p
+ display var-scompu4p
+ display var-scomp5p
+ display var-scompu5p
+
+ goback.
+ end program prog2.
+
--- /dev/null
+ 0.0001193046 0.0001193046 0.0001193046 0.0001193046 0.0001193046 0.0001193046 0.0001193046
++0.0001193046 +0.0001193046 +0.0001193046 +0.0001193046 +0.0001193046 +0.0001193046 +0.0001193046
+-0.0001193046 -0.0001193046 -0.0001193046 -0.0001193046 -0.0001193046 -0.0001193046 -0.0001193046
+0x5634120000000000
+0x5634120000000000
+0x5634120000000000
+0x5634120000000000
+0x5634120000000000
+0x0000000000123456
+0x0000000000123456
+0xaacbedffffffffff
+0xaacbedffffffffff
+0xaacbedffffffffff
+0xaacbedffffffffff
+0xaacbedffffffffff
+0xffffffffffedcbaa
+0xffffffffffedcbaa
+ 0.0001193046 0.0001193046 0.0001193046 0.0001193046 0.0001193046 0.0001193046 0.0001193046
++0.0001193046 +0.0001193046 +0.0001193046 +0.0001193046 +0.0001193046 +0.0001193046 +0.0001193046
+-0.0001193046 -0.0001193046 -0.0001193046 -0.0001193046 -0.0001193046 -0.0001193046 -0.0001193046
+0x5634120000000000
+0x5634120000000000
+0x5634120000000000
+0x5634120000000000
+0x5634120000000000
+0x0000000000123456
+0x0000000000123456
+0xaacbedffffffffff
+0xaacbedffffffffff
+0xaacbedffffffffff
+0xaacbedffffffffff
+0xaacbedffffffffff
+0xffffffffffedcbaa
+0xffffffffffedcbaa
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/CDF2_-_DEFINE_FOO_AS_literal-1.out" }
+ >>DEFINE FOO AS "on"
+ id division.
+ program-id. prog.
+ procedure division.
+ >>IF FOO = "on"
+ DISPLAY "FOO is on.".
+ >>END-IF
+ DISPLAY "gratuitous display.".
+ goback.
+
--- /dev/null
+FOO is on.
+gratuitous display.
+
--- /dev/null
+ *> { dg-do run }
+
+ *> This compiles correctly; there should be no period after "prog"
+ *> and there should be a period after INITIAL. But, IS INITIAL is
+ *> excluded because skip-init is not defined.
+ identification division.
+ program-id. prog.
+ >>IF skip-init IS DEFINED
+ IS INITIAL
+ >>END-IF
+ data division.
+ working-storage section.
+ 77 VAR INDEX.
+ procedure division.
+ set VAR TO +1
+ display var
+ set VAR TO -1000
+ display var
+ .
+ end program prog.
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/CDF2_Trouble_with___IF__2_.out" }
+
+ *> This should compile, and doesn't
+ identification division.
+ program-id. prog2
+ >>IF skip-init IS DEFINED
+ IS INITIAL .
+ >>END-IF
+ data division.
+ working-storage section.
+ 77 VAR INDEX.
+ procedure division.
+ set VAR TO +1
+ display var
+ set VAR TO -1000
+ display var
+ .
+ end program prog2.
+
--- /dev/null
+1
+18446744073709550616
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/CDF4_.out" }
+
+ >>DEFINE FOO AS 1
+ *> Only the gratuitous display message shows. The message
+ *> enclosed in the IF does not.
+ id division.
+ program-id. prog.
+ procedure division.
+ >>IF FOO = 1
+ DISPLAY "FOO is one.".
+ >>END-IF
+ DISPLAY "gratuitous display.".
+ goback.
+
--- /dev/null
+FOO is one.
+gratuitous display.
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-options "-fexec-charset=cp1140 -dialect ibm" }
+ *> { dg-output-file "group2/CDF_Feature_.out" }
+
+ id division.
+ program-id. prog.
+ Data Division.
+ Working-Storage Section.
+ 77 X PIC 9 value 1.
+ procedure division.
+ >>IF %64-BIT-POINTER DEFINED
+ DISPLAY '64-bit-pointer mode ON'
+ >>END-IF
+ >>IF %EBCDIC-MODE DEFINED
+ DISPLAY 'EBCDIC-MODE ON'
+ >>END-IF
+ >>DEFINE %64-BIT-POINTER OFF
+ >>IF %64-BIT-POINTER DEFINED
+ DISPLAY '64-bit-pointer mode still ON'
+ >>END-IF
+ >>IF not-ok IS DEFINED
+ >>DEFINE %EBCDIC-MODE OFF
+ >>IF %EBCDIC-MODE DEFINED
+ DISPLAY 'EBCDIC-MODE mode still ON'
+ >>END-IF
+ >>END-IF
+
--- /dev/null
+64-bit-pointer mode ON
+EBCDIC-MODE ON
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/CDF_IS_NOT_DEFINED.out" }
+ identification division.
+ program-id. fbug.
+ procedure division.
+
+ >>IF CVAR IS NOT DEFINED
+ display "case 1: correct: >>IF cvar not defined"
+ >>ELSE
+ display "case 1: INCORRECT: >>ELSE cvar not defined"
+ >>END-IF
+
+ >>IF CVAR IS DEFINED
+ display "case 2: INCORRECT: >>IF cvar defined"
+ >>ELSE
+ display "case 2: correct: >>ELSE cvar defined"
+ >>END-IF
+
+ >>DEFINE CVAR AS 1
+
+ >>IF CVAR IS NOT DEFINED
+ display "case 3: INCORRECT: >>IF cvar not defined"
+ >>ELSE
+ display "case 3: correct: >>ELSE cvar not defined"
+ >>END-IF
+
+ >>IF CVAR IS DEFINED
+ display "case 4: correct: >>IF cvar defined"
+ >>ELSE
+ display "case 4: INCORRECT: >>ELSE cvar defined"
+ >>END-IF
+
+ goback.
+
--- /dev/null
+case 1: correct: >>IF cvar not defined
+case 2: correct: >>ELSE cvar defined
+case 3: correct: >>ELSE cvar not defined
+case 4: correct: >>IF cvar defined
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-options "-dialect ibm" }
+ *> { dg-output-file "group2/CDF__1__IF____text_.out" }
+
+ >>DEFINE FOO AS "on"
+ id division.
+ program-id. prog.
+ Data Division.
+ Working-Storage Section.
+ 77 X PIC 9 value 1.
+ procedure division.
+ >>IF FOO = "on"
+ DISPLAY " FOO is on.".
+ >>END-IF
+ DISPLAY "Should have seen FOO is on.".
+ >>IF FOO = "off"
+ DISPLAY " FOO is off.".
+ >>END-IF
+ DISPLAY "Shouldn't see FOO is off.".
+ a-paragraph.
+ EJECT
+ a-paragraph.
+ add 1 to X.
+ EJECT
+ a-paragraph.
+ EJECT
+ b-paragraph.
+ goback.
+
--- /dev/null
+ FOO is on.
+Should have seen FOO is on.
+Shouldn't see FOO is off.
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/CDF__2__IF____number_.out" }
+
+ >>DEFINE FOO AS 1
+ id division.
+ program-id. prog.
+ procedure division.
+ >>IF FOO = 1
+ DISPLAY " FOO is 1.".
+ >>END-IF
+ DISPLAY "Should have seen FOO is 1.".
+ >>IF FOO = 2
+ DISPLAY " FOO is 2.".
+ >>END-IF
+ DISPLAY "Shouldn't see FOO is 2.".
+ goback.
+
--- /dev/null
+ FOO is 1.
+Should have seen FOO is 1.
+Shouldn't see FOO is 2.
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/CDF__3__ALL_NUMERIC_COMPARISONS.out" }
+
+ >>DEFINE ONE AS 1
+ >>DEFINE TWO AS 2
+ >>DEFINE WUN AS 1
+ id division.
+ program-id. prog.
+ procedure division.
+ >>IF ONE = TWO
+ DISPLAY "??? ONE = TWO ???"
+ >>END-IF
+ >>IF ONE <> TWO
+ DISPLAY "ONE <> TWO"
+ >>END-IF
+ >>IF ONE < TWO
+ DISPLAY "ONE < TWO"
+ >>END-IF
+ >>IF ONE <= TWO
+ DISPLAY "ONE <= TWO"
+ >>END-IF
+ >>IF ONE >= TWO
+ DISPLAY "??? ONE >= TWO ???"
+ >>END-IF
+ >>IF ONE > TWO
+ DISPLAY "??? ONE > TWO ???"
+ >>END-IF
+ >>IF ONE = WUN
+ DISPLAY "ONE = ONE"
+ >>END-IF
+ >>IF ONE <> WUN
+ DISPLAY "??? ONE <> ONE ???"
+ >>END-IF
+ >>IF ONE < WUN
+ DISPLAY "??? ONE < ONE ???"
+ >>END-IF
+ >>IF ONE <= WUN
+ DISPLAY "ONE <= ONE"
+ >>END-IF
+ >>IF ONE >= WUN
+ DISPLAY "ONE >= ONE"
+ >>END-IF
+ >>IF ONE > WUN
+ DISPLAY "??? ONE > ONE ???"
+ >>END-IF
+ goback.
+
--- /dev/null
+ONE <> TWO
+ONE < TWO
+ONE <= TWO
+ONE = ONE
+ONE <= ONE
+ONE >= ONE
+
--- /dev/null
+ *> { dg-do run }
+
+ *> This program should produce no output. It is a sanity check of
+ *> COMP-5 moves and addition.
+ program-id. comp5.
+ data division.
+ working-storage section.
+ 77 var PIC 999V999 COMP-5 .
+ 77 var1 PIC 999V9(1) COMP-5 .
+ 77 var2 PIC 999V9(2) COMP-5 .
+ 77 var3 PIC 999V9(3) COMP-5 .
+ 77 var4 PIC 999V9(4) COMP-5 .
+ 77 var5 PIC 999V9(5) COMP-5 .
+ 77 var6 PIC 999V9(6) COMP-5 .
+ 77 var7 PIC 999V9(7) COMP-5 .
+ 77 var8 PIC 999V9(8) COMP-5 .
+ 77 var555 PIC 999V99999999 COMP-5 VALUE 555.55555555.
+ procedure division.
+ move 111.111 to var.
+ if var not equal to 111.111 display var.
+ add 000.001 to var.
+ if var not equal to 111.112 display var.
+ add 000.01 to var.
+ if var not equal to 111.122 display var.
+ add 000.1 to var.
+ if var not equal to 111.222 display var.
+ add 1 to var.
+ if var not equal to 112.222 display var.
+ add 10 to var.
+ if var not equal to 122.222 display var.
+ add 100 to var.
+ if var not equal to 222.222 display var.
+ move 555.55555555 to var1
+ move 555.55555555 to var2
+ move 555.55555555 to var3
+ move 555.55555555 to var4
+ move 555.55555555 to var5
+ move 555.55555555 to var6
+ move 555.55555555 to var7
+ move 555.55555555 to var8
+ add 0.00000001 TO var555 giving var1 rounded
+ add 0.00000001 TO var555 giving var2 rounded
+ add 0.00000001 TO var555 giving var3 rounded
+ add 0.00000001 TO var555 giving var4 rounded
+ add 0.00000001 TO var555 giving var5 rounded
+ add 0.00000001 TO var555 giving var6 rounded
+ add 0.00000001 TO var555 giving var7 rounded
+ add 0.00000001 TO var555 giving var8 rounded
+ if var1 not equal to 555.6 display var1.
+ if var2 not equal to 555.56 display var2.
+ if var3 not equal to 555.556 display var3.
+ if var4 not equal to 555.5556 display var4.
+ if var5 not equal to 555.55556 display var5.
+ if var6 not equal to 555.555556 display var6.
+ if var7 not equal to 555.5555556 display var7.
+ if var8 not equal to 555.55555556 display var8.
+ stop run.
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/Complex_HEX__VALUE_and_MOVE_-_ASCII_EBCDIC.out" }
+ identification division.
+ program-id. hex-init.
+ data division.
+ working-storage section.
+ 01 template.
+ 05 under-test pic x(8).
+ 05 filler pic x.
+ 05 msg pic x(12).
+ 05 filler pic x.
+ 05 ascii-val pic x(8).
+ 05 filler pic x.
+ 05 ebcdic-val pic x(8).
+
+ 01 var01020304.
+ 05 filler1.
+ 10 filler2 pic x(2) VALUE "33".
+ 10 as-value pic x(4) VALUE X'01020304'.
+ 10 filler3 pic x(2) VALUE "33".
+ 05 filler pic x value space.
+ 05 msg pic x(12) value "var01020304".
+ 05 filler pic x value space.
+ 05 ascii-val pic x(8) value X"3333010203043333".
+ 05 filler pic x value space.
+ 05 ebcdic-val pic x(8) value X"f3f301020304f3f3".
+
+ 01 var-low.
+ 05 filler1.
+ 10 filler2 pic x(2) VALUE "33".
+ 10 as-value pic x(4) VALUE LOW-VALUES.
+ 10 filler3 pic x(2) VALUE "33".
+ 05 filler pic x value space.
+ 05 msg pic x(12) value "var-low".
+ 05 filler pic x value space.
+ 05 ascii-val pic x(8) value X"3333000000003333".
+ 05 filler pic x value space.
+ 05 ebcdic-val pic x(8) value X"f3f300000000f3f3".
+
+ 01 var-space.
+ 05 filler1.
+ 10 filler2 pic x(2) VALUE "33".
+ 10 as-value pic x(4) VALUE SPACE.
+ 10 filler3 pic x(2) VALUE "33".
+ 05 filler pic x value space.
+ 05 msg pic x(12) value "var-space".
+ 05 filler pic x value space.
+ 05 ascii-val pic x(8) value X"3333202020203333".
+ 05 filler pic x value space.
+ 05 ebcdic-val pic x(8) value X"f3f340404040f3f3".
+
+ 01 var-quote.
+ 05 filler1.
+ 10 filler2 pic x(2) VALUE "33".
+ 10 as-value pic x(4) VALUE QUOTE.
+ 10 filler3 pic x(2) VALUE "33".
+ 05 filler pic x value space.
+ 05 msg pic x(12) value "var-quote".
+ 05 filler pic x value space.
+ 05 ascii-val pic x(8) value X"3333222222223333".
+ 05 filler pic x value space.
+ 05 ebcdic-val pic x(8) value X"f3f37f7f7f7ff3f3".
+
+ 01 var-zero.
+ 05 filler1.
+ 10 filler2 pic x(2) VALUE "33".
+ 10 as-value pic x(4) VALUE ZERO.
+ 10 filler3 pic x(2) VALUE "33".
+ 05 filler pic x value space.
+ 05 msg pic x(12) value "var-zero".
+ 05 filler pic x value space.
+ 05 ascii-val pic x(8) value X"3333303030303333".
+ 05 filler pic x value space.
+ 05 ebcdic-val pic x(8) value X"f3f3f0f0f0f0f3f3".
+
+ 01 var-high.
+ 05 filler1.
+ 10 filler2 pic x(2) VALUE "33".
+ 10 as-value pic x(4) VALUE HIGH-VALUES.
+ 10 filler3 pic x(2) VALUE "33".
+ 05 filler pic x value space.
+ 05 msg pic x(12) value "var-high".
+ 05 filler pic x value space.
+ 05 ascii-val pic x(8) value X"3333ffffffff3333".
+ 05 filler pic x value space .
+ 05 ebcdic-val pic x(8) value X"f3f3fffffffff3f3".
+
+ procedure division.
+ move var01020304 to template perform checker
+ move var-low to template perform checker
+ move var-space to template perform checker
+ move var-quote to template perform checker
+ move var-zero to template perform checker
+ move var-high to template perform checker
+ goback.
+ checker.
+ display msg of template space with no advancing
+ if under-test of template =
+ ascii-val of template
+ or ebcdic-val of template
+ display "is okay."
+ else
+ display "is no good: " function hex-of(under-test)
+ end-if
+ continue.
+ end program hex-init.
+
--- /dev/null
+var01020304 is okay.
+var-low is okay.
+var-space is okay.
+var-quote is okay.
+var-zero is okay.
+var-high is okay.
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/Complex_INITIALIZE_with_nested_tables__1_.out" }
+
+ program-id. prog.
+ data division.
+ working-storage section.
+
+ 01 foo.
+ 05 FNAME PIC X(7) VALUE "James".
+ 05 FILLER PIC X(7) VALUE "Keen ".
+ 05 LNAME PIC X(7) VALUE "Lowden".
+
+ 01 filler PIC 9999 BINARY value zero.
+
+ 01 foo3.
+ 02 three-lines occurs 3 times.
+ 05 FNAME PIC X(7) VALUE "James".
+ 05 FILLER PIC X(7) VALUE "Keen ".
+ 05 LNAME PIC X(7) VALUE "Lowden".
+
+ 01 filler PIC 9999 BINARY value zero.
+
+ 01 four-by-four.
+ 05 four-outer occurs 4 times.
+ 10 four-inner occurs 4 times.
+ 15 FNAME PIC X(7) VALUE "James".
+ 15 FILLER PIC X(7) VALUE "Keen ".
+ 15 LNAME PIC X(7) VALUE "Lowden".
+
+ 01 filler PIC 9999 BINARY value zero.
+
+ 01 four-by-four2.
+ 05 label5 pic x(12) value "four-by-four".
+ 05 four-outer2 occurs 4 times.
+ 10 label10 pic x(12) value "four-outer".
+ 10 four-inner2 occurs 4 times.
+ 15 label15 pic x(12) value "four-inner".
+ 15 FNAME PIC X(7) VALUE "James".
+ 15 FILLER PIC X(7) VALUE "Keen ".
+ 15 LNAME PIC X(7) VALUE "Lowden".
+
+ procedure division.
+ display " Simple data structure"
+ display "1 " """" foo """".
+ INITIALIZE foo.
+ display "2 " """" foo """".
+ INITIALIZE foo WITH FILLER.
+ display "3 " """" foo """".
+ INITIALIZE foo ALL VALUE
+ display "4 " """" foo """".
+ INITIALIZE foo WITH FILLER ALL VALUE
+ display "5 " """" foo """".
+
+ display " Simple table"
+ display "31 " """" foo3 """".
+ initialize foo3
+ display "32 " """" foo3 """".
+ INITIALIZE foo3 WITH FILLER.
+ display "33 " """" foo3 """".
+ INITIALIZE foo3 ALL VALUE
+ display "34 " """" foo3 """".
+ INITIALIZE foo3 WITH FILLER ALL VALUE
+ display "35 " """" foo3 """".
+
+ move all "A" to three-lines(1)
+ move all "B" to three-lines(2)
+ move all "C" to three-lines(3)
+ display "36 " """" foo3 """".
+ INITIALIZE foo3 ALL VALUE
+ display "37 " """" foo3 """".
+
+ display " Simple four-by-four table"
+ display "40-1 " """" four-outer(1) """"
+ display "40-2 " """" four-outer(2) """"
+ display "40-3 " """" four-outer(3) """"
+ display "40-4 " """" four-outer(4) """"
+
+ move all 'A' to four-inner(1 1)
+ move all 'B' to four-inner(1 2)
+ move all 'C' to four-inner(1 3)
+ move all 'D' to four-inner(1 4)
+ move all 'E' to four-inner(2 1)
+ move all 'F' to four-inner(2 2)
+ move all 'G' to four-inner(2 3)
+ move all 'H' to four-inner(2 4)
+ move all 'I' to four-inner(3 1)
+ move all 'J' to four-inner(3 2)
+ move all 'K' to four-inner(3 3)
+ move all 'L' to four-inner(3 4)
+ move all 'M' to four-inner(4 1)
+ move all 'N' to four-inner(4 2)
+ move all 'O' to four-inner(4 3)
+ move all 'P' to four-inner(4 4)
+
+ display "41-1 " """" four-outer(1) """"
+ display "41-2 " """" four-outer(2) """"
+ display "41-3 " """" four-outer(3) """"
+ display "41-4 " """" four-outer(4) """"
+
+ INITIALIZE four-by-four ALL VALUE
+
+ display "42-1 " """" four-outer(1) """"
+ display "42-2 " """" four-outer(2) """"
+ display "42-3 " """" four-outer(3) """"
+ display "42-4 " """" four-outer(4) """"
+
+ display " Complex four-by-four table, with extra fields"
+ display "50-1 " """" four-outer2(1) """"
+ display "50-2 " """" four-outer2(2) """"
+ display "50-3 " """" four-outer2(3) """"
+ display "50-4 " """" four-outer2(4) """"
+
+ INITIALIZE four-by-four2.
+ display " After INITIALIZE, only the KEEN columns should be left"
+ display "51-1 " """" four-outer2(1) """"
+ display "51-2 " """" four-outer2(2) """"
+ display "51-3 " """" four-outer2(3) """"
+ display "51-4 " """" four-outer2(4) """"
+ INITIALIZE four-by-four2 WITH FILLER.
+ display " After INITIALIZE WITH FILLER, all should be blank"
+ display "52-1 " """" four-outer2(1) """"
+ display "52-2 " """" four-outer2(2) """"
+ display "52-3 " """" four-outer2(3) """"
+ display "52-4 " """" four-outer2(4) """"
+ INITIALIZE four-by-four2 ALL VALUE
+ display " After INITIALIZE ALL VALUE, all but the KEEN columns should be back"
+ display "53-1 " """" four-outer2(1) """"
+ display "53-2 " """" four-outer2(2) """"
+ display "53-3 " """" four-outer2(3) """"
+ display "53-4 " """" four-outer2(4) """"
+ INITIALIZE four-by-four2 WITH FILLER ALL VALUE
+ display " After INITIALIZE WITH FILLER ALL VALUE, should be the original"
+ display "54-1 " """" four-outer2(1) """"
+ display "54-2 " """" four-outer2(2) """"
+ display "54-3 " """" four-outer2(3) """"
+ display "54-4 " """" four-outer2(4) """"
+
+ move all 'A' to four-inner2(1 1)
+ move all 'B' to four-inner2(1 2)
+ move all 'C' to four-inner2(1 3)
+ move all 'D' to four-inner2(1 4)
+ move all 'E' to four-inner2(2 1)
+ move all 'F' to four-inner2(2 2)
+ move all 'G' to four-inner2(2 3)
+ move all 'H' to four-inner2(2 4)
+ move all 'I' to four-inner2(3 1)
+ move all 'J' to four-inner2(3 2)
+ move all 'K' to four-inner2(3 3)
+ move all 'L' to four-inner2(3 4)
+ move all 'M' to four-inner2(4 1)
+ move all 'N' to four-inner2(4 2)
+ move all 'O' to four-inner2(4 3)
+ move all 'P' to four-inner2(4 4)
+
+ display " After setting FILLER fields to unique values"
+ display "55-1 " """" four-outer2(1) """"
+ display "55-2 " """" four-outer2(2) """"
+ display "55-3 " """" four-outer2(3) """"
+ display "55-4 " """" four-outer2(4) """"
+
+ INITIALIZE four-by-four2 ALL VALUE
+ display " After INITIALIZE ALL VALUE, the KEEN columns should have the unique values"
+ display "56-1 " """" four-outer2(1) """"
+ display "56-2 " """" four-outer2(2) """"
+ display "56-3 " """" four-outer2(3) """"
+ display "56-4 " """" four-outer2(4) """"
+
+ goback.
+
--- /dev/null
+ Simple data structure
+1 "James Keen Lowden "
+2 " Keen "
+3 " "
+4 "James Lowden "
+5 "James Keen Lowden "
+ Simple table
+31 "James Keen Lowden James Keen Lowden James Keen Lowden "
+32 " Keen Keen Keen "
+33 " "
+34 "James Lowden James Lowden James Lowden "
+35 "James Keen Lowden James Keen Lowden James Keen Lowden "
+36 "AAAAAAAAAAAAAAAAAAAAABBBBBBBBBBBBBBBBBBBBBCCCCCCCCCCCCCCCCCCCCC"
+37 "James AAAAAAALowden James BBBBBBBLowden James CCCCCCCLowden "
+ Simple four-by-four table
+40-1 "James Keen Lowden James Keen Lowden James Keen Lowden James Keen Lowden "
+40-2 "James Keen Lowden James Keen Lowden James Keen Lowden James Keen Lowden "
+40-3 "James Keen Lowden James Keen Lowden James Keen Lowden James Keen Lowden "
+40-4 "James Keen Lowden James Keen Lowden James Keen Lowden James Keen Lowden "
+41-1 "AAAAAAAAAAAAAAAAAAAAABBBBBBBBBBBBBBBBBBBBBCCCCCCCCCCCCCCCCCCCCCDDDDDDDDDDDDDDDDDDDDD"
+41-2 "EEEEEEEEEEEEEEEEEEEEEFFFFFFFFFFFFFFFFFFFFFGGGGGGGGGGGGGGGGGGGGGHHHHHHHHHHHHHHHHHHHHH"
+41-3 "IIIIIIIIIIIIIIIIIIIIIJJJJJJJJJJJJJJJJJJJJJKKKKKKKKKKKKKKKKKKKKKLLLLLLLLLLLLLLLLLLLLL"
+41-4 "MMMMMMMMMMMMMMMMMMMMMNNNNNNNNNNNNNNNNNNNNNOOOOOOOOOOOOOOOOOOOOOPPPPPPPPPPPPPPPPPPPPP"
+42-1 "James AAAAAAALowden James BBBBBBBLowden James CCCCCCCLowden James DDDDDDDLowden "
+42-2 "James EEEEEEELowden James FFFFFFFLowden James GGGGGGGLowden James HHHHHHHLowden "
+42-3 "James IIIIIIILowden James JJJJJJJLowden James KKKKKKKLowden James LLLLLLLLowden "
+42-4 "James MMMMMMMLowden James NNNNNNNLowden James OOOOOOOLowden James PPPPPPPLowden "
+ Complex four-by-four table, with extra fields
+50-1 "four-outer four-inner James Keen Lowden four-inner James Keen Lowden four-inner James Keen Lowden four-inner James Keen Lowden "
+50-2 "four-outer four-inner James Keen Lowden four-inner James Keen Lowden four-inner James Keen Lowden four-inner James Keen Lowden "
+50-3 "four-outer four-inner James Keen Lowden four-inner James Keen Lowden four-inner James Keen Lowden four-inner James Keen Lowden "
+50-4 "four-outer four-inner James Keen Lowden four-inner James Keen Lowden four-inner James Keen Lowden four-inner James Keen Lowden "
+ After INITIALIZE, only the KEEN columns should be left
+51-1 " Keen Keen Keen Keen "
+51-2 " Keen Keen Keen Keen "
+51-3 " Keen Keen Keen Keen "
+51-4 " Keen Keen Keen Keen "
+ After INITIALIZE WITH FILLER, all should be blank
+52-1 " "
+52-2 " "
+52-3 " "
+52-4 " "
+ After INITIALIZE ALL VALUE, all but the KEEN columns should be back
+53-1 "four-outer four-inner James Lowden four-inner James Lowden four-inner James Lowden four-inner James Lowden "
+53-2 "four-outer four-inner James Lowden four-inner James Lowden four-inner James Lowden four-inner James Lowden "
+53-3 "four-outer four-inner James Lowden four-inner James Lowden four-inner James Lowden four-inner James Lowden "
+53-4 "four-outer four-inner James Lowden four-inner James Lowden four-inner James Lowden four-inner James Lowden "
+ After INITIALIZE WITH FILLER ALL VALUE, should be the original
+54-1 "four-outer four-inner James Keen Lowden four-inner James Keen Lowden four-inner James Keen Lowden four-inner James Keen Lowden "
+54-2 "four-outer four-inner James Keen Lowden four-inner James Keen Lowden four-inner James Keen Lowden four-inner James Keen Lowden "
+54-3 "four-outer four-inner James Keen Lowden four-inner James Keen Lowden four-inner James Keen Lowden four-inner James Keen Lowden "
+54-4 "four-outer four-inner James Keen Lowden four-inner James Keen Lowden four-inner James Keen Lowden four-inner James Keen Lowden "
+ After setting FILLER fields to unique values
+55-1 "four-outer AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD"
+55-2 "four-outer EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHH"
+55-3 "four-outer IIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL"
+55-4 "four-outer MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPP"
+ After INITIALIZE ALL VALUE, the KEEN columns should have the unique values
+56-1 "four-outer four-inner James AAAAAAALowden four-inner James BBBBBBBLowden four-inner James CCCCCCCLowden four-inner James DDDDDDDLowden "
+56-2 "four-outer four-inner James EEEEEEELowden four-inner James FFFFFFFLowden four-inner James GGGGGGGLowden four-inner James HHHHHHHLowden "
+56-3 "four-outer four-inner James IIIIIIILowden four-inner James JJJJJJJLowden four-inner James KKKKKKKLowden four-inner James LLLLLLLLowden "
+56-4 "four-outer four-inner James MMMMMMMLowden four-inner James NNNNNNNLowden four-inner James OOOOOOOLowden four-inner James PPPPPPPLowden "
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/Complex_INITIALIZE_with_nested_tables__2_.out" }
+
+ program-id. prog.
+ data division.
+ working-storage section.
+
+ 01 three-by-three2.
+ 05 label5 pic x(14) value "three-by-three".
+ 05 three-outer2 occurs 3 times.
+ 10 label10 pic x(12) value "leading".
+ 10 three-inner2 occurs 3 times.
+ 15 label15 pic x(12) value "three-inner".
+ 15 FNAME PIC X(7) VALUE "James".
+ 15 FILLER PIC X(7) VALUE "Keen ".
+ 15 LNAME PIC X(7) VALUE "Lowden".
+ 10 label10 pic x(12) value "middling".
+ 10 three-inner22 occurs 3 times.
+ 15 label15 pic x(12) value "three-inner".
+ 15 FNAME PIC X(7) VALUE "James".
+ 15 FILLER PIC X(7) VALUE "Keen ".
+ 15 LNAME PIC X(7) VALUE "Lowden".
+ 10 label10 pic x(12) value "trailing".
+
+ procedure division.
+ display " Complex three-by-three table, with extra fields"
+ display "50-1 " """" three-outer2(1) """"
+ display "50-2 " """" three-outer2(2) """"
+ display "50-3 " """" three-outer2(3) """"
+
+ INITIALIZE three-by-three2.
+ display " After INITIALIZE, only the KEEN columns should be left"
+ display "51-1 " """" three-outer2(1) """"
+ display "51-2 " """" three-outer2(2) """"
+ display "51-3 " """" three-outer2(3) """"
+ INITIALIZE three-by-three2 WITH FILLER.
+ display " After INITIALIZE WITH FILLER, all should be blank"
+ display "52-1 " """" three-outer2(1) """"
+ display "52-2 " """" three-outer2(2) """"
+ display "52-3 " """" three-outer2(3) """"
+ INITIALIZE three-by-three2 ALL VALUE
+ display " After INITIALIZE ALL VALUE, all but the KEEN columns should be back"
+ display "53-1 " """" three-outer2(1) """"
+ display "53-2 " """" three-outer2(2) """"
+ display "53-3 " """" three-outer2(3) """"
+ INITIALIZE three-by-three2 WITH FILLER ALL VALUE
+ display " After INITIALIZE WITH FILLER ALL VALUE, should be the original"
+ display "54-1 " """" three-outer2(1) """"
+ display "54-2 " """" three-outer2(2) """"
+ display "54-3 " """" three-outer2(3) """"
+
+ move all 'Z' to three-by-three2
+ move all 'A' to three-inner2(1 1)
+ move all 'B' to three-inner2(1 2)
+ move all 'C' to three-inner2(1 3)
+ move all 'D' to three-inner2(2 1)
+ move all 'E' to three-inner2(2 2)
+ move all 'F' to three-inner2(2 3)
+ move all 'G' to three-inner2(3 1)
+ move all 'H' to three-inner2(3 2)
+ move all 'I' to three-inner2(3 3)
+
+ move all 'a' to three-inner22(1 1)
+ move all 'b' to three-inner22(1 2)
+ move all 'c' to three-inner22(1 3)
+ move all 'd' to three-inner22(2 1)
+ move all 'e' to three-inner22(2 2)
+ move all 'f' to three-inner22(2 3)
+ move all 'g' to three-inner22(3 1)
+ move all 'h' to three-inner22(3 2)
+ move all 'i' to three-inner22(3 3)
+
+ display " After setting FILLER fields to unique values"
+ display "55-1 " """" three-outer2(1) """"
+ display "55-2 " """" three-outer2(2) """"
+ display "55-3 " """" three-outer2(3) """"
+
+ INITIALIZE three-by-three2 ALL VALUE
+ display " After INITIALIZE ALL VALUE, the KEEN columns should have the unique values"
+ display "56-1 " """" three-outer2(1) """"
+ display "56-2 " """" three-outer2(2) """"
+ display "56-3 " """" three-outer2(3) """"
+
+ goback.
+
--- /dev/null
+ Complex three-by-three table, with extra fields
+50-1 "leading three-inner James Keen Lowden three-inner James Keen Lowden three-inner James Keen Lowden middling three-inner James Keen Lowden three-inner James Keen Lowden three-inner James Keen Lowden trailing "
+50-2 "leading three-inner James Keen Lowden three-inner James Keen Lowden three-inner James Keen Lowden middling three-inner James Keen Lowden three-inner James Keen Lowden three-inner James Keen Lowden trailing "
+50-3 "leading three-inner James Keen Lowden three-inner James Keen Lowden three-inner James Keen Lowden middling three-inner James Keen Lowden three-inner James Keen Lowden three-inner James Keen Lowden trailing "
+ After INITIALIZE, only the KEEN columns should be left
+51-1 " Keen Keen Keen Keen Keen Keen "
+51-2 " Keen Keen Keen Keen Keen Keen "
+51-3 " Keen Keen Keen Keen Keen Keen "
+ After INITIALIZE WITH FILLER, all should be blank
+52-1 " "
+52-2 " "
+52-3 " "
+ After INITIALIZE ALL VALUE, all but the KEEN columns should be back
+53-1 "leading three-inner James Lowden three-inner James Lowden three-inner James Lowden middling three-inner James Lowden three-inner James Lowden three-inner James Lowden trailing "
+53-2 "leading three-inner James Lowden three-inner James Lowden three-inner James Lowden middling three-inner James Lowden three-inner James Lowden three-inner James Lowden trailing "
+53-3 "leading three-inner James Lowden three-inner James Lowden three-inner James Lowden middling three-inner James Lowden three-inner James Lowden three-inner James Lowden trailing "
+ After INITIALIZE WITH FILLER ALL VALUE, should be the original
+54-1 "leading three-inner James Keen Lowden three-inner James Keen Lowden three-inner James Keen Lowden middling three-inner James Keen Lowden three-inner James Keen Lowden three-inner James Keen Lowden trailing "
+54-2 "leading three-inner James Keen Lowden three-inner James Keen Lowden three-inner James Keen Lowden middling three-inner James Keen Lowden three-inner James Keen Lowden three-inner James Keen Lowden trailing "
+54-3 "leading three-inner James Keen Lowden three-inner James Keen Lowden three-inner James Keen Lowden middling three-inner James Keen Lowden three-inner James Keen Lowden three-inner James Keen Lowden trailing "
+ After setting FILLER fields to unique values
+55-1 "ZZZZZZZZZZZZAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCZZZZZZZZZZZZaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaabbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbcccccccccccccccccccccccccccccccccZZZZZZZZZZZZ"
+55-2 "ZZZZZZZZZZZZDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFZZZZZZZZZZZZdddddddddddddddddddddddddddddddddeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeefffffffffffffffffffffffffffffffffZZZZZZZZZZZZ"
+55-3 "ZZZZZZZZZZZZGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIZZZZZZZZZZZZggggggggggggggggggggggggggggggggghhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiZZZZZZZZZZZZ"
+ After INITIALIZE ALL VALUE, the KEEN columns should have the unique values
+56-1 "leading three-inner James AAAAAAALowden three-inner James BBBBBBBLowden three-inner James CCCCCCCLowden middling three-inner James aaaaaaaLowden three-inner James bbbbbbbLowden three-inner James cccccccLowden trailing "
+56-2 "leading three-inner James DDDDDDDLowden three-inner James EEEEEEELowden three-inner James FFFFFFFLowden middling three-inner James dddddddLowden three-inner James eeeeeeeLowden three-inner James fffffffLowden trailing "
+56-3 "leading three-inner James GGGGGGGLowden three-inner James HHHHHHHLowden three-inner James IIIIIIILowden middling three-inner James gggggggLowden three-inner James hhhhhhhLowden three-inner James iiiiiiiLowden trailing "
+
WORKING-STORAGE SECTION.
01 BYTE-LENGTH PIC 9.
01 X CONSTANT AS BYTE-LENGTH OF BYTE-LENGTH.
+ 01 stride binary-short.
PROCEDURE DIVISION.
+ move function byte-length("A") to stride
MOVE X TO BYTE-LENGTH.
+ compute byte-length = x / stride
DISPLAY BYTE-LENGTH NO ADVANCING
END-DISPLAY.
STOP RUN.
*> { dg-do run }
*> { dg-output-file "group2/DEBUG_Line.out" }
-
+ >>SOURCE FIXED
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
ENVIRONMENT DIVISION.
*> { dg-do run }
*> { dg-output-file "group2/DISPLAY__Sign_ASCII.out" }
-
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
DATA DIVISION.
02 X-S9-T REDEFINES X PIC S9(4) TRAILING.
02 X-S9-TS REDEFINES X PIC S9(4) TRAILING SEPARATE.
PROCEDURE DIVISION.
- MOVE ZERO TO X. MOVE 1234 TO X-9. DISPLAY X
- END-DISPLAY.
- MOVE ZERO TO X. MOVE 1234 TO X-S9. DISPLAY X
- END-DISPLAY.
- MOVE ZERO TO X. MOVE -1234 TO X-S9. DISPLAY X
- END-DISPLAY.
- MOVE ZERO TO X. MOVE 1234 TO X-S9-L. DISPLAY X
- END-DISPLAY.
- MOVE ZERO TO X. MOVE -1234 TO X-S9-L. DISPLAY X
- END-DISPLAY.
- MOVE ZERO TO X. MOVE 1234 TO X-S9-LS. DISPLAY X
- END-DISPLAY.
- MOVE ZERO TO X. MOVE -1234 TO X-S9-LS. DISPLAY X
- END-DISPLAY.
- MOVE ZERO TO X. MOVE 1234 TO X-S9-T. DISPLAY X
- END-DISPLAY.
- MOVE ZERO TO X. MOVE -1234 TO X-S9-T. DISPLAY X
- END-DISPLAY.
- MOVE ZERO TO X. MOVE 1234 TO X-S9-TS. DISPLAY X
- END-DISPLAY.
- MOVE ZERO TO X. MOVE -1234 TO X-S9-TS. DISPLAY X
- END-DISPLAY.
- STOP RUN.
+ MOVE ZERO TO X MOVE 1234 TO X-9 DISPLAY X
+ MOVE ZERO TO X MOVE 1234 TO X-S9 DISPLAY X
+ MOVE ZERO TO X MOVE -1234 TO X-S9
+ *> Let's be ecumenical with regard to ASCII and EBCDIC:
+ if X equals "123M0" or "123t0" DISPLAY "-1234"
+ else DISPLAY X " Not Good"
+ end-if
+ MOVE ZERO TO X MOVE 1234 TO X-S9-L DISPLAY X
+ MOVE ZERO TO X MOVE -1234 TO X-S9-L
+ if X equals "J2340" or "q2340" DISPLAY "-1234"
+ else DISPLAY X " Not Good"
+ end-if
+ MOVE ZERO TO X MOVE 1234 TO X-S9-LS DISPLAY X
+ MOVE ZERO TO X MOVE -1234 TO X-S9-LS DISPLAY X
+ MOVE ZERO TO X MOVE 1234 TO X-S9-T DISPLAY X
+ MOVE ZERO TO X MOVE -1234 TO X-S9-T
+ if X equals "123M0" or "123t0" DISPLAY "-1234"
+ else DISPLAY X " Not Good"
+ end-if
+ MOVE ZERO TO X MOVE 1234 TO X-S9-TS DISPLAY X
+ MOVE ZERO TO X MOVE -1234 TO X-S9-TS DISPLAY X
+ goback.
+ end program prog.
12340
12340
-123t0
+-1234
12340
-q2340
+-1234
+1234
-1234
12340
-123t0
+-1234
1234+
1234-
*> { dg-do run }
*> { dg-output-file "group2/DISPLAY__Sign_ASCII__2_.out" }
-
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
DATA DIVISION.
MOVE 7 TO X-S9(8).
MOVE 8 TO X-S9(9).
MOVE 9 TO X-S9(10).
- DISPLAY X NO ADVANCING
- END-DISPLAY.
+ DISPLAY X
MOVE -10 TO X-S99. MOVE X(2:1) TO X(1:1).
MOVE -1 TO X-S9(2).
MOVE -2 TO X-S9(3).
MOVE -7 TO X-S9(8).
MOVE -8 TO X-S9(9).
MOVE -9 TO X-S9(10).
- DISPLAY X NO ADVANCING
- END-DISPLAY.
+ *> Let's be tolerant of our ECDIC friends:
+ if x equal "}JKLMNOPQR" or "pqrstuvwxy" then
+ display "It's properly either pqrstuvwxy or }JKLMNOPQR"
+ else
+ display "It's wrong: " """" X """"
+ end-if
STOP RUN.
-0123456789pqrstuvwxy
+0123456789
+It's properly either pqrstuvwxy or }JKLMNOPQR
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/Default_Arithmetic__1_.out" }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 NUM-A PIC 9(3) VALUE 399.
+ 01 NUM-B PIC 9(3) VALUE 211.
+ 01 NUM-C PIC 9(3)V99 VALUE 212.34.
+ 01 NUMV1 PIC 9(3)V9.
+ 01 PICX PIC X VALUE 'A'.
+ 01 RSLT PIC 9(3).
+ 01 RSLTV1 PIC 9(3).9.
+ 01 RSLTV2 PIC 9(3).99.
+ *
+ PROCEDURE DIVISION.
+ MAIN.
+ COMPUTE RSLT = NUM-A + 1.1.
+ DISPLAY 'Simple Compute RSLT IS ' RSLT
+ COMPUTE RSLT = ((NUM-A / 100) - (NUM-B / 100)) * 100
+ DISPLAY 'Single Variable RSLT IS ' RSLT
+ COMPUTE RSLTV2, RSLT = ((NUM-A / 100) - (NUM-B / 100)) * 100
+ DISPLAY 'Compute RSLT IS ' RSLT
+ DISPLAY 'Compute RSLTv99 IS ' RSLTV2
+ COMPUTE RSLTV1, RSLT = ((NUM-A / 100) - (NUM-B / 100)) * 100
+ DISPLAY 'Compute RSLT IS ' RSLT
+ DISPLAY 'Compute RSLTv9 IS ' RSLTV1
+ MOVE 0 TO RSLT
+ ADD NUM-C TO RSLT.
+ DISPLAY 'Add RSLT IS ' RSLT.
+ MOVE 0 TO RSLT
+ ADD NUM-A NUM-C 10 TO RSLT.
+ DISPLAY 'Add RSLT IS ' RSLT.
+ SUBTRACT NUM-C FROM RSLT.
+ DISPLAY 'Subtract RSLT IS ' RSLT.
+ SUBTRACT NUM-A -10 FROM RSLT.
+ DISPLAY 'Subtract RSLT IS ' RSLT.
+ MOVE 0 TO RSLT
+ ADD NUM-A NUM-C TO RSLT GIVING RSLTV1.
+ DISPLAY 'Add RSLTv9 IS ' RSLTV1
+ MULTIPLY NUM-A BY NUM-C GIVING RSLT.
+ DISPLAY 'Multiply RSLT IS ' RSLT.
+ MULTIPLY RSLT BY NUM-C.
+ DISPLAY 'Multiply RSLT IS ' RSLT.
+ DIVIDE NUM-A BY 10 GIVING RSLT.
+ DISPLAY 'Divide RSLT IS ' RSLT.
+ DIVIDE RSLT BY 4 GIVING RSLTV1.
+ DISPLAY 'Divide RSLTv9 IS ' RSLTV1.
+ DIVIDE RSLT BY 4 GIVING RSLT.
+ DISPLAY 'Divide RSLT IS ' RSLT.
+
+ COMPUTE RSLTV1, RSLT = ((NUM-A / 100) - (NUM-B / 100)) * 100
+ DISPLAY 'Simple RSLT IS ' RSLT
+ ' RSLTv9 IS ' RSLTV1.
+
+ COMPUTE RSLTV1, RSLT = ((NUM-A / (100.55 + -0.550))
+ - (NUM-B / (10.11 * 10 - 1.1)))
+ * (220 / 2.2)
+ DISPLAY 'Complex RSLT IS ' RSLT
+ ' RSLTv9 IS ' RSLTV1.
+
+ COMPUTE RSLTV1, RSLT = ((NUM-A / (101 - 1))
+ - (NUM-B / (10 * 10))) * (200 / 2)
+ DISPLAY 'Reduced RSLT IS ' RSLT
+ ' RSLTv9 IS ' RSLTV1.
+ MOVE NUM-A TO NUMV1.
+ IF ((NUMV1 / (101 - 1))
+ - (NUM-B / (10 * 10))) * (200 / 2) EQUAL 188
+ DISPLAY "Not Using ARITHMETIC-OSVS"
+ ELSE
+ DISPLAY "Using ARITHMETIC-OSVS"
+ END-IF.
+ STOP RUN.
+
--- /dev/null
+Simple Compute RSLT IS 400
+Single Variable RSLT IS 188
+Compute RSLT IS 188
+Compute RSLTv99 IS 188.00
+Compute RSLT IS 188
+Compute RSLTv9 IS 188.0
+Add RSLT IS 212
+Add RSLT IS 621
+Subtract RSLT IS 408
+Subtract RSLT IS 019
+Add RSLTv9 IS 611.3
+Multiply RSLT IS 723
+Multiply RSLT IS 723
+Divide RSLT IS 039
+Divide RSLTv9 IS 009.7
+Divide RSLT IS 009
+Simple RSLT IS 188 RSLTv9 IS 188.0
+Complex RSLT IS 188 RSLTv9 IS 188.0
+Reduced RSLT IS 188 RSLTv9 IS 188.0
+Not Using ARITHMETIC-OSVS
+
*> { dg-do run }
*> { dg-xfail-run-if "" { *-*-* } }
+ *> { dg-options "-Wno-any-length" }
*> { dg-output-file "group2/EC-BOUND-REF-MOD_checking_process_termination.out" }
identification division.
program-id. caller.
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/ENTRY_statement.out" }
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 01 msg pic x(32).
+ procedure division.
+ move "This is foo" to msg
+ display "About to call FOO"
+ call "foo" using msg
+ move "This is bar" to msg
+ display "About to call BAR"
+ call "bar" using msg
+ move "This is foo2" to msg
+ display "About to call FOO again"
+ call "foo" using msg
+ goback.
+ end program prog.
+
+ identification division.
+ program-id. foo.
+ data division.
+ linkage section.
+ 01 msg pic x(32).
+ procedure division using msg.
+ display " entry point foo: " function trim (msg)
+ entry "bar"
+ display " entry point bar: " function trim (msg)
+ goback.
+ end program foo.
+
--- /dev/null
+About to call FOO
+ entry point foo: This is foo
+ entry point bar: This is foo
+About to call BAR
+ entry point bar: This is bar
+About to call FOO again
+ entry point foo: This is foo2
+ entry point bar: This is foo2
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/EVALUATE__A__OR__a_.out" }
+ program-id. prog.
+ data division.
+ working-storage section.
+ 77 answer pic x.
+ procedure division.
+ move 'a' to answer
+ evaluate answer
+ when = "A" or "a"
+ display "answer is '" answer "'"
+ when other
+ display answer" is neither 'A' nor 'a' "
+ end-evaluate.
+
+ move 'A' to answer
+ evaluate answer
+ when = "A" or "a"
+ display "answer is '" answer "'"
+ when other
+ display answer" is neither 'A' nor 'a' "
+ end-evaluate.
+ end program prog.
+
--- /dev/null
+answer is 'a'
+answer is 'A'
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/EVALUATE_condition__1_.out" }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 77 var-1 PIC 99V9.
+ 88 var-1-big VALUE 20 THRU 40.
+ 88 var-1-huge VALUE 40 THRU 99.
+ PROCEDURE DIVISION.
+ EVALUATE TRUE *> not: var-1
+ WHEN var-1-big DISPLAY "big"
+ WHEN var-1-huge DISPLAY "huge"
+ WHEN OTHER DISPLAY "not"
+ END-EVALUATE.
+ END PROGRAM prog.
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-options "-fexec-charset=cp1140" }
+ *> { dg-output-file "group2/FIND-STRING__forward_.out" }
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 foo pic x(55) value "bob01 bob11 bob21 bob31 bob41 bob51".
+ 01 nfound pic 99.
+ PROCEDURE DIVISION.
+ move function find-string(foo, "bob") to nfound
+ display "A: " nfound
+ move function find-string(foo, "bob" start after 0) to nfound
+ display "B: " nfound
+ move function find-string(foo, "bob" start after 1) to nfound
+ display "C: " nfound
+ move function find-string(foo, "bob" start after 2) to nfound
+ display "D: " nfound
+ move function find-string(foo, "bob" start after 3) to nfound
+ display "E: " nfound
+ move function find-string(foo, "bob" start after 4) to nfound
+ display "F: " nfound
+ move function find-string(foo, "bob" start after 5) to nfound
+ display "G: " nfound
+ move function find-string(foo, "bob" start after 6) to nfound
+ display "H: " nfound
+
+ move function find-string(foo, "BOB") to nfound
+ display "I: " nfound
+
+ move function find-string(foo, "BOB"anycase) to nfound
+ display "J: " nfound
+ move function find-string(foo, "BOB" start after 0 anycase) to nfound
+ display "K: " nfound
+ move function find-string(foo, "BOB" start after 1 anycase) to nfound
+ display "L: " nfound
+ move function find-string(foo, "BOB" start after 2 anycase) to nfound
+ display "M: " nfound
+ move function find-string(foo, "BOB" start after 3 anycase) to nfound
+ display "N: " nfound
+ move function find-string(foo, "BOB" start after 4 anycase) to nfound
+ display "O: " nfound
+ move function find-string(foo, "BOB" start after 5 anycase) to nfound
+ display "P: " nfound
+ move function find-string(foo, "BOB" start after 6 anycase) to nfound
+ display "Q: " nfound
+ goback.
+
--- /dev/null
+A: 01
+B: 01
+C: 11
+D: 21
+E: 31
+F: 41
+G: 51
+H: 00
+I: 00
+J: 01
+K: 01
+L: 11
+M: 21
+N: 31
+O: 41
+P: 51
+Q: 00
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-options "-fexec-charset=cp1140" }
+ *> { dg-output-file "group2/FIND-STRING__reverse_.out" }
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 foo value "bob01 bob11 bob21 bob31 bob41 bob51".
+ 02 bar PIC X(55).
+ 01 nfound pic 99.
+ PROCEDURE DIVISION.
+ move function find-string(foo, "bob" last) to nfound
+ display "A: " nfound
+ move function find-string(foo, "bob" last start after 0) to nfound
+ display "B: " nfound
+ move function find-string(foo, "bob" last start after 1) to nfound
+ display "C: " nfound
+ move function find-string(foo, "bob" last start after 2) to nfound
+ display "D: " nfound
+ move function find-string(foo, "bob" last start after 3) to nfound
+ display "E: " nfound
+ move function find-string(foo, "bob" last start after 4) to nfound
+ display "F: " nfound
+ move function find-string(foo, "bob" last start after 5) to nfound
+ display "G: " nfound
+ move function find-string(foo, "bob" last start after 6) to nfound
+ display "H: " nfound
+
+ move function find-string(foo, "BOB" last) to nfound
+ display "I: " nfound
+
+ move function find-string(foo, "BOB" last anycase) to nfound
+ display "J: " nfound
+ move function find-string(foo, "BOB" last start after 0 anycase) to nfound
+ display "K: " nfound
+ move function find-string(foo, "BOB" last start after 1 anycase) to nfound
+ display "L: " nfound
+ move function find-string(foo, "BOB" last start after 2 anycase) to nfound
+ display "M: " nfound
+ move function find-string(foo, "BOB" last start after 3 anycase) to nfound
+ display "N: " nfound
+ move function find-string(foo, "BOB" last start after 4 anycase) to nfound
+ display "O: " nfound
+ move function find-string(foo, "BOB" last start after 5 anycase) to nfound
+ display "P: " nfound
+ move function find-string(foo, "BOB" last start after 6 anycase) to nfound
+ display "Q: " nfound
+ goback.
+
--- /dev/null
+A: 51
+B: 51
+C: 41
+D: 31
+E: 21
+F: 11
+G: 01
+H: 00
+I: 00
+J: 51
+K: 51
+L: 41
+M: 31
+N: 21
+O: 11
+P: 01
+Q: 00
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-options "-ffixed-form" }
+ *> { dg-output-file "group2/FIXED_FORMAT_data_in_cols_73_and_beyond.out" }
+
+ *> ISO-IEC2014 leaves the length of the Program Area in Fixed
+ *> Format to the implementor.
+ *> By convention it ends in position 72.
+ *> IBM's COBOLs, Microfocus, GnuCOBOL follow that convention.
+ IDENTIFICATION DIVISION. VALID
+ PROGRAM-ID. prog.
+ PROCEDURE DIVISION.
+ DISPLAY "OK"
+ GOBACK.
+ END PROGRAM prog.
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-options "-ffixed-form" }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 77 var PIC 99 VALUE ZERO.
+ PROCEDURE DIVISION.
+ COMPUTE VAR = 5
+ * 3
+ + 6.
+ IF var NOT = 11
+ MOVE 1 to RETURN-CODE
+ DISPLAY var.
+ GOBACK.
+ END PROGRAM prog.
+
*> { dg-do run }
*> { dg-options "-dialect ibm" }
*> { dg-output-file "group2/FUNCTION_BIGGER-POINTER.out" }
-
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
DATA DIVISION.
01 FILLER.
05 X PIC A(4) VALUE "ABC".
05 E REDEFINES X PIC A(1) OCCURS 4.
+ 01 stride binary-short.
LINKAGE SECTION.
77 B PIC A.
-
PROCEDURE DIVISION.
+ move function byte-length("A") to stride
set P to address of E(1).
display FUNCTION trim(x) '.'
set address of B to p.
perform until B = SPACE
display B no advancing
- set p up by 1
+ set p up by stride
set address of B to p
end-perform
display '.'
set address of B to p
perform until B = SPACES
display B no advancing
- add 1 to N
+ add stride to N
set address of B to p
end-perform
display '.'
*> { dg-do run }
*> { dg-output-file "group2/FUNCTION_BYTE-LENGTH.out" }
-
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 X PIC X(4).
- 01 TEST-FLD PIC S9(04)V9(08).
- PROCEDURE DIVISION.
- MOVE FUNCTION BYTE-LENGTH ( TEST-FLD ) TO TEST-FLD.
- DISPLAY "BYTE-LENGTH of PIC S9(04)V9(08) is " TEST-FLD
- MOVE FUNCTION BYTE-LENGTH ( X ) TO TEST-FLD.
- DISPLAY "BYTE-LENGTH of PIC X(4) is " TEST-FLD
- MOVE FUNCTION BYTE-LENGTH ( '00128' ) TO TEST-FLD
- DISPLAY "BYTE-LENGTH of PIC '00128' is " TEST-FLD
- MOVE FUNCTION BYTE-LENGTH ( x'a0' ) TO TEST-FLD
- DISPLAY "BYTE-LENGTH of PIC x'a0' is " TEST-FLD
- STOP RUN.
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 01 one-char pic x.
+ 01 x pic x(4).
+ 01 test-fld pic s9(04)v9(08).
+ 01 stride usage binary-long.
+ 01 nbytes usage binary-long.
+ procedure division.
+ *> We are going to use this routine to compensate for itself, so
+ *> that it can be used for single- and multi=byte encodings:
+ move function byte-length(one-char) to stride
+ compute test-fld = function byte-length ( test-fld ) / stride
+ display "byte-length of pic s9(04)v9(08) is " test-fld
+ compute test-fld = function byte-length ( x ) / stride
+ display "byte-length of pic x(4) is " test-fld
+ compute test-fld = function byte-length ( '00128' ) / stride
+ display "byte-length of '00128' is " test-fld
+ move function byte-length ( x'a0' ) to test-fld
+ display "byte-length of pic x'a0' is " test-fld
+ goback.
-BYTE-LENGTH of PIC S9(04)V9(08) is +0012.00000000
-BYTE-LENGTH of PIC X(4) is +0004.00000000
-BYTE-LENGTH of PIC '00128' is +0005.00000000
-BYTE-LENGTH of PIC x'a0' is +0001.00000000
+byte-length of pic s9(04)v9(08) is +0012.00000000
+byte-length of pic x(4) is +0004.00000000
+byte-length of '00128' is +0005.00000000
+byte-length of pic x'a0' is +0001.00000000
*> { dg-do run }
-
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
DATA DIVISION.
05 TEST-UNSET PIC X VALUE '_'.
88 VALID-UNSET VALUE '_'.
PROCEDURE DIVISION.
+ *> Use ORD to make this routine ASCII/EBCDIC agnostic
+ MOVE function ORD('k') to X
STRING FUNCTION CHAR ( X )
DELIMITED BY SIZE
INTO TEST-FLD
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/FUNCTION_CONVERT.out" }
+ identification division.
+ program-id. conv.
+ environment division.
+ configuration section.
+ special-names.
+ locale sbc is "cp1252"
+ locale ebcd is "cp1140".
+ object-computer.
+ gnu-linux
+ classification
+ for alphanumeric is sbc
+ for national is ebcd.
+ data division.
+ working-storage section.
+ 01 hello-a pic X(12) value "I am ascii".
+ 01 hello-e pic N(12) value N"I am ebcdic".
+ 01 hex-a pic X(4) value "01F9".
+ 01 hex-e pic N(4) value N"F109".
+ procedure division.
+ display hello-a space function hex-of(hello-a)
+ display hello-e space function hex-of(hello-e)
+ display hex-a space function hex-of(hex-a)
+ display hex-e space function hex-of(hex-e)
+
+ display function convert(hello-a ANY ANUM HEX)
+ display function convert(hello-a ANY NAT HEX)
+
+ display function convert(hello-e ANY ANUM HEX)
+ display function convert(hello-e ANY NAT HEX)
+
+ display function convert(hex-a HEX BYTE)
+ display function convert(hex-e HEX BYTE)
+
+ display function convert(hello-a ANUM NAT)
+ space FUNCTION HEX-OF (function convert(hello-a ANUM NAT))
+ display function convert(hello-e NAT ANUM)
+ space FUNCTION HEX-OF (function convert(hello-e NAT ANUM))
+
+ goback.
+ end program conv.
+
+
--- /dev/null
+I am ascii 4920616D2061736369692020
+I am ebcdic C94081944085828384898340
+01F9 30314639
+F109 C6F1F0F9
+4920616D2061736369692020
+C94081944081A28389894040
+4920616D2065626364696320
+C94081944085828384898340
+0000000111111001
+1111000100001001
+I am ascii C94081944081A28389894040
+I am ebcdic 4920616D2065626364696320
+
*> { dg-do run }
- *> { dg-set-target-env-var TZ UTC0 }
identification division.
- program-id. test.
+ program-id. testy.
*> Tests all the DATE and TIME functions
*>
*> The various functions are used to test each other.
01 forced_date_v pic X(64) VALUE Z"1945/06/01 12:34:56".
procedure division.
- CALL "setenv" using forced_date_n, forced_date_v
+ set environment forced_date_n to forced_date_v
move "SECONDS-PAST-MIDNIGHT" to checking
move "45296" to should-be
move "+hh:mm" TO should-be(20:6)
end-if
.
- end program test.
+ end program testy.
*> { dg-do run }
*> { dg-output-file "group2/FUNCTION_HEX-OF.out" }
-
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 PAC PIC 9(5) COMP-3 VALUE 12345.
PROCEDURE DIVISION.
- DISPLAY FUNCTION HEX-OF('Hello, world!')
+ DISPLAY FUNCTION HEX-OF(X'0102030481828384')
DISPLAY FUNCTION HEX-OF(PAC).
END PROGRAM prog.
-48656C6C6F2C20776F726C6421
+0102030481828384
12345F
*> { dg-do run }
*> { dg-output-file "group2/FUNCTION_ORD.out" }
-
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 RESULT PIC 999.
- PROCEDURE DIVISION.
- MOVE FUNCTION ORD ( "k" ) TO RESULT
- DISPLAY RESULT
- END-DISPLAY.
- STOP RUN.
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 01 result pic 999.
+ procedure division.
+ move function ord ( "k" ) to result
+ if result = 147 or 108
+ display "ORD result is ebcdic or ascii for 'k'"
+ else
+ display "ORD result is improperly " result
+ end-if
+ goback.
+ end program prog.
-108
+ORD result is ebcdic or ascii for 'k'
*> { dg-do run }
identification division.
- program-id. test.
+ program-id. testy.
data division.
working-storage section.
01 datev pic 99999999.
should_be " but was " result
move 1 to return-code
end-if.
- end program test.
+ end program testy.
*> { dg-do run }
identification division.
- program-id. test.
+ program-id. testy.
data division.
working-storage section.
01 datev pic 99999999.
end-if
add 1 to date-integer
end-perform.
- end program test.
+ end program testy.
*> { dg-do run }
+ *> { dg-options "-Wno-any-length" }
*> { dg-output-file "group2/FUNCTION_as_CALL_parameter_BY_CONTENT.out" }
IDENTIFICATION DIVISION.
--- /dev/null
+ *> { dg-do run }
+ *> { dg-options "-dialect mf" }
+ *> { dg-output-file "group2/Fundamental_INSPECT_BACKWARD_REPLACING.out" }
+ program-id. prog.
+ data division.
+ working-storage section.
+ *> Note that 'item' has to have a length divisible by three for
+ *> the trailing "Abc" tests to work.
+ 01 item pic x(45).
+ procedure division.
+ display "INSPECT BACKWARD REPLACING Abc by MMM"
+ move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc" to item
+ display function trim(item)
+
+ move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc" to item
+ inspect backward item replacing all "Abc" by "MMM"
+ display "all " item with no advancing
+ if item <> "MMMMMMXMMMMMMMMMYMMMMMMMMMMMM MMMMMMMMMMMMMMM"
+ display " Not right." else display " Okay." end-if
+
+ move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc" to item
+ inspect backward item replacing leading "Abc" by "MMM"
+ display "leading " item with no advancing
+ if item <> "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc MMMMMMMMMMMMMMM"
+ display " Not right." else display " Okay." end-if
+
+ move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc" to item
+ inspect backward item replacing all "Abc" by "MMM" after "Y" before "X"
+ display "Y to X " item with no advancing
+ if item <> "AbcAbcXMMMMMMMMMYAbcAbcAbcAbc AbcAbcAbcAbcAbc"
+ display " Not right." else display " Okay." end-if
+
+ move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc" to item
+ inspect backward item replacing all "Abc" by "MMM" after space before "Y"
+ display "space to Y " item with no advancing
+ if item <> "AbcAbcXAbcAbcAbcYMMMMMMMMMMMM AbcAbcAbcAbcAbc"
+ display " Not right." else display " Okay." end-if
+
+ move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc" to item
+ inspect backward item replacing trailing "Abc" by "MMM"
+ display "trailing " item with no advancing
+ if item <> "MMMMMMXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc"
+ display " Not right." else display " Okay." end-if
+
+ move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc" to item
+ inspect backward item replacing all "Abc" by "MMM" after "X"
+ display "after X " item with no advancing
+ if item <> "MMMMMMXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc"
+ display " Not right." else display " Okay." end-if
+
+ move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc" to item
+ inspect backward item replacing all "Abc" by "MMM" before space
+ display "before space " item with no advancing
+ if item <> "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc MMMMMMMMMMMMMMM"
+ display " Not right." else display " Okay." end-if
+
+ move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc" to item
+ inspect backward item replacing all "Abc" by "MMM" after "b"
+ display "after b " item with no advancing
+ if item <> "MMMMMMXMMMMMMMMMYMMMMMMMMMMMM MMMMMMMMMMMMAbc"
+ display " Not right." else display " Okay." end-if
+
+ move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc" to item
+ inspect backward item replacing all "Abc" by "MMM" before "b"
+ display "before b " item with no advancing
+ if item <> "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc"
+ display " Not right." else display " Okay." end-if
+
+ goback.
+
+ end program prog.
+
--- /dev/null
+INSPECT BACKWARD REPLACING Abc by MMM
+AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc
+all MMMMMMXMMMMMMMMMYMMMMMMMMMMMM MMMMMMMMMMMMMMM Okay.
+leading AbcAbcXAbcAbcAbcYAbcAbcAbcAbc MMMMMMMMMMMMMMM Okay.
+Y to X AbcAbcXMMMMMMMMMYAbcAbcAbcAbc AbcAbcAbcAbcAbc Okay.
+space to Y AbcAbcXAbcAbcAbcYMMMMMMMMMMMM AbcAbcAbcAbcAbc Okay.
+trailing MMMMMMXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc Okay.
+after X MMMMMMXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc Okay.
+before space AbcAbcXAbcAbcAbcYAbcAbcAbcAbc MMMMMMMMMMMMMMM Okay.
+after b MMMMMMXMMMMMMMMMYMMMMMMMMMMMM MMMMMMMMMMMMAbc Okay.
+before b AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc Okay.
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-options "-dialect mf" }
+ *> { dg-output-file "group2/Fundamental_INSPECT_BACKWARD_TALLYING.out" }
+ program-id. prog.
+ data division.
+ working-storage section.
+ *> Note that 'item' has to have a length divisible by three for
+ *> the trailing "Abc" tests to work.
+ 01 item pic x(45).
+ 01 counter pic 999.
+ procedure division.
+ move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc" to item
+ display function trim(item)
+ move zero to counter
+ inspect backward item tallying counter for all "Abc"
+ display "All ""Abc"" " counter " (014)"
+ move zero to counter
+ inspect backward item tallying counter for leading "Abc"
+ display "Leading ""Abc"" " counter " (005)"
+ move zero to counter
+ inspect backward item tallying counter for all "Abc" after "Y" before "X"
+ display "X to Y ""Abc"" " counter " (003)"
+ move zero to counter
+ inspect backward item tallying counter for all "Abc" after space before "Y"
+ display "Y to ' ' ""Abc"" " counter " (004)"
+ move zero to counter
+ inspect backward item tallying counter for trailing "Abc"
+ display "Trailing ""Abc"" " counter " (002)"
+ move zero to counter
+ inspect backward item tallying counter for all "Abc" after "X"
+ display """Abc"" after ""x"" " counter " (002)"
+ move zero to counter
+ inspect backward item tallying counter for all "Abc" before space
+ display "before space " counter " (005)"
+ move zero to counter
+ inspect backward item tallying counter for all "Abc" after "b"
+ display """Abc"" after ""b"" " counter " (013)"
+ move zero to counter
+ inspect backward item tallying counter for all "Abc" before "b"
+ display "before ""b"" " counter " (000)"
+ goback.
+ end program prog.
+
--- /dev/null
+AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc
+All "Abc" 014 (014)
+Leading "Abc" 005 (005)
+X to Y "Abc" 003 (003)
+Y to ' ' "Abc" 004 (004)
+Trailing "Abc" 002 (002)
+"Abc" after "x" 002 (002)
+before space 005 (005)
+"Abc" after "b" 013 (013)
+before "b" 000 (000)
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-options "-dialect mf" }
+ *> { dg-output-file "group2/Fundamental_INSPECT_REPLACING.out" }
+ program-id. prog.
+ data division.
+ working-storage section.
+ *> Note that 'item' has to have a length divisible by three for
+ *> the trailing "Abc" tests to work.
+ 01 item pic x(45).
+ procedure division.
+ display "INSPECT REPLACING Abc by MMM"
+ move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc" to item
+ display function trim(item)
+
+ move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc" to item
+ inspect item replacing all "Abc" by "MMM"
+ display "all " item with no advancing
+ if item <> "MMMMMMXMMMMMMMMMYMMMMMMMMMMMM MMMMMMMMMMMMMMM"
+ display " Not right." else display " Okay." end-if
+
+ move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc" to item
+ inspect item replacing leading "Abc" by "MMM"
+ display "leading " item with no advancing
+ if item <> "MMMMMMXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc"
+ display " Not right." else display " Okay." end-if
+
+ move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc" to item
+ inspect item replacing all "Abc" by "MMM" after "X" before "Y"
+ display "X to Y " item with no advancing
+ if item <> "AbcAbcXMMMMMMMMMYAbcAbcAbcAbc AbcAbcAbcAbcAbc"
+ display " Not right." else display " Okay." end-if
+
+ move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc" to item
+ inspect item replacing all "Abc" by "MMM" after "Y" before space
+ display "Y to space " item with no advancing
+ if item <> "AbcAbcXAbcAbcAbcYMMMMMMMMMMMM AbcAbcAbcAbcAbc"
+ display " Not right." else display " Okay." end-if
+
+ move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc" to item
+ inspect item replacing trailing "Abc" by "MMM"
+ display "trailing " item with no advancing
+ if item <> "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc MMMMMMMMMMMMMMM "
+ display " Not right." else display " Okay." end-if
+
+ move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc" to item
+ inspect item replacing all "Abc" by "MMM" after "X"
+ display "after X " item with no advancing
+ if item <> "AbcAbcXMMMMMMMMMYMMMMMMMMMMMM MMMMMMMMMMMMMMM "
+ display " Not right." else display " Okay." end-if
+
+ move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc" to item
+ inspect item replacing all "Abc" by "MMM" before space
+ display "before space " item with no advancing
+ if item <> "MMMMMMXMMMMMMMMMYMMMMMMMMMMMM AbcAbcAbcAbcAbc"
+ display " Not right." else display " Okay." end-if
+
+ move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc" to item
+ inspect item replacing all "Abc" by "MMM" after "b"
+ display "after b " item with no advancing
+ if item <> "AbcMMMXMMMMMMMMMYMMMMMMMMMMMM MMMMMMMMMMMMMMM"
+ display " Not right." else display " Okay." end-if
+
+ move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc" to item
+ inspect item replacing all "Abc" by "MMM" before "b"
+ display "before b " item with no advancing
+ if item <> "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc"
+ display " Not right." else display " Okay." end-if
+
+ goback.
+
+ end program prog.
+
--- /dev/null
+INSPECT REPLACING Abc by MMM
+AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc
+all MMMMMMXMMMMMMMMMYMMMMMMMMMMMM MMMMMMMMMMMMMMM Okay.
+leading MMMMMMXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc Okay.
+X to Y AbcAbcXMMMMMMMMMYAbcAbcAbcAbc AbcAbcAbcAbcAbc Okay.
+Y to space AbcAbcXAbcAbcAbcYMMMMMMMMMMMM AbcAbcAbcAbcAbc Okay.
+trailing AbcAbcXAbcAbcAbcYAbcAbcAbcAbc MMMMMMMMMMMMMMM Okay.
+after X AbcAbcXMMMMMMMMMYMMMMMMMMMMMM MMMMMMMMMMMMMMM Okay.
+before space MMMMMMXMMMMMMMMMYMMMMMMMMMMMM AbcAbcAbcAbcAbc Okay.
+after b AbcMMMXMMMMMMMMMYMMMMMMMMMMMM MMMMMMMMMMMMMMM Okay.
+before b AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc Okay.
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-options "-dialect mf" }
+ *> { dg-output-file "group2/Fundamental_INSPECT_TALLYING.out" }
+ program-id. prog.
+ data division.
+ working-storage section.
+ *> Note that 'item' has to have a length divisible by three for
+ *> the trailing "Abc" tests to work.
+ 01 item pic x(45).
+ 01 counter pic 999.
+ procedure division.
+ move "AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc" to item
+ display function trim(item)
+ move zero to counter
+ inspect item tallying counter for all "Abc"
+ display "All ""Abc"" " counter " (014)"
+ move zero to counter
+ inspect item tallying counter for leading "Abc"
+ display "Leading ""Abc"" " counter " (002)"
+ move zero to counter
+ inspect item tallying counter for all "Abc" after "X" before "Y"
+ display "X to Y ""Abc"" " counter " (003)"
+ move zero to counter
+ inspect item tallying counter for all "Abc" after "Y" before space
+ display "Y to ' ' ""Abc"" " counter " (004)"
+ move zero to counter
+ inspect item tallying counter for trailing "Abc"
+ display "Trailing ""Abc"" " counter " (005)"
+ move zero to counter
+ inspect item tallying counter for all "Abc" after "X"
+ display """Abc"" after ""x"" " counter " (012)"
+ move zero to counter
+ inspect item tallying counter for all "Abc" before space
+ display "before space " counter " (009)"
+ move zero to counter
+ inspect item tallying counter for all "Abc" after "b"
+ display """Abc"" after ""b"" " counter " (013)"
+ move zero to counter
+ inspect item tallying counter for all "Abc" before "b"
+ display "before ""b"" " counter " (000)"
+ goback.
+ end program prog.
+
--- /dev/null
+AbcAbcXAbcAbcAbcYAbcAbcAbcAbc AbcAbcAbcAbcAbc
+All "Abc" 014 (014)
+Leading "Abc" 002 (002)
+X to Y "Abc" 003 (003)
+Y to ' ' "Abc" 004 (004)
+Trailing "Abc" 005 (005)
+"Abc" after "x" 012 (012)
+before space 009 (009)
+"Abc" after "b" 013 (013)
+before "b" 000 (000)
+
*> { dg-do run }
*> { dg-output-file "group2/Hexadecimal_literal.out" }
-
- >>DEFINE CHARSET AS 'ASCII'
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 A PIC X VALUE "0".
PROCEDURE DIVISION.
- >>IF CHARSET = 'EBCDIC'
- DISPLAY X"F1F2F3"
- >>ELSE
- DISPLAY X"313233"
- >>END-IF
- END-DISPLAY.
- STOP RUN.
+ *> Detect EBCDIC vs ASCII vs UTF
+ evaluate A
+ when X"F0" display X"F1F2F3"
+ when X"30" DISPLAY X"313233"
+ when X"3000" DISPLAY X"310032003300"
+ when other display "BaCK to the drawing board"
+ goback.
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/INITIALIZE_OCCURS_with_SIGN_LEADING___TRAILING.out" }
+ >>SOURCE FIXED
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 G1.
+ 02 FILLER OCCURS 2.
+ 03 X PIC S9 SIGN LEADING SEPARATE.
+ 02 FILLER OCCURS 2.
+ 03 Y PIC S9 SIGN TRAILING SEPARATE.
+ *> definition taken from NC1184.2
+ 01 MINUS-NAMES SIGN IS TRAILING SEPARATE CHARACTER.
+ 02 MINUS-NAMES-1.
+ 03 MINUS-NAME1 PIC S9(18) VALUE -999999999999999999.
+ 03 EVEN-NAME1 PIC S9(18) VALUE +1.
+ 03 PLUS-NAME1 PIC S9(18) VALUE +999999999999999999.
+ 02 MINUS-NAMES-2.
+ 03 MINUS-NAME3 PIC SV9(18) VALUE -.999999999999999999.
+ 03 EVEN-NAME2 PIC SV9(18) VALUE +.1.
+ 03 PLUS-NAME3 PIC SV9(18) VALUE +.999999999999999999.
+ PROCEDURE DIVISION.
+ INITIALIZE G1
+ MOVE 5 TO X(1), PLUS-NAME1
+ MOVE -9 TO Y(2), MINUS-NAME1
+ IF G1 NOT = "+5+00+9-"
+ DISPLAY 'MOVE G "' G1 '"'
+ END-DISPLAY
+ END-IF
+ ** The following line doesn't work causing test failure.
+ MOVE .123 TO PLUS-NAME3
+ IF MINUS-NAMES-1 NOT =
+ "000000000000000009-000000000000000001+000000000000000005+"
+ OR MINUS-NAMES-2 NOT =
+ "999999999999999999-100000000000000000+123000000000000000+"
+ DISPLAY 'MOVE MN1 "' MINUS-NAMES-1 '"'
+ END-DISPLAY
+ DISPLAY 'MOVE MN2 "' MINUS-NAMES-2 '"'
+ END-DISPLAY
+ END-IF
+ INITIALIZE G1, MINUS-NAMES
+ IF G1 NOT = "+0+00+0+"
+ DISPLAY 'INIT G1 "' G1 '"'
+ END-DISPLAY
+ END-IF
+ IF MINUS-NAMES-1 NOT =
+ "000000000000000000+000000000000000000+000000000000000000+"
+ OR MINUS-NAMES-2 NOT =
+ "000000000000000000+000000000000000000+000000000000000000+"
+ DISPLAY 'MOVE MN1 "' MINUS-NAMES-1 '"'
+ END-DISPLAY
+ DISPLAY 'MOVE MN2 "' MINUS-NAMES-2 '"'
+ END-DISPLAY
+ END-IF
+ MOVE .123 TO PLUS-NAME3
+ MOVE -.456 TO MINUS-NAME3
+ DISPLAY PLUS-NAME3 END-DISPLAY
+ DISPLAY MINUS-NAME3 END-DISPLAY
+ STOP RUN.
+
--- /dev/null
+.123000000000000000+
+.456000000000000000-
+
--- /dev/null
+ *> { dg-do run }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 G1.
+ 02 G2 OCCURS 5.
+ 03 X PIC Z9.
+ PROCEDURE DIVISION.
+ INITIALIZE G1
+ MOVE 5 TO X(1)
+ MOVE 99 TO X(3)
+ IF G1 NOT = " 5 099 0 0"
+ DISPLAY 'MOVE "' G1 '"'
+ END-DISPLAY
+ END-IF
+ INITIALIZE G1
+ IF G1 NOT = " 0 0 0 0 0"
+ DISPLAY 'INIT "' G1 '"'
+ END-DISPLAY
+ END-IF
+ STOP RUN.
+
--- /dev/null
+ *> { dg-do run }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 G1.
+ 02 X PIC X.
+ 02 G2 OCCURS 2.
+ 03 Y PIC 9.
+ 02 Z PIC 9.
+ PROCEDURE DIVISION.
+ INITIALIZE G1.
+ IF G1 NOT = " 000"
+ DISPLAY G1
+ END-DISPLAY
+ END-IF.
+ STOP RUN.
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/INITIALIZE_complex_group__2_.out" }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 G1.
+ 02 G2 OCCURS 2.
+ 03 X PIC 9.
+ 03 Y PIC X OCCURS 2.
+ 03 Z PIC X.
+ PROCEDURE DIVISION.
+ MOVE ALL 'Z' TO G1
+ DISPLAY """"G1""""
+ INITIALIZE G1
+ DISPLAY """"G1""""
+ IF G1 NOT = "0 0 "
+ DISPLAY "That should have been ""0 0 """
+ END-DISPLAY
+ END-IF
+ STOP RUN.
+
--- /dev/null
+"ZZZZZZZZ"
+"0 0 "
+
--- /dev/null
+ *> { dg-do run }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 G1.
+ 02 G2 OCCURS 2.
+ 03 X1 PIC X.
+ 03 X2 PIC 9.
+ PROCEDURE DIVISION.
+ MOVE SPACE TO G1.
+ INITIALIZE G2 (2).
+ IF G1 NOT = " 0"
+ *> DISPLAY G1 NO ADVANCING
+ *> also applied in tests below
+ *>
+ DISPLAY G1
+ END-DISPLAY
+ END-IF.
+ STOP RUN.
+
--- /dev/null
+ *> { dg-do run }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 EXT-VAR-01 PIC X(5) EXTERNAL.
+ 01 EXT-VAR-GRP EXTERNAL.
+ 02 EXT-FIELD1 PIC 999.
+ 02 EXT-FIELD2 PIC x(4).
+ 02 EXT-FIELD3 PIC 9(6).
+ 02 EXT-FIELD4 PIC s9(5)v99.
+ PROCEDURE DIVISION.
+ MOVE "MOVE" TO EXT-VAR-01.
+ MOVE 1 TO EXT-FIELD1.
+ MOVE "X" TO EXT-FIELD2.
+ MOVE 123 TO EXT-FIELD3.
+ MOVE -2.1 TO EXT-FIELD4.
+ INITIALIZE EXT-VAR-01.
+ INITIALIZE EXT-VAR-GRP.
+ IF EXT-VAR-01 NOT = SPACES
+ DISPLAY "EXT-VAR-01 " EXT-VAR-01
+ END-DISPLAY
+ END-IF.
+ IF EXT-FIELD1 NOT = ZERO
+ DISPLAY "EXT-FIELD1 " EXT-FIELD1
+ END-DISPLAY
+ END-IF.
+ IF EXT-FIELD2 NOT = SPACES
+ DISPLAY "EXT-FIELD2 " EXT-FIELD2
+ END-DISPLAY
+ END-IF.
+ IF EXT-FIELD3 NOT = ZERO
+ DISPLAY "EXT-FIELD3 " EXT-FIELD3
+ END-DISPLAY
+ END-IF.
+ IF EXT-FIELD4 NOT = ZERO
+ DISPLAY "EXT-FIELD4 " EXT-FIELD4
+ END-DISPLAY
+ END-IF.
+ STOP RUN.
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-options "-fdefaultbyte 64" }
+ *> { dg-output-file "group2/INITIALIZE_with_-defaultbyte__ASCII_.out" }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. proga.
+ PROCEDURE DIVISION.
+ call "prog"
+ call "prog"
+ goback.
+ end program proga.
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 MY-FLD PIC X(6) VALUE "ABCDEF".
+ 01 MY-OTHER-FLD PIC 9(4) VALUE ZERO.
+ 01 FILLER.
+ 02 PHONE-NUMBER.
+ 03 NAME PIC A(30).
+ 03 AREA-CODE PIC 999.
+ 03 DASH PIC X VALUE'-'.
+ 03 PREFIX PIC 999.
+ 03 DASH PIC X VALUE'-'.
+ 03 LOCAL PIC 999.
+ 77 WHO-AM-I PIC X(12).
+ PROCEDURE DIVISION.
+ ASTART SECTION.
+ A01.
+ DISPLAY MY-FLD.
+ DISPLAY MY-OTHER-FLD.
+ DISPLAY PHONE-NUMBER.
+ DISPLAY WHO-AM-I.
+ move quote to phone-number
+ display """" phone-number """"
+ goback.
+ end program prog.
+
--- /dev/null
+ABCDEF
+0000
+@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@-@@@-@@@
+@@@@@@@@@@@@
+"""""""""""""""""""""""""""""""""""""""""""
+ABCDEF
+0000
+@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@-@@@-@@@
+@@@@@@@@@@@@
+"""""""""""""""""""""""""""""""""""""""""""
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-options "-fdefaultbyte 124" }
+ *> { dg-output-file "group2/INITIALIZE_with_-defaultbyte__EBCDIC_.out" }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. proga.
+ PROCEDURE DIVISION.
+ call "prog"
+ call "prog"
+ goback.
+ end program proga.
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 MY-FLD PIC X(6) VALUE "ABCDEF".
+ 01 MY-OTHER-FLD PIC 9(4) VALUE ZERO.
+ 01 FILLER.
+ 02 PHONE-NUMBER.
+ 03 NAME PIC A(30).
+ 03 AREA-CODE PIC 999.
+ 03 DASH PIC X VALUE'-'.
+ 03 PREFIX PIC 999.
+ 03 DASH PIC X VALUE'-'.
+ 03 LOCAL PIC 999.
+ 77 WHO-AM-I PIC X(12).
+ PROCEDURE DIVISION.
+ ASTART SECTION.
+ A01.
+ DISPLAY MY-FLD.
+ DISPLAY MY-OTHER-FLD.
+ DISPLAY PHONE-NUMBER.
+ DISPLAY WHO-AM-I.
+ DISPLAY FUNCTION HEX-OF( AREA-CODE(1:1) ).
+ move quote to phone-number
+ display """" phone-number """"
+ goback.
+ end program prog.
+
--- /dev/null
+ABCDEF
+0000
+|||||||||||||||||||||||||||||||||-|||-|||
+||||||||||||
+7C
+"""""""""""""""""""""""""""""""""""""""""""
+ABCDEF
+0000
+|||||||||||||||||||||||||||||||||-|||-|||
+||||||||||||
+7C
+"""""""""""""""""""""""""""""""""""""""""""
+
--- /dev/null
+ *> { dg-do run }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 G1.
+ 02 X PIC 99.
+ 02 FILLER PIC X.
+ 02 Z PIC 99.
+ 01 MY-FILLER.
+ 02 FILLER PIC 9(6) VALUE 12345.
+ PROCEDURE DIVISION.
+ MOVE ALL 'A' TO G1.
+ INITIALIZE G1.
+ IF G1 NOT = "00A00"
+ DISPLAY "G1 (INIT): " G1
+ END-DISPLAY
+ END-IF.
+ MOVE ALL 'A' TO G1.
+ INITIALIZE G1 WITH FILLER.
+ IF G1 NOT = "00 00"
+ DISPLAY "G1 (INIT FILLER):" G1
+ END-DISPLAY
+ END-IF.
+
+ INITIALIZE MY-FILLER
+ IF MY-FILLER NOT = "012345"
+ DISPLAY "MY-FILLER (INIT): " MY-FILLER
+ END-DISPLAY
+ END-IF
+
+ INITIALIZE MY-FILLER WITH FILLER
+ IF MY-FILLER NOT = "000000"
+ DISPLAY "MY-FILLER (INIT FILLER): " MY-FILLER
+ END-DISPLAY
+ END-IF
+
+ INITIALIZE MY-FILLER ALL TO VALUE
+ IF MY-FILLER NOT = "000000"
+ DISPLAY "MY-FILLER (INIT TO VAL): " MY-FILLER
+ END-DISPLAY
+ END-IF
+
+ INITIALIZE MY-FILLER WITH FILLER ALL TO VALUE
+ IF MY-FILLER NOT = "012345"
+ DISPLAY "MY-FILLER (INIT FILLER TO VAL): " MY-FILLER
+ END-DISPLAY
+ END-IF
+
+ INITIALIZE MY-FILLER (2:3)
+ IF MY-FILLER NOT = "0 45"
+ DISPLAY "MY-FILLER (REF-MOD): " MY-FILLER
+ END-DISPLAY
+ END-IF
+
+ STOP RUN.
+
--- /dev/null
+ *> { dg-do run }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 G1.
+ 02 X PIC X.
+ 02 Y REDEFINES X PIC 9.
+ 02 Z PIC 9.
+ PROCEDURE DIVISION.
+ INITIALIZE G1.
+ IF G1 NOT = " 0"
+ DISPLAY G1
+ END-DISPLAY
+ END-IF.
+ STOP RUN.
+
--- /dev/null
+ *> { dg-do run }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 MY-FLD PIC X(6) VALUE "ABCDEF".
+ 01.
+ 02 MY-OTHER-FLD PIC 9(4) VALUE ZERO.
+ 02 AS-STRING REDEFINES MY-OTHER-FLD PIC X(4).
+ PROCEDURE DIVISION.
+ ASTART SECTION.
+ A01.
+ INITIALIZE MY-FLD (1:2).
+ IF MY-FLD NOT = " CDEF"
+ DISPLAY "MY-FLD: " MY-FLD
+ END-DISPLAY
+ END-IF
+ *> note: INITIALIZE with refmod => handle field as alphanumeric
+ INITIALIZE MY-OTHER-FLD (2:2)
+ MOVE "0 0" TO MY-FLD
+ IF AS-STRING NOT = MY-FLD (1:4)
+ DISPLAY "MY-OTHER-FLD: " MY-OTHER-FLD
+ END-DISPLAY
+ END-IF
+ STOP RUN.
+
working-storage section.
01 item pic x(12).
01 pitem redefines item pointer.
+
+ 01 l pic x(8) value low-value.
+ 01 lp redefines l pointer.
+ 01 s pic x(8) value space.
+ 01 sp redefines s pointer.
+ 01 z pic x(8) value zero.
+ 01 zp redefines z pointer.
+ 01 q pic x(8) value quote.
+ 01 qp redefines q pointer.
+ 01 h pic x(8) value high-value.
+ 01 hp redefines h pointer.
+
procedure division.
move all "abcd" to item
inspect item converting "abcd" to low-values
- display "low-values " space """" pitem """"
+ display "low-values " with no advancing
+ if pitem = lp display "okay" else display "no good" end-if
move all "abcd" to item
inspect item converting "abcd" to spaces
- display "spaces " space """" pitem """"
+ display "spaces " with no advancing
+ if pitem = sp display "okay" else display "no good" end-if
move all "abcd" to item
inspect item converting "abcd" to zeros
- display "zeros " space """" pitem """"
+ display "zeros " with no advancing
+ if pitem = zp display "okay" else display "no good" end-if
move all "abcd" to item
inspect item converting "abcd" to quotes
- display "quotes " space """" pitem """"
+ display "quotes " with no advancing
+ if pitem = qp display "okay" else display "no good" end-if
move all "abcd" to item
inspect item converting "abcd" to high-values
- display "high-values" space """" pitem """"
+ display "high-values " with no advancing
+ if pitem = hp display "okay" else display "no good" end-if
goback.
end program clouseau.
-low-values "0x0000000000000000"
-spaces "0x2020202020202020"
-zeros "0x3030303030303030"
-quotes "0x2222222222222222"
-high-values "0xffffffffffffffff"
+low-values okay
+spaces okay
+zeros okay
+quotes okay
+high-values okay
--- /dev/null
+ *> { dg-do run }
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ PROCEDURE DIVISION.
+ IF FUNCTION ABS(123.4) NOT EQUAL TO 123.4
+ MOVE 1 TO RETURN-CODE
+ DISPLAY "FUNCTION ABS(123.4) FAILS."
+ END-IF.
+ IF FUNCTION ABS(-123.4) NOT EQUAL TO 123.4
+ MOVE 1 TO RETURN-CODE
+ DISPLAY "FUNCTION ABS(-123.4) FAILS "
+ END-IF.
+ IF FUNCTION ABS(-000.0) NOT EQUAL TO ZERO
+ MOVE 1 TO RETURN-CODE
+ DISPLAY "FUNCTION ABS(-000.0) FAILS."
+ END-IF.
+ IF FUNCTION ABS(000.0) NOT EQUAL TO ZERO
+ MOVE 1 TO RETURN-CODE
+ DISPLAY "FUNCTION ABS(-000.0) FAILS."
+ END-IF.
+
--- /dev/null
+ *> { dg-do run }
+ *> TEST FUNCTION ACOS (Intrinsic)
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 77 trig-val-1 PIC S9v999999.
+ 77 trig-val-2 PIC -9.999999.
+ 77 report-area PIC x(80).
+ 77 failure-count PIC 99 VALUE ZERO.
+ 77 failure-report PIC Z9 VALUE ZERO.
+ PROCEDURE DIVISION.
+ main-procedure.
+ PERFORM run-tests.
+ PERFORM report-failure-count.
+ GOBACK.
+ EXIT PROGRAM.
+
+ run-tests.
+ MOVE FUNCTION ACOS(0.707107) TO trig-val-1.
+ MOVE trig-val-1 TO trig-val-2.
+ IF trig-val-2 NOT EQUAL " 0.785397"
+ STRING "FUNCTION ACOS(0.707107) FAILS. RETURNED "
+ trig-val-2 INTO report-area
+ END-STRING
+ PERFORM do-failure
+ END-IF.
+ MOVE FUNCTION ACOS(-0.707107) TO trig-val-1.
+ MOVE trig-val-1 TO trig-val-2.
+ IF trig-val-2 NOT EQUAL " 2.356194"
+ STRING 'FUNCTION ACOS(-0.0707107 FAILS. '
+ 'RETURNED ' trig-val-2 INTO report-area
+ END-STRING
+ PERFORM do-failure
+ END-IF.
+ MOVE FUNCTION ACOS(-1.000000) TO trig-val-1.
+ MOVE trig-val-1 TO trig-val-2.
+ IF trig-val-2 NOT EQUAL " 3.141592"
+ STRING 'FUNCTION ACOS(-1.0000000 FAILS. '
+ 'RETURNED ' trig-val-2 INTO report-area
+ END-STRING
+ PERFORM do-failure
+ END-IF.
+ MOVE FUNCTION ACOS(1.000000) TO trig-val-1.
+ MOVE trig-val-1 TO trig-val-2.
+ IF trig-val-2 NOT EQUAL " 0.000000"
+ STRING 'FUNCTION ACOS(1.0000000 FAILS. '
+ 'RETURNED ' trig-val-2 INTO report-area
+ END-STRING
+ PERFORM do-failure
+ END-IF.
+ *> ALLOWABLE RANGE for ACOS per ISO2014 (15.8.2):
+ *> The value of argument-1 shall be greater than or equal
+ *> to –1 and less than or equal to +1.
+ *> No comment about how the IMPLEMENTER SHOULD/MUST handle out
+ *> of range inputs.
+ *>
+ *> Because Exception Code processing is, by default, not turned on, the
+ *> return value for a bad parameter comes back as zero
+ MOVE FUNCTION ACOS(1.707107) TO trig-val-2.
+ IF trig-val-2 NOT EQUAL " 0.000000"
+ STRING 'FUNCTION ACOS(1.707107) FAILS. '
+ 'RETURNED ' trig-val-2 INTO report-area
+ PERFORM do-failure
+ END-IF.
+ MOVE FUNCTION ACOS(-1.707107) TO trig-val-2.
+ IF trig-val-2 NOT EQUAL " 0.000000"
+ STRING 'FUNCTION ACOS(-1.707107) FAILS. '
+ 'RETURNED ' trig-val-2 INTO report-area
+ PERFORM do-failure
+ END-IF.
+
+ do-failure.
+ MOVE 1 TO RETURN-CODE,
+ DISPLAY report-area,
+ MOVE SPACE to report-area.
+ ADD 1 TO failure-count.
+
+ report-failure-count.
+ IF failure-count IS GREATER THAN ZERO
+ THEN
+ MOVE failure-count TO failure-report
+ DISPLAY "Total failures: " failure-report
+ END-IF.
+
--- /dev/null
+ *> { dg-do run }
+ *> TEST FUNCTION ANNUITY (Intrinsic)
+ *> INADEQUATE sample of tests: TODO FIXME
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 77 trig-val-1 PIC S9v999999.
+ PROCEDURE DIVISION.
+ MOVE FUNCTION ANNUITY(0.07, 12) TO trig-val-1.
+ IF trig-val-1 NOT EQUAL +0.125901
+ MOVE 1 TO RETURN-CODE
+ DISPLAY 'FUNCTION ANNUITY(0.07, 12) FAILS.'
+ DISPLAY 'RETURNED ' trig-val-1 ', not 0.125901'
+ END-IF.
+
--- /dev/null
+ *> { dg-do run }
+ identification division.
+ program-id. prog.
+
+ data division.
+ working-storage section.
+
+ 01 datev pic 99999999.
+ 01 should_be pic 9999.
+ 01 result pic 9999.
+
+ procedure division.
+
+ move function test-date-yyyymmdd(19450601) to result
+ move zero to should_be
+ if result not equal to should_be then
+ display "test-date-yyyymmdd(19450601) should have been "
+ should_be " but was " result
+ move 1 to return-code
+ end-if.
+
+ move function test-date-yyyymmdd(100000000) to result
+ move 1 to should_be
+ if result not equal to should_be then
+ display "test-date-yyyymmdd(100000000) should have been "
+ should_be " but was " result
+ move 1 to return-code
+ end-if.
+
+ move 16010101 to datev
+ move zero to should_be
+ move function test-date-yyyymmdd(datev) to result
+ if result not equal to should_be then
+ display "test-date-yyyymmdd(" datev ") should have been "
+ should_be " but was " result
+ move 1 to return-code
+ end-if.
+
+ move 16010100 to datev
+ move 3 to should_be
+ move function test-date-yyyymmdd(datev) to result
+ if result not equal to should_be then
+ display "test-date-yyyymmdd(" datev ") should have been "
+ should_be " but was " result
+ move 1 to return-code
+ end-if.
+
+ move 99991231 to datev
+ move zero to should_be
+ move function test-date-yyyymmdd(datev) to result
+ if result not equal to should_be then
+ display "test-date-yyyymmdd(" datev ") should have been "
+ should_be " but was " result
+ move 1 to return-code
+ end-if.
+
+ move 99991232 to datev
+ move 3 to should_be
+ move function test-date-yyyymmdd(datev) to result
+ if result not equal to should_be then
+ display "test-date-yyyymmdd(" datev ") should have been "
+ should_be " but was " result
+ move 1 to return-code
+ end-if.
+
+ move 19450601 to datev
+ move zero to should_be
+ move function test-date-yyyymmdd(datev) to result
+ if result not equal to should_be then
+ display "test-date-yyyymmdd(" datev ") should have been "
+ should_be " but was " result
+ move 1 to return-code
+ end-if.
+
+ move 19450600 to datev
+ move 3 to should_be
+ move function test-date-yyyymmdd(datev) to result
+ if result not equal to should_be then
+ display "test-date-yyyymmdd(" datev ") should have been "
+ should_be " but was " result
+ move 1 to return-code
+ end-if.
+
+ move 19450631 to datev
+ move 3 to should_be
+ move function test-date-yyyymmdd(datev) to result
+ if result not equal to should_be then
+ display "test-date-yyyymmdd(" datev ") should have been "
+ should_be " but was " result
+ move 1 to return-code
+ end-if.
+
+ move 19450001 to datev
+ move 2 to should_be
+ move function test-date-yyyymmdd(datev) to result
+ if result not equal to should_be then
+ display "test-date-yyyymmdd(" datev ") should have been "
+ should_be " but was " result
+ move 1 to return-code
+ end-if.
+
+ move 19454701 to datev
+ move 2 to should_be
+ move function test-date-yyyymmdd(datev) to result
+ if result not equal to should_be then
+ display "test-date-yyyymmdd(" datev ") should have been "
+ should_be " but was " result
+ move 1 to return-code
+ end-if.
+
+ move 19880229 to datev
+ move 0 to should_be
+ move function test-date-yyyymmdd(datev) to result
+ if result not equal to should_be then
+ display "test-date-yyyymmdd(" datev ") should have been "
+ should_be " but was " result
+ move 1 to return-code
+ end-if.
+
+ move 19890229 to datev
+ move 3 to should_be
+ move function test-date-yyyymmdd(datev) to result
+ if result not equal to should_be then
+ display "test-date-yyyymmdd(" datev ") should have been "
+ should_be " but was " result
+ move 1 to return-code
+ end-if.
+
+ end program prog.
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/Intrinsic_Function_NUMVAL.out" }
+ IDENTIFICATiON DIVISION.
+ PROGRAM-ID. prog.
+ PROCEDURE DIVISION.
+ DISPLAY FUNCTION NUMVAL(" 123.4 ").
+ IF FUNCTION NUMVAL(" 123.4 ") NOT EQUAL 123.4
+ DISPLAY 'NUMVAL(" 123.4 ") FAILS'
+ MOVE 1 TO RETURN-CODE
+ END-IF.
+ IF FUNCTION NUMVAL(" + 123.4 ") NOT EQUAL 123.4
+ DISPLAY 'NUMVAL(" + 123.4 ") FAILS'
+ MOVE 1 TO RETURN-CODE
+ END-IF.
+ IF FUNCTION NUMVAL("+123.4") NOT EQUAL 123.4
+ DISPLAY 'NUMVAL("+123.4") FAILS'
+ MOVE 1 TO RETURN-CODE
+ END-IF.
+ IF FUNCTION NUMVAL(" 123.4 + ") NOT EQUAL 123.4
+ DISPLAY 'NUMVAL(" 123.4 + ") FAILS'
+ MOVE 1 TO RETURN-CODE
+ END-IF.
+ IF FUNCTION NUMVAL(" - 123.4 ") NOT EQUAL -123.4
+ DISPLAY 'NUMVAL(" - 123.4 ") FAILS'
+ MOVE 1 TO RETURN-CODE
+ END-IF.
+ IF FUNCTION NUMVAL(" - 123.4 ") NOT EQUAL -123.4
+ DISPLAY 'NUMVAL(" - 123.4 ") FAILS'
+ MOVE 1 TO RETURN-CODE
+ END-IF.
+ IF FUNCTION NUMVAL(" 123.4 - ") NOT EQUAL -123.4
+ DISPLAY 'NUMVAL(" 123.4 - ") FAILS'
+ MOVE 1 TO RETURN-CODE
+ END-IF.
+ IF FUNCTION NUMVAL(" 123.4 CR ") NOT EQUAL -123.4
+ DISPLAY 'NUMVAL(" 123.4 CR ") FAILS'
+ MOVE 1 TO RETURN-CODE
+ END-IF.
+ IF FUNCTION NUMVAL("123.4cR") NOT EQUAL -123.4
+ DISPLAY 'NUMVAL("123.4cR") FAILS'
+ MOVE 1 TO RETURN-CODE
+ END-IF.
+ IF FUNCTION NUMVAL(" 123.4 Cr ") NOT EQUAL -123.4
+ DISPLAY 'NUMVAL(" 123.4 Cr ") FAILS'
+ MOVE 1 TO RETURN-CODE
+ END-IF.
+ IF FUNCTION NUMVAL(" 123.4 cr ") NOT EQUAL -123.4
+ DISPLAY 'NUMVAL(" 123.4 cr ") FAILS'
+ MOVE 1 TO RETURN-CODE
+ END-IF.
+ IF FUNCTION NUMVAL(" 123.4 DB ") NOT EQUAL -123.4
+ DISPLAY 'NUMVAL(" 123.4 DB") FAILS'
+ MOVE 1 TO RETURN-CODE
+ END-IF.
+ IF FUNCTION NUMVAL(" 123.4 dB ") NOT EQUAL -123.4
+ DISPLAY 'NUMVAL(" 123.4 dB") FAILS'
+ MOVE 1 TO RETURN-CODE
+ END-IF.
+ IF FUNCTION NUMVAL(" 123.4 Db ") NOT EQUAL -123.4
+ DISPLAY 'NUMVAL(" 123.4 Db") FAILS'
+ MOVE 1 TO RETURN-CODE
+ END-IF.
+ IF FUNCTION NUMVAL(" 123.4 db ") NOT EQUAL -123.4
+ DISPLAY 'NUMVAL(" 123.4 db") FAILS'
+ MOVE 1 TO RETURN-CODE
+ END-IF.
+ *> ISO2014 inputs to NUMVAL() "SHALL BE" and goes on to define
+ *> a grammar of allowable strings. It is silent on correct
+ *> behavior when the string presened does not conform to the
+ *> grammer.
+ *>
+ *> As IMPLEMENTER we get to decide how to handle non-coforming
+ *> input values. These tests use a return value of ZERO as a
+ *> WORKING ASSUMPTION (TODISCUSS)
+ IF FUNCTION NUMVAL(" ") NOT EQUAL ZERO
+ DISPLAY 'NUMVAL(" ") FAILS'
+ DISPLAY 'NUMVAL(" ") FAILS WITH '
+ FUNCTION NUMVAL(" ")
+ MOVE 1 TO RETURN-CODE
+ END-IF.
+ IF FUNCTION NUMVAL(" F ") NOT EQUAL ZERO
+ DISPLAY 'NUMVAL(" F ") FAILS WITH '
+ FUNCTION NUMVAL(" F ")
+ MOVE 1 TO RETURN-CODE
+ END-IF.
+
--- /dev/null
+123.4000000000000000000000000000000049
+
77 should-be pic zzzz9.
77 but-is pic zzzz9.
+ 01 stride binary-short.
procedure division.
+ move function byte-length("A") to stride
display "using LENGTH OF"
move "Length of desc1" to msg
move 50 to should-be
- move length of desc1 to but-is
+ compute but-is = length of desc1 / stride
perform result-is
move "Length of desc1-entry" to msg
move 5 to should-be
- move length of desc1-entry to but-is
+ compute but-is = length of desc1-entry / stride
perform result-is
move "Length of desc1-entry(1)" to msg
move 5 to should-be
- move length of desc1-entry(1) to but-is
+ compute but-is = length of desc1-entry(1) / stride
perform result-is
move "Length of desc2" to msg
move 50 to should-be
- move length of desc2 to but-is
+ compute but-is = length of desc2 / stride
perform result-is
move "Length of desc2-table" to msg
move 5 to should-be
- move length of desc2-table to but-is
+ compute but-is = length of desc2-table / stride
perform result-is
move "Length of desc2-entry" to msg
move 5 to should-be
- move length of desc2-entry to but-is
+ compute but-is = length of desc2-entry / stride
perform result-is
move "Length of desc2-entry(1)" to msg
move 5 to should-be
- move length of desc2-entry(1) to but-is
+ compute but-is = length of desc2-entry(1) / stride
perform result-is
move 5 to desc3-lim
move "Length of desc3" to msg
move 750 to should-be
- move length of desc3 to but-is
+ compute but-is = length of desc3 / stride
perform result-is
move "Length of desc3-outer" to msg
move 150 to should-be
- move length of desc3-outer to but-is
+ compute but-is = length of desc3-outer / stride
perform result-is
move "Length of desc3-outer(1)" to msg
move 150 to should-be
- move length of desc3-outer(1) to but-is
+ compute but-is = length of desc3-outer(1) / stride
perform result-is
move "Length of desc3-outer-txt" to msg
move 7 to should-be
- move length of desc3-outer-txt to but-is
+ compute but-is = length of desc3-outer-txt / stride
perform result-is
move "Length of desc3-inner" to msg
move 13 to should-be
- move length of desc3-inner to but-is
+ compute but-is = length of desc3-inner / stride
perform result-is
move "Length of desc3-inner(1)" to msg
move 13 to should-be
- move length of desc3-inner(1) to but-is
+ compute but-is = length of desc3-inner(1) / stride
perform result-is
goback.
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/Long_Division.out" }
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 01 a pic 9(37) display.
+ 01 b pic 9(37) display.
+ 01 c pic 9(37) display.
+ procedure division.
+ move 1000000000000000000000000000000000000 to b
+ move 200000000000000000000000000000000000 to c
+ divide b by c giving a
+ display a.
+ end program prog.
+
--- /dev/null
+0000000000000000000000000000000000005
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/MOVE_X_000203_.out" }
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 01 x pic xxx.
+ 01 stride binary-long.
+ 01 hexed pic x(24).
+ procedure division.
+ move function byte-length('a') to stride.
+ evaluate stride
+ when 1 move x"000203" to x
+ when 2 move x"000203040506" to x
+ when 4 move x"0002030405060708090a0b0c" to x
+ end-evaluate
+ move function hex-of(x) to hexed
+ evaluate stride
+ when 1 if hexed = "000203"
+ display "Okay" else display "1 BAD" end-if
+ when 2 if hexed = "000203040506"
+ display "Okay" else display "2 BAD" end-if
+ when 4 if hexed = "0002030405060708090a0b0c"
+ display "Okay" else display "4 BAD" end-if
+ end-evaluate
+ goback.
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/MOVE_to_JUSTIFIED_items.out" }
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 SRC-1 PIC S9(04) VALUE 11.
+ 01 SRC-2 PIC S9(04) COMP VALUE 22.
+ 01 SRC-3 PIC S9(04) COMP-5 VALUE 33.
+ 01 SRC-4 PIC S9(04)PP VALUE 4400.
+ 01 SRC-5 PIC S9(04)PPPPP VALUE 55500000.
+ 01 EDT-FLD PIC X(07) JUSTIFIED RIGHT.
+ 01 DateNowInt PIC 9(8) value 19530227 .
+ 01 aspicx pic X(9).
+ 01 aspicxr pic X(9) JUSTIFIED RIGHT.
+ PROCEDURE DIVISION.
+ MOVE SRC-1 TO EDT-FLD.
+ DISPLAY '>' EDT-FLD '<'
+ END-DISPLAY.
+ MOVE SRC-2 TO EDT-FLD.
+ DISPLAY '>' EDT-FLD '<'
+ END-DISPLAY.
+ MOVE SRC-3 TO EDT-FLD.
+ DISPLAY '>' EDT-FLD '<'
+ END-DISPLAY.
+ MOVE SRC-4 TO EDT-FLD.
+ DISPLAY '>' EDT-FLD '<'
+ END-DISPLAY.
+ MOVE SRC-5 TO EDT-FLD.
+ DISPLAY '>' EDT-FLD '<'
+ END-DISPLAY.
+ MOVE FUNCTION INTEGER-OF-DATE(DateNowInt) to aspicx
+ MOVE FUNCTION INTEGER-OF-DATE(DateNowInt) to aspicxr
+ display """"aspicx""""
+ display """"aspicxr""""
+ STOP RUN.
+
--- /dev/null
+> 0011<
+> 0022<
+> 0033<
+> 004400<
+>5500000<
+"128623 "
+" 128623"
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/N-Queens_algorithm.out" }
+ identification division.
+ program-id. xdamcnt.
+ data division.
+ working-storage section.
+ 77 i pic 9(8) comp-5.
+ 77 j pic 9(8) comp-5.
+ 77 k pic 9(8) comp-5.
+ 77 n pic 9(8) comp-5.
+ 77 n2 pic 9(8) comp-5.
+ 77 l pic s9(8) comp-5.
+ 77 z pic 9(8) comp-5.
+ 77 configokret pic 9(8) comp-5.
+ 01 a_vector.
+ 10 a pic 9(8) comp-5 occurs 100 value 0.
+ 77 istart pic 9(8) comp-5 value 1.
+ 77 iend pic 9(8) comp-5 value 0.
+ 77 cnt pic 9(8) comp-5 value 0.
+ 77 slen pic 9(8) comp-5 value 0.
+ 77 argc pic 9(8) comp-5 value 0.
+ 77 argv pic x(100) value spaces.
+
+ procedure division.
+ pmain section.
+ display "N-queens problem in COBOL".
+ display ' 2 4 6 8 10 12 14'.
+ display '1 0 0 2 10 4 40 92 352 724 2680 14200 73712 365596'.
+
+ move 11 to iend
+ move 1 to istart
+
+ display "istart=", istart, " iend=", iend.
+
+ perform varying i from istart by 1 until i > iend
+ perform nqsolve
+ display "d(", i, ") = ", cnt
+ end-perform.
+
+ goback.
+
+ *> Calculate number of positions for n queens.
+ nqsolve section.
+ move zero to cnt.
+ move 1 to k.
+ move 1 to a(1).
+ move i to n.
+ move i to n2.
+
+ lloop.
+ perform configok.
+ if configokret = 1 then
+ if k < n then
+ add 1 to k
+ move 1 to a(k)
+ go to lloop
+ else
+ add 1 to cnt
+ end-if
+ end-if.
+
+ perform with test after varying k from k by -1 until k <= 1
+ if a(k) < n then
+ add 1 to a(k)
+ go to lloop
+ end-if
+ end-perform.
+
+ add 1 to a(1).
+ if a(1) > n2 then
+ exit section
+ end-if.
+ move 2 to k.
+ move 1 to a(2).
+ go to lloop.
+
+ *> check if k-th queen is attacked by any other prior queen.
+ *> return nonzero if configuration is ok, zero otherwise.
+ configok section.
+ move zero to configokret.
+ move a(k) to z.
+
+ perform varying j from 1 by 1 until j >= k
+ compute l = z - a(j)
+ if l = 0 then
+ exit section
+ end-if
+ if l < 0 then
+ compute l = 0 - l
+ end-if
+ if l = k - j then
+ exit section
+ end-if
+ end-perform.
+
+ move 1 to configokret.
+
+ dummy section.
+ display space.
+
+ end program xdamcnt.
+
--- /dev/null
+N-queens problem in COBOL
+ 2 4 6 8 10 12 14
+1 0 0 2 10 4 40 92 352 724 2680 14200 73712 365596
+istart=00000001 iend=00000011
+d(00000001) = 00000001
+d(00000002) = 00000000
+d(00000003) = 00000000
+d(00000004) = 00000002
+d(00000005) = 00000010
+d(00000006) = 00000004
+d(00000007) = 00000040
+d(00000008) = 00000092
+d(00000009) = 00000352
+d(00000010) = 00000724
+d(00000011) = 00002680
+
03 X-NUM PIC 9(06) PACKED-DECIMAL VALUE 123.
77 NUM PIC 9(06).
PROCEDURE DIVISION.
- MOVE x"0A" TO X (2:1)
+ *> "O" is non-numeric BCD in ascii or ebcdic
+ MOVE "O" TO X (2:1)
IF X-NUM NUMERIC
DISPLAY "bad prog"
END-DISPLAY
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/Numeric_operations__6_.out" }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+
+ 01 P-FIELD1 PIC 99PPP.
+ 01 p1 redefines p-field1 pic x(2).
+ 01 P-FIELD2 PIC PPP99.
+ 01 p2 redefines p-field2 pic x(2).
+
+ PROCEDURE DIVISION.
+
+ MOVE 5000 TO P-FIELD1.
+ ADD 5 TO P-FIELD1 END-ADD
+ IF P-FIELD1 NOT = 5000
+ DISPLAY "Error: Add 5 to PIC 99PPP."
+ END-DISPLAY
+ END-IF
+ display p1
+
+ ADD 5000 TO P-FIELD1 END-ADD
+ IF P-FIELD1 NOT = 10000
+ DISPLAY "Error: Add 5000 to PIC 99PPP."
+ END-DISPLAY
+ END-IF
+ display p1
+
+ MOVE 0.00055 TO P-FIELD2.
+ ADD 0.00033 TO P-FIELD2 END-ADD
+ IF P-FIELD2 NOT = 0.00088
+ DISPLAY "Error: Add 0.00033 to PIC PPP99."
+ END-DISPLAY
+ END-IF
+ display p2
+
+ MOVE 0.00055 TO P-FIELD2.
+ ADD 0.00300 TO P-FIELD2 END-ADD
+ IF P-FIELD2 NOT = 0.00055
+ DISPLAY "Error: Add 0.00300 to PIC PPP99."
+ END-DISPLAY
+ END-IF
+ display p2
+
+ STOP RUN.
+
--- /dev/null
+05
+10
+88
+55
+
*> { dg-do run }
+ *> { dg-options "-dialect ibm" }
*> { dg-output-file "group2/PACKED-DECIMAL_dump.out" }
IDENTIFICATION DIVISION.
01 G-1.
02 X-1 PIC 9(1) VALUE 1
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ *> Eight bytes of 0x2020202020202020
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
+ *> One additional 0x20 byte.
+ 02 FILLER BINARY-CHAR VALUE 32.
01 G-2.
02 X-2 PIC 9(2) VALUE 12
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-3.
02 X-3 PIC 9(3) VALUE 123
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-4.
02 X-4 PIC 9(4) VALUE 1234
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-5.
02 X-5 PIC 9(5) VALUE 12345
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-6.
02 X-6 PIC 9(6) VALUE 123456
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-7.
02 X-7 PIC 9(7) VALUE 1234567
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-8.
02 X-8 PIC 9(8) VALUE 12345678
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-9.
02 X-9 PIC 9(9) VALUE 123456789
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-10.
02 X-10 PIC 9(10) VALUE 1234567890
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-11.
02 X-11 PIC 9(11) VALUE 12345678901
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-12.
02 X-12 PIC 9(12) VALUE 123456789012
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-13.
02 X-13 PIC 9(13) VALUE 1234567890123
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-14.
02 X-14 PIC 9(14) VALUE 12345678901234
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-15.
02 X-15 PIC 9(15) VALUE 123456789012345
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-16.
02 X-16 PIC 9(16) VALUE 1234567890123456
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-17.
02 X-17 PIC 9(17) VALUE 12345678901234567
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-18.
02 X-18 PIC 9(18) VALUE 123456789012345678
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-S1.
02 X-S1 PIC S9(1) VALUE -1
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
+ 02 FILLER BINARY-CHAR VALUE 32.
01 G-S2.
02 X-S2 PIC S9(2) VALUE -12
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-S3.
02 X-S3 PIC S9(3) VALUE -123
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-S4.
02 X-S4 PIC S9(4) VALUE -1234
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-S5.
02 X-S5 PIC S9(5) VALUE -12345
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-S6.
02 X-S6 PIC S9(6) VALUE -123456
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-S7.
02 X-S7 PIC S9(7) VALUE -1234567
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-S8.
02 X-S8 PIC S9(8) VALUE -12345678
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-S9.
02 X-S9 PIC S9(9) VALUE -123456789
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-S10.
02 X-S10 PIC S9(10) VALUE -1234567890
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-S11.
02 X-S11 PIC S9(11) VALUE -12345678901
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-S12.
02 X-S12 PIC S9(12) VALUE -123456789012
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-S13.
02 X-S13 PIC S9(13) VALUE -1234567890123
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-S14.
02 X-S14 PIC S9(14) VALUE -12345678901234
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-S15.
02 X-S15 PIC S9(15) VALUE -123456789012345
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-S16.
02 X-S16 PIC S9(16) VALUE -1234567890123456
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-S17.
02 X-S17 PIC S9(17) VALUE -12345678901234567
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
01 G-S18.
02 X-S18 PIC S9(18) VALUE -123456789012345678
COMP-3.
- 02 FILLER PIC X(18) VALUE SPACE.
+ 02 FILLER BINARY-DOUBLE VALUE 2314885530818453536.
PROCEDURE DIVISION.
*> Dump all values
CALL "dump" USING G-1
PROGRAM-ID. dump.
DATA DIVISION.
WORKING-STORAGE SECTION.
- 01 HEXCHARS.
- 02 HEXCHART PIC X(16) VALUE "0123456789abcdef".
- 02 HEXCHAR REDEFINES HEXCHART PIC X OCCURS 16.
- 01 BYTE-TO-DUMP PIC X(1).
- 01 FILLER.
- 02 DUMPER1 PIC 9999 COMP-5.
- 02 DUMPER2 REDEFINES DUMPER1 PIC X(1).
- 01 THE-BYTE PIC 99.
- 01 LADVANCE PIC 9.
+ 01 in-hex pic x(20).
LINKAGE SECTION.
- 01 G-VAL PIC X(20).
- 01 G-PTR REDEFINES G-VAL USAGE POINTER.
+ 01 G-VAL PIC X(24).
PROCEDURE DIVISION USING G-VAL.
- MOVE 1 TO THE-BYTE
- MOVE 0 TO LADVANCE
- PERFORM UNTIL THE-BYTE GREATER THAN 10
- MOVE G-VAL(THE-BYTE:1) TO BYTE-TO-DUMP
- IF THE-BYTE EQUAL TO 10 MOVE 1 TO LADVANCE END-IF
- PERFORM DUMP-BYTE
- ADD 1 TO THE-BYTE
- END-PERFORM.
- GOBACK.
- DUMP-BYTE.
- MOVE ZERO TO DUMPER1
- MOVE BYTE-TO-DUMP TO DUMPER2
- DIVIDE DUMPER1 BY 16 GIVING DUMPER1
- ADD 1 TO DUMPER1
- DISPLAY HEXCHAR(DUMPER1) NO ADVANCING.
- MOVE ZERO TO DUMPER1
- MOVE BYTE-TO-DUMP TO DUMPER2
- MOVE FUNCTION MOD(DUMPER1 16) TO DUMPER1
- ADD 1 TO DUMPER1
- IF LADVANCE EQUAL TO 1 THEN
- DISPLAY HEXCHAR(DUMPER1)
- ELSE
- DISPLAY HEXCHAR(DUMPER1) NO ADVANCING
- END-IF.
+ move function hex-of(g-val) to in-hex
+ display in-hex
+ goback.
END PROGRAM dump.
-1f202020202020202020
-012f2020202020202020
-123f2020202020202020
-01234f20202020202020
-12345f20202020202020
-0123456f202020202020
-1234567f202020202020
-012345678f2020202020
-123456789f2020202020
-01234567890f20202020
-12345678901f20202020
-0123456789012f202020
-1234567890123f202020
-012345678901234f2020
-123456789012345f2020
-01234567890123456f20
-12345678901234567f20
-0123456789012345678f
-1d202020202020202020
-012d2020202020202020
-123d2020202020202020
-01234d20202020202020
-12345d20202020202020
-0123456d202020202020
-1234567d202020202020
-012345678d2020202020
-123456789d2020202020
-01234567890d20202020
-12345678901d20202020
-0123456789012d202020
-1234567890123d202020
-012345678901234d2020
-123456789012345d2020
-01234567890123456d20
-12345678901234567d20
-0123456789012345678d
-0f202020202020202020
-000f2020202020202020
-000f2020202020202020
-00000f20202020202020
-00000f20202020202020
-0000000f202020202020
-0000000f202020202020
-000000000f2020202020
-000000000f2020202020
-00000000000f20202020
-00000000000f20202020
-0000000000000f202020
-0000000000000f202020
-000000000000000f2020
-000000000000000f2020
-00000000000000000f20
-00000000000000000f20
-0000000000000000000f
-0c202020202020202020
-000c2020202020202020
-000c2020202020202020
-00000c20202020202020
-00000c20202020202020
-0000000c202020202020
-0000000c202020202020
-000000000c2020202020
-000000000c2020202020
-00000000000c20202020
-00000000000c20202020
-0000000000000c202020
-0000000000000c202020
-000000000000000c2020
-000000000000000c2020
-00000000000000000c20
-00000000000000000c20
-0000000000000000000c
-0f202020202020202020
-000f2020202020202020
-000f2020202020202020
-00000f20202020202020
-00000f20202020202020
-0000000f202020202020
-0000000f202020202020
-000000000f2020202020
-000000000f2020202020
-00000000000f20202020
-00000000000f20202020
-0000000000000f202020
-0000000000000f202020
-000000000000000f2020
-000000000000000f2020
-00000000000000000f20
-00000000000000000f20
-0000000000000000000f
-0c202020202020202020
-000c2020202020202020
-000c2020202020202020
-00000c20202020202020
-00000c20202020202020
-0000000c202020202020
-0000000c202020202020
-000000000c2020202020
-000000000c2020202020
-00000000000c20202020
-00000000000c20202020
-0000000000000c202020
-0000000000000c202020
-000000000000000c2020
-000000000000000c2020
-00000000000000000c20
-00000000000000000c20
-0000000000000000000c
+1F202020202020202020
+012F2020202020202020
+123F2020202020202020
+01234F20202020202020
+12345F20202020202020
+0123456F202020202020
+1234567F202020202020
+012345678F2020202020
+123456789F2020202020
+01234567890F20202020
+12345678901F20202020
+0123456789012F202020
+1234567890123F202020
+012345678901234F2020
+123456789012345F2020
+01234567890123456F20
+12345678901234567F20
+0123456789012345678F
+1D202020202020202020
+012D2020202020202020
+123D2020202020202020
+01234D20202020202020
+12345D20202020202020
+0123456D202020202020
+1234567D202020202020
+012345678D2020202020
+123456789D2020202020
+01234567890D20202020
+12345678901D20202020
+0123456789012D202020
+1234567890123D202020
+012345678901234D2020
+123456789012345D2020
+01234567890123456D20
+12345678901234567D20
+0123456789012345678D
+0F202020202020202020
+000F2020202020202020
+000F2020202020202020
+00000F20202020202020
+00000F20202020202020
+0000000F202020202020
+0000000F202020202020
+000000000F2020202020
+000000000F2020202020
+00000000000F20202020
+00000000000F20202020
+0000000000000F202020
+0000000000000F202020
+000000000000000F2020
+000000000000000F2020
+00000000000000000F20
+00000000000000000F20
+0000000000000000000F
+0C202020202020202020
+000C2020202020202020
+000C2020202020202020
+00000C20202020202020
+00000C20202020202020
+0000000C202020202020
+0000000C202020202020
+000000000C2020202020
+000000000C2020202020
+00000000000C20202020
+00000000000C20202020
+0000000000000C202020
+0000000000000C202020
+000000000000000C2020
+000000000000000C2020
+00000000000000000C20
+00000000000000000C20
+0000000000000000000C
+0F202020202020202020
+000F2020202020202020
+000F2020202020202020
+00000F20202020202020
+00000F20202020202020
+0000000F202020202020
+0000000F202020202020
+000000000F2020202020
+000000000F2020202020
+00000000000F20202020
+00000000000F20202020
+0000000000000F202020
+0000000000000F202020
+000000000000000F2020
+000000000000000F2020
+00000000000000000F20
+00000000000000000F20
+0000000000000000000F
+0C202020202020202020
+000C2020202020202020
+000C2020202020202020
+00000C20202020202020
+00000C20202020202020
+0000000C202020202020
+0000000C202020202020
+000000000C2020202020
+000000000C2020202020
+00000000000C20202020
+00000000000C20202020
+0000000000000C202020
+0000000000000C202020
+000000000000000C2020
+000000000000000C2020
+00000000000000000C20
+00000000000000000C20
+0000000000000000000C
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/Preserve_collation_past_a_CALL.out" }
+ identification division.
+ program-id. asciibet.
+ environment division.
+ configuration section.
+ special-names.
+ alphabet like-ascii is standard-1.
+ object-computer.
+ linux-system program collating sequence is like-ascii.
+ data division.
+ working-storage section.
+ 01.
+ 02 signature pic x(8) value "76543210".
+ procedure division.
+ display "Should collate like ASCII"
+ if 'A' < 'a'
+ display "Collates like ASCII"
+ else
+ display "Collates like EBCDIC"
+ end-if
+ call "ebcdicbet"
+ display "Should collate like ASCII"
+ if 'A' < 'a'
+ display "Collates like ASCII"
+ else
+ display "Collates like EBCDIC"
+ end-if
+ goback.
+ end program asciibet.
+
+ identification division.
+ program-id. ebcdicbet.
+ environment division.
+ configuration section.
+ special-names.
+ alphabet like-ebcdic is EBCDIC.
+ object-computer.
+ linux-system program collating sequence is like-ebcdic.
+ data division.
+ working-storage section.
+ 01.
+ 02 signature pic x(8) value "76543210".
+ procedure division.
+ display "Should collate like EBCDIC"
+ if 'A' < 'a'
+ display "Collates like ASCII"
+ else
+ display "Collates like EBCDIC"
+ end-if
+ goback.
+ end program ebcdicbet.
+
--- /dev/null
+Should collate like ASCII
+Collates like ASCII
+Should collate like EBCDIC
+Collates like EBCDIC
+Should collate like ASCII
+Collates like ASCII
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-xfail-run-if "" { *-*-* } }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 I PIC 99 COMP.
+ PROCEDURE DIVISION.
+ INITIALIZE RETURN-CODE.
+ MOVE ZERO TO RETURN-CODE.
+ MOVE 1 TO RETURN-CODE.
+ MOVE RETURN-CODE TO I.
+ IF I NOT = 1
+ DISPLAY I NO ADVANCING
+ END-DISPLAY
+ END-IF.
+ STOP RUN.
+
--- /dev/null
+ *> { dg-do run }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ PROCEDURE DIVISION.
+ MOVE 1 TO RETURN-CODE.
+ IF RETURN-CODE NOT = 1
+ DISPLAY RETURN-CODE NO ADVANCING
+ END-DISPLAY
+ END-IF.
+ CALL "mod1"
+ END-CALL.
+ IF RETURN-CODE NOT = 2
+ DISPLAY RETURN-CODE NO ADVANCING
+ END-DISPLAY
+ END-IF.
+ MOVE ZERO TO RETURN-CODE.
+ STOP RUN.
+ PROGRAM-ID. mod1.
+ PROCEDURE DIVISION.
+ IF RETURN-CODE NOT = 1
+ DISPLAY RETURN-CODE NO ADVANCING
+ END-DISPLAY
+ END-IF.
+ MOVE 2 TO RETURN-CODE.
+ EXIT PROGRAM.
+ END PROGRAM mod1.
+ END PROGRAM prog.
+
*> { dg-do run }
*> { dg-output-file "group2/Refmod__comparisons_inside_numeric-display.out" }
identification division.
+ * """"" (quotes reset the syntax highlighting
program-id. prog.
data division.
working-storage section.
*> { dg-do run }
*> { dg-output-file "group2/Refmod_sources_are_figurative_constants.out" }
-
id division.
program-id. prog.
data division.
working-storage section.
- 01 varx pic x(8) VALUE '""""""""'.
- 01 varp redefines varx pointer.
+ 01 varx pic x(8) value '""""""""'.
+ 01 hexed pic x(32).
procedure division.
move "12345678" to varx
display """" varx """"
move "999" to varx(4:3)
display """" varx """"
- move LOW-VALUE to varx(4:3).
- display """" varx """"
- move ZERO to varx(4:3).
- display """" varx """"
- move SPACE to varx(4:3).
+ move zero to varx(4:3)
display """" varx """"
- move QUOTE to varx(4:3).
+ move space to varx(4:3)
display """" varx """"
- move HIGH-VALUE to varx(4:3).
- display varp
- initialize varx all to value
+ move quote to varx(4:3)
display """" varx """"
- .
+ move high-value to varx
+ move low-value to varx(4:3)
+ move function hex-of(varx) to hexed
+ display "low-value " with no advancing
+ evaluate function byte-length("a")
+ when 1 if hexed = "FFFFFF000000FFFF" display "Okay"
+ else display "no good" end-if
+ when 2 if hexed = "FF00FF00FF00000000000000FF00FF00"
+ display "Okay"
+ else display "no good" end-if
+ when 4 if hexed = "to be determined" display "Okay"
+ else display "no good" end-if
+ end-evaluate
+ move low-value to varx
+ move high-value to varx(4:3)
+ move function hex-of(varx) to hexed
+ display "high-value " with no advancing
+ evaluate function byte-length("a")
+ when 1 if hexed = "000000FFFFFF0000" display "Okay"
+ else display "no good" end-if
+ when 2 if hexed = "000000000000FF00FF00FF0000000000"
+ display "Okay"
+ else display "no good" end-if
+ when 4 if hexed = "to be determined" display "Okay"
+ else display "no good" end-if
+ end-evaluate
+ goback.
end program prog.
"12345678"
"12399978"
-"123"
"12300078"
"123 78"
"123"""78"
-0x3837ffffff333231
-""""""""""
+low-value Okay
+high-value Okay
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/SORT__table_sort__2___ASCII_.out" }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ ENVIRONMENT DIVISION.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 K PIC 9(2).
+
+ 01 CNT1 PIC 9(9) COMP-5 VALUE 4.
+ 01 TAB1.
+ 05 ROW1 OCCURS 1 TO 4 DEPENDING CNT1
+ DESCENDING TAB1-NR.
+ 10 TAB1-NR PIC 99.
+
+ 01 TAB2.
+ 05 CNT2 PIC 9(9) COMP-5 VALUE 4.
+ 05 ROW2 OCCURS 1 TO 4 DEPENDING CNT2
+ DESCENDING TAB2-NR.
+ 10 TAB2-NR PIC 99.
+
+ 01 TAB3.
+ 05 CNT3 PIC 9(9) COMP-5 VALUE 10.
+ 05 ROW3 OCCURS 1 TO 10 DEPENDING CNT3
+ DESCENDING TAB3-NR
+ ASCENDING TAB3-DATA.
+ 10 TAB3-NR PIC 99.
+ 10 FILLER PIC X(2).
+ 10 TAB3-DATA PIC X(5).
+ 10 FILLER PIC X(2).
+ 10 TAB3-DATA2 PIC X(5).
+
+
+ PROCEDURE DIVISION.
+ A.
+ PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4
+ MOVE K TO TAB1-NR(K), TAB2-NR(K)
+ END-PERFORM
+
+ MOVE 1 TO TAB3-NR(1).
+ MOVE 1 TO TAB3-NR(8).
+ MOVE 1 TO TAB3-NR(4).
+ MOVE 6 TO TAB3-NR(2).
+ MOVE 5 TO TAB3-NR(3).
+ MOVE 5 TO TAB3-NR(9).
+ MOVE 2 TO TAB3-NR(5).
+ MOVE 2 TO TAB3-NR(10).
+ MOVE 4 TO TAB3-NR(6).
+ MOVE 3 TO TAB3-NR(7).
+
+ MOVE "abcde" TO TAB3-DATA(1).
+ MOVE "AbCde" TO TAB3-DATA(2).
+ MOVE "abcde" TO TAB3-DATA(3).
+ MOVE "zyx" TO TAB3-DATA(4).
+ MOVE "12345" TO TAB3-DATA(5).
+ MOVE "zyx" TO TAB3-DATA(6).
+ MOVE "abcde" TO TAB3-DATA(7).
+ MOVE "AbCde" TO TAB3-DATA(8).
+ MOVE "abc" TO TAB3-DATA(9).
+ MOVE "12346" TO TAB3-DATA(10).
+
+ MOVE "day" TO TAB3-DATA2(1).
+ MOVE "The" TO TAB3-DATA2(2).
+ MOVE "eats" TO TAB3-DATA2(3).
+ MOVE "." TO TAB3-DATA2(4).
+ MOVE "mooos" TO TAB3-DATA2(5).
+ MOVE "grass" TO TAB3-DATA2(6).
+ MOVE "and" TO TAB3-DATA2(7).
+ MOVE "whole" TO TAB3-DATA2(8).
+ MOVE "cow" TO TAB3-DATA2(9).
+ MOVE "the" TO TAB3-DATA2(10).
+
+ SORT ROW1 DESCENDING TAB1-NR
+ SORT ROW2 DESCENDING TAB2-NR
+
+ DISPLAY "SINGLE TABLE" END-DISPLAY
+ PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4
+ DISPLAY TAB1-NR(K) END-DISPLAY
+ END-PERFORM
+
+ DISPLAY "LOWER LEVEL TABLE" END-DISPLAY
+ PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4
+ DISPLAY TAB2-NR(K) END-DISPLAY
+ END-PERFORM
+
+ SORT ROW3 DESCENDING TAB3-NR ASCENDING TAB3-DATA
+
+ DISPLAY "MULTI-KEY SORT" END-DISPLAY
+ PERFORM VARYING K FROM 1 BY 1 UNTIL K > 10
+ DISPLAY FUNCTION TRIM(ROW3(K))
+ END-DISPLAY
+ END-PERFORM
+
+ STOP RUN.
+
--- /dev/null
+SINGLE TABLE
+04
+03
+02
+01
+LOWER LEVEL TABLE
+04
+03
+02
+01
+MULTI-KEY SORT
+06 AbCde The
+05 abc cow
+05 abcde eats
+04 zyx grass
+03 abcde and
+02 12345 mooos
+02 12346 the
+01 AbCde whole
+01 abcde day
+01 zyx .
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/SORT__table_sort__2___EBCDIC_.out" }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ ENVIRONMENT DIVISION.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 K PIC 9(2).
+
+ 01 CNT1 PIC 9(9) COMP-5 VALUE 4.
+ 01 TAB1.
+ 05 ROW1 OCCURS 1 TO 4 DEPENDING CNT1
+ DESCENDING TAB1-NR.
+ 10 TAB1-NR PIC 99.
+
+ 01 TAB2.
+ 05 CNT2 PIC 9(9) COMP-5 VALUE 4.
+ 05 ROW2 OCCURS 1 TO 4 DEPENDING CNT2
+ DESCENDING TAB2-NR.
+ 10 TAB2-NR PIC 99.
+
+ 01 TAB3.
+ 05 CNT3 PIC 9(9) COMP-5 VALUE 10.
+ 05 ROW3 OCCURS 1 TO 10 DEPENDING CNT3
+ DESCENDING TAB3-NR
+ ASCENDING TAB3-DATA.
+ 10 TAB3-NR PIC 99.
+ 10 FILLER PIC X(2).
+ 10 TAB3-DATA PIC X(5).
+ 10 FILLER PIC X(2).
+ 10 TAB3-DATA2 PIC X(5).
+
+
+ PROCEDURE DIVISION.
+ A.
+ PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4
+ MOVE K TO TAB1-NR(K), TAB2-NR(K)
+ END-PERFORM
+
+ MOVE 1 TO TAB3-NR(1).
+ MOVE 1 TO TAB3-NR(8).
+ MOVE 1 TO TAB3-NR(4).
+ MOVE 6 TO TAB3-NR(2).
+ MOVE 5 TO TAB3-NR(3).
+ MOVE 5 TO TAB3-NR(9).
+ MOVE 2 TO TAB3-NR(5).
+ MOVE 2 TO TAB3-NR(10).
+ MOVE 4 TO TAB3-NR(6).
+ MOVE 3 TO TAB3-NR(7).
+
+ MOVE "abcde" TO TAB3-DATA(1).
+ MOVE "AbCde" TO TAB3-DATA(2).
+ MOVE "abcde" TO TAB3-DATA(3).
+ MOVE "zyx" TO TAB3-DATA(4).
+ MOVE "12345" TO TAB3-DATA(5).
+ MOVE "zyx" TO TAB3-DATA(6).
+ MOVE "abcde" TO TAB3-DATA(7).
+ MOVE "AbCde" TO TAB3-DATA(8).
+ MOVE "abc" TO TAB3-DATA(9).
+ MOVE "12346" TO TAB3-DATA(10).
+
+ MOVE "day" TO TAB3-DATA2(1).
+ MOVE "The" TO TAB3-DATA2(2).
+ MOVE "eats" TO TAB3-DATA2(3).
+ MOVE "." TO TAB3-DATA2(4).
+ MOVE "mooos" TO TAB3-DATA2(5).
+ MOVE "grass" TO TAB3-DATA2(6).
+ MOVE "and" TO TAB3-DATA2(7).
+ MOVE "whole" TO TAB3-DATA2(8).
+ MOVE "cow" TO TAB3-DATA2(9).
+ MOVE "the" TO TAB3-DATA2(10).
+
+ SORT ROW1 DESCENDING TAB1-NR
+ SORT ROW2 DESCENDING TAB2-NR
+
+ DISPLAY "SINGLE TABLE" END-DISPLAY
+ PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4
+ DISPLAY TAB1-NR(K) END-DISPLAY
+ END-PERFORM
+
+ DISPLAY "LOWER LEVEL TABLE" END-DISPLAY
+ PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4
+ DISPLAY TAB2-NR(K) END-DISPLAY
+ END-PERFORM
+
+ SORT ROW3 DESCENDING TAB3-NR ASCENDING TAB3-DATA
+
+ DISPLAY "MULTI-KEY SORT" END-DISPLAY
+ PERFORM VARYING K FROM 1 BY 1 UNTIL K > 10
+ DISPLAY FUNCTION TRIM(ROW3(K))
+ END-DISPLAY
+ END-PERFORM
+
+ STOP RUN.
+
--- /dev/null
+SINGLE TABLE
+04
+03
+02
+01
+LOWER LEVEL TABLE
+04
+03
+02
+01
+MULTI-KEY SORT
+06 AbCde The
+05 abc cow
+05 abcde eats
+04 zyx grass
+03 abcde and
+02 12345 mooos
+02 12346 the
+01 AbCde whole
+01 abcde day
+01 zyx .
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/Simple_DEBUG-ITEM.out" }
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ procedure division.
+ perform debugs
+ move "6chars" to debug-line
+ move "30chars======================>" to debug-name
+ move 1234 to debug-sub-1
+ move -4321 to debug-sub-2
+ move 9876 to debug-sub-3
+ move all 'A' to debug-contents
+ perform debugs
+ goback.
+ debugs.
+ display "DEBUG-ITEM " """" DEBUG-ITEM """"
+ display "DEBUG-LINE " """" DEBUG-LINE """"
+ display "DEBUG-NAME " """" DEBUG-NAME """"
+ display "DEBUG-SUB-1 " """" DEBUG-SUB-1 """"
+ display "DEBUG-SUB-2 " """" DEBUG-SUB-2 """"
+ display "DEBUG-SUB-3 " """" DEBUG-SUB-3 """"
+ display "DEBUG-CONTENTS " """" DEBUG-CONTENTS""""
+ continue.
+ end program prog.
+
--- /dev/null
+DEBUG-ITEM " +0000 +0000 +0000 "
+DEBUG-LINE " "
+DEBUG-NAME " "
+DEBUG-SUB-1 "+0000"
+DEBUG-SUB-2 "+0000"
+DEBUG-SUB-3 "+0000"
+DEBUG-CONTENTS " "
+DEBUG-ITEM "6chars 30chars======================> +1234 -4321 +9876 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"
+DEBUG-LINE "6chars"
+DEBUG-NAME "30chars======================>"
+DEBUG-SUB-1 "+1234"
+DEBUG-SUB-2 "-4321"
+DEBUG-SUB-3 "+9876"
+DEBUG-CONTENTS "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/Simple_ENVIRONMENT-NAME_with_exception.out" }
+ identification division.
+ program-id. envtest.
+ data division.
+ working-storage section.
+ 01 ename pic x(32).
+ 01 evalue pic x(32).
+ procedure division.
+ move "USER" to ename
+ display ename upon environment-name
+ accept evalue from environment-value
+ not on exception Display "We got a value back" end-display
+ end-accept
+ goback.
+ end program envtest.
+
--- /dev/null
+We got a value back
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/UNSTRING_with_refmods.out" }
+ identification division.
+ program-id prog.
+ data division.
+ working-storage section.
+ 01 foo pic x(10) value "A12345678A".
+ 01 bar pic X(11) value all ".".
+ procedure division.
+ unstring foo(2:) into bar(7:4) bar(2:4)
+ display bar
+ goback.
+
--- /dev/null
+.5678.1234.
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/command-line.out" }
+
+ *> ODD FAILURE: failing to recognize "" as SPACE
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 77 cmd-line-parm pic x(20).
+ procedure division.
+ ACCEPT cmd-line-parm FROM COMMAND-LINE(2).
+ IF cmd-line-parm NOT EQUAL SPACE THEN
+ DISPLAY "Not SPACE: " """" cmd-line-parm """"
+ ELSE
+ DISPLAY "Okay"
+ END-IF.
+ end program prog.
+
*> { dg-do run }
*> { dg-output-file "group2/debugging_lines__not_active_.out" }
-
+ >>SOURCE FIXED
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
DATA DIVISION.
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/floating-point_FORMAT_1.out" }
+ identification division.
+ program-id. prog.
+
+ data division.
+ working-storage section.
+ 01 cmp1a comp-1.
+ 01 cmp1b comp-1.
+
+ 01 cmp2a comp-2.
+ 01 cmp2b comp-2.
+
+ 01 cmp3a float-extended.
+ 01 cmp3b float-extended.
+
+ procedure division.
+ display "--- COMP-1 FORMAT 1 ---"
+ move 10 to cmp1a
+ move 7 to cmp1b
+ add cmp1b to cmp1a
+ display "add " cmp1a
+ move 10 to cmp1a
+ subtract cmp1b from cmp1a
+ display "subtract " cmp1a
+ move 10 to cmp1a
+ multiply cmp1b by cmp1a
+ display "multiply " cmp1a
+ move 10 to cmp1a
+ divide cmp1b into cmp1a
+ display "divide " cmp1a
+
+ display "--- COMP-2 FORMAT 1 ---"
+ move 10 to cmp2a
+ move 7 to cmp2b
+ add cmp2b to cmp2a
+ display "add " cmp2a
+ move 10 to cmp2a
+ subtract cmp2b from cmp2a
+ display "subtract " cmp2a
+ move 10 to cmp2a
+ multiply cmp2b by cmp2a
+ display "multiply " cmp2a
+ move 10 to cmp2a
+ divide cmp1b into cmp2a
+ display "divide " cmp2a
+
+ display "--- FLOAT-EXTENDED FORMAT 1 ---"
+ move 10 to cmp3a
+ move 7 to cmp3b
+ add cmp3b to cmp3a
+ display "add " cmp3a
+ move 10 to cmp3a
+ subtract cmp3b from cmp3a
+ display "subtract " cmp3a
+ move 10 to cmp3a
+ multiply cmp3b by cmp3a
+ display "multiply " cmp3a
+ move 10 to cmp3a
+ divide cmp1b into cmp3a
+ display "divide " cmp3a
+
+ goback.
+ end program prog.
+
--- /dev/null
+--- COMP-1 FORMAT 1 ---
+add 17
+subtract 3
+multiply 70
+divide 1.428571463
+--- COMP-2 FORMAT 1 ---
+add 17
+subtract 3
+multiply 70
+divide 1.4285714285714286
+--- FLOAT-EXTENDED FORMAT 1 ---
+add 17
+subtract 3
+multiply 70
+divide 1.428571428571428571428571428571428599
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/floating-point_FORMAT_2.out" }
+ identification division.
+ program-id. prog.
+
+ data division.
+ working-storage section.
+ 01 cmp1a comp-1.
+ 01 cmp1b comp-1.
+ 01 cmp1c comp-1.
+
+ 01 cmp2a comp-2.
+ 01 cmp2b comp-2.
+ 01 cmp2c comp-2.
+
+ 01 cmp3a float-extended.
+ 01 cmp3b float-extended.
+ 01 cmp3c float-extended.
+
+ procedure division.
+ display "--- COMP-1 FORMAT 2 ---"
+ move 10 to cmp1a
+ move 7 to cmp1b
+ add cmp1b to cmp1a giving cmp1c
+ display "add " cmp1a space cmp1b space cmp1c
+ subtract cmp1b from cmp1a giving cmp1c
+ display "subtract " cmp1a space cmp1b space cmp1c
+ multiply cmp1b by cmp1a giving cmp1c
+ display "multiply " cmp1a space cmp1b space cmp1c
+ divide cmp1a by cmp1b giving cmp1c
+ display "divide " cmp1a space cmp1b space cmp1c
+
+ display "--- COMP-2 FORMAT 2 ---"
+ move 10 to cmp2a
+ move 7 to cmp2b
+ add cmp2b to cmp2a giving cmp2c
+ display "add " cmp2a space cmp2b space cmp2c
+ subtract cmp2b from cmp2a giving cmp2c
+ display "subtract " cmp2a space cmp2b space cmp2c
+ multiply cmp2b by cmp2a giving cmp2c
+ display "multiply " cmp2a space cmp2b space cmp2c
+ divide cmp2a by cmp2b giving cmp2c
+ display "divide " cmp2a space cmp2b space cmp2c
+
+ display "--- FLOAT-EXTENDED FORMAT 2 ---"
+ move 10 to cmp3a
+ move 7 to cmp3b
+ add cmp3b to cmp3a giving cmp3c
+ display "add " cmp3a space cmp3b space cmp3c
+ subtract cmp3b from cmp3a giving cmp3c
+ display "subtract " cmp3a space cmp3b space cmp3c
+ multiply cmp3b by cmp3a giving cmp3c
+ display "multiply " cmp3a space cmp3b space cmp3c
+ divide cmp3a by cmp3b giving cmp3c
+ display "divide " cmp3a space cmp3b space cmp3c
+
+ goback.
+ end program prog.
+
--- /dev/null
+--- COMP-1 FORMAT 2 ---
+add 10 7 17
+subtract 10 7 3
+multiply 10 7 70
+divide 10 7 1.428571463
+--- COMP-2 FORMAT 2 ---
+add 10 7 17
+subtract 10 7 3
+multiply 10 7 70
+divide 10 7 1.4285714285714286
+--- FLOAT-EXTENDED FORMAT 2 ---
+add 10 7 17
+subtract 10 7 3
+multiply 10 7 70
+divide 10 7 1.428571428571428571428571428571428599
+
555.10 555.10 555.09 555.09 555.0999756 555.099999999999909 555.0999999999999999999999999999999211
555.10 555.09 555.09 555.10 555.0999756 555.099999999999909 555.0999999999999999999999999999999211
555.09 555.09 555.10 555.10 555.0999756 555.099999999999909 555.1000030517578124999999999999999606
-555.09 555.10 555.10 555.10 555.0999756 555.100003051757767 555.0999999999999971578290569595992171
\ No newline at end of file
+555.09 555.10 555.10 555.10 555.0999756 555.100003051757767 555.0999999999999971578290569595992171
+
555.55
555.55e206
333.3300 333.3300 333.3300 333.3300 3.333300083E+22 3.33329999999999994E+102 3.333300000000000000000000000000000168E+202
-555.5500 555.5500 555.5500 555.5500 5.555499988E+22 5.55549999999999973E+102 5.555500000000000000000000000000000029E+202
\ No newline at end of file
+555.5500 555.5500 555.5500 555.5500 5.555499988E+22 5.55549999999999973E+102 5.555500000000000000000000000000000029E+202
+
--- /dev/null
+ *> { dg-do run }
+ id division.
+ *> IBM is PERMISSIVE and allows PROGRAM-ID without a terminating
+ *> period. ISO 2014 does not. IBM's behaviors are part of a
+ *> DIALECT
+ program-id prog.
+ data division.
+ working-storage section.
+ 77 var-1 pic x(10).
+ 77 var-2 pic x(10).
+ procedure division.
+ call "subroutine1" using by reference var-1
+ by value var-2.
+ id division.
+ program-id. subroutine1.
+ data division.
+ linkage section.
+ 77 avar-1 pic x(10).
+ 77 avar-2 pic x(10).
+ procedure division using by reference avar-1 by value avar-2.
+ display avar-1.
+ move "---" to avar-1.
+ display avar-1.
+ end program subroutine1.
+ end program prog.
+
--- /dev/null
+ *> { dg-do run }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ REPOSITORY.
+ PROCEDURE DIVISION.
+ DISPLAY "OK".
+
--- /dev/null
+ *> { dg-do compile }
+
+ ID DIVISION.
+ PROGRAM-ID. TS00PCOl.
+ SKIP1
+ DATE-WRITTEN.
+
--- /dev/null
+ *> { dg-do run }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ SOURCE-COMPUTER. a.
+ OBJECT-COMPUTER. b.
+ PROCEDURE DIVISION.
+ DISPLAY "OK".
+
projects / thirdparty / gcc.git / commitdiff
