diff options
Diffstat (limited to 'tests/examplefiles/example.cob')
| -rw-r--r-- | tests/examplefiles/example.cob | 3556 |
1 files changed, 3556 insertions, 0 deletions
diff --git a/tests/examplefiles/example.cob b/tests/examplefiles/example.cob new file mode 100644 index 00000000..3f65e498 --- /dev/null +++ b/tests/examplefiles/example.cob @@ -0,0 +1,3556 @@ + IDENTIFICATION DIVISION.
+ PROGRAM-ID. OCic.
+ *****************************************************************
+ ** This program provides a Textual User Interface (TUI) to the **
+ ** process of compiling and (optionally) executing an OpenCOBOL**
+ ** program. **
+ ** **
+ ** This programs execution syntax is as follows: **
+ ** **
+ ** ocic <program-path-and-filename> [ <switch>... ] **
+ ** **
+ ** Once executed, a display screen will be presented showing **
+ ** the compilation options that will be used. The user will **
+ ** have the opportunity to change options, specify new ones **
+ ** and specify any program execution arguments to be used if **
+ ** you select the "Execute" option. When you press the Enter **
+ ** key the program will be compiled. **
+ ** **
+ ** The SCREEN SECTION contains an image of the screen. **
+ ** **
+ ** The "010-Parse-Args" section in the PROCEDURE DIVISION has **
+ ** documentation on switches and their function. **
+ *****************************************************************
+ ** **
+ ** AUTHOR: GARY L. CUTLER **
+ ** CutlerGL@gmail.com **
+ ** Copyright (C) 2009-2010, Gary L. Cutler, GPL **
+ ** **
+ ** DATE-WRITTEN: June 14, 2009 **
+ ** **
+ *****************************************************************
+ ** Note: Depending on which extended DISPLAY handler you're **
+ ** using (PDCurses, Curses, ...), you may need to un- **
+ ** comment any source lines tagged with "SCROLL" in cols **
+ ** 1-6 in order to have error messages scroll properly **
+ ** in the OCic shell window. **
+ *****************************************************************
+ ** DATE CHANGE DESCRIPTION **
+ ** ====== ==================================================== **
+ ** GC0609 Don't display compiler messages file if compilation **
+ ** Is successful. Also don't display messages if the **
+ ** output file is busy (just put a message on the **
+ ** screen, leave the OC screen up & let the user fix **
+ ** the problem & resubmit. **
+ ** GC0709 When 'EXECUTE' is selected, a 'FILE BUSY' error will **
+ ** still cause the (old) executable to be launched. **
+ ** Also, the 'EXTRA SWITCHES' field is being ignored. **
+ ** Changed the title bar to lowlighted reverse video & **
+ ** the message area to highlighted reverse-video. **
+ ** GC0809 Add a SPACE in from of command-line args when **
+ ** executing users program. Add a SPACE after the **
+ ** -ftraceall switch when building cobc command. **
+ ** GC0909 Convert to work on Cygwin/Linux as well as MinGW **
+ ** GC0310 Virtualized the key codes for S-F1 thru S-F7 as they **
+ ** differ depending upon whether PDCurses or NCurses is **
+ ** being used. **
+ ** GC0410 Introduced the cross-reference and source listing **
+ ** features. Also fixed a bug in @EXTRA switch proces- **
+ ** sing where garbage will result if more than the **
+ ** @EXTRA switch is specified. **
+ *****************************************************************
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ REPOSITORY.
+ FUNCTION ALL INTRINSIC.
+ INPUT-OUTPUT SECTION.
+ FILE-CONTROL.
+ SELECT Bat-File ASSIGN TO Bat-File-Name
+ ORGANIZATION IS LINE SEQUENTIAL.
+
+ SELECT Cobc-Output ASSIGN TO Cobc-Output-File
+ ORGANIZATION IS LINE SEQUENTIAL.
+
+ SELECT Source-Code ASSIGN TO File-Name
+ ORGANIZATION IS LINE SEQUENTIAL
+ FILE STATUS IS FSM-Status.
+ DATA DIVISION.
+ FILE SECTION.
+ FD Bat-File.
+ 01 Bat-File-Rec PIC X(2048).
+
+ FD Cobc-Output.
+ 01 Cobc-Output-Rec PIC X(256).
+
+ FD Source-Code.
+ 01 Source-Code-Record PIC X(80).
+
+ WORKING-STORAGE SECTION.
+ COPY screenio.
+
+ 01 Bat-File-Name PIC X(256).
+
+GC0909 01 Cmd PIC X(512).
+
+ 01 Cobc-Cmd PIC X(256).
+
+ 01 Cobc-Output-File PIC X(256).
+
+ 01 Command-Line-Args PIC X(256).
+
+ 01 Config-File PIC X(12).
+
+GC0310 01 Config-Keys.
+GC0310 05 CK-S-F1 PIC 9(4).
+GC0310 05 CK-S-F2 PIC 9(4).
+GC0310 05 CK-S-F3 PIC 9(4).
+GC0310 05 CK-S-F4 PIC 9(4).
+GC0310 05 CK-S-F5 PIC 9(4).
+GC0310 05 CK-S-F6 PIC 9(4).
+GC0310 05 CK-S-F7 PIC 9(4).
+
+GC0909 01 Dir-Char PIC X(1).
+
+ 01 Dummy PIC X(1).
+
+ 01 Env-TEMP PIC X(256).
+
+ 01 File-Name.
+ 05 FN-Char OCCURS 256 TIMES PIC X(1).
+
+ 01 File-Status-Message.
+ 05 FILLER PIC X(13) VALUE 'Status Code: '.
+ 05 FSM-Status PIC 9(2).
+ 05 FILLER PIC X(11) VALUE ', Meaning: '.
+ 05 FSM-Msg PIC X(25).
+
+ 01 Flags.
+ 05 F-Compilation-Succeeded PIC X(1).
+ 88 88-Compile-OK VALUE 'Y'.
+GC0909 88 88-Compile-OK-Warn VALUE 'W'.
+ 88 88-Compile-Failed VALUE 'N'.
+GC0609 05 F-Complete PIC X(1).
+GC0609 88 88-Complete VALUE 'Y'.
+GC0609 88 88-Not-Complete VALUE 'N'.
+GC0809 05 F-IDENT-DIVISION PIC X(1).
+GC0809 88 88-1st-Prog-Complete VALUE 'Y'.
+GC0809 88 88-More-To-1st-Prog VALUE 'N'.
+ 05 F-LINKAGE-SECTION PIC X(1).
+ 88 88-Compile-As-Subpgm VALUE 'Y'.
+ 88 88-Compile-As-Mainpgm VALUE 'N'.
+ 05 F-No-Switch-Changes PIC X(1).
+ 88 88-No-Switch-Changes VALUE 'Y'.
+ 88 88-Switch-Changes VALUE 'N'.
+GC0709 05 F-Output-File-Busy PIC X(1).
+GC0709 88 88-Output-File-Busy VALUE 'Y'.
+GC0709 88 88-Output-File-Avail VALUE 'N'.
+GC0809 05 F-Source-Record-Type PIC X(1).
+GC0809 88 88-Source-Rec-Linkage VALUE 'L'.
+GC0809 88 88-Source-Rec-Ident VALUE 'I'.
+GC0809 88 88-Source-Rec-IgnoCOB-COLOR-RED VALUE ' '.
+ 05 F-Switch-Error PIC X(1).
+ 88 88-Switch-Is-Bad VALUE 'Y'.
+ 88 88-Switch-Is-Good VALUE 'N'.
+
+GC0909 01 Horizontal-Line PIC X(80).
+GC0909
+ 01 I USAGE BINARY-LONG.
+
+ 01 J USAGE BINARY-LONG.
+
+GC0909 01 MS USAGE BINARY-LONG.
+
+GC0909 01 ML USAGE BINARY-LONG.
+
+ 01 OC-Compiled PIC XXXX/XX/XXBXX/XX.
+
+GC0909 01 OS-Type USAGE BINARY-LONG.
+GC0909 88 OS-Unknown VALUE 0.
+GC0909 88 OS-Windows VALUE 1.
+GC0909 88 OS-Cygwin VALUE 2.
+GC0909 88 OS-UNIX VALUE 3.
+
+GC0909 01 OS-Type-Literal PIC X(7).
+
+ 01 Output-Message PIC X(80).
+
+ 01 Path-Delimiter PIC X(1).
+
+ 01 Prog-Folder PIC X(256).
+
+ 01 Prog-Extension PIC X(30).
+
+ 01 Prog-File-Name PIC X(40).
+
+ 01 Prog-Name PIC X(31).
+
+ 78 Selection-Char VALUE '>'.
+
+ 01 Switch-Display.
+ 05 SD-Switch-And-Value PIC X(19).
+ 05 FILLER PIC X(1).
+ 05 SD-Description PIC X(60).
+
+ 01 Switch-Keyword PIC X(12).
+GC0410 88 Switch-Is-CONFIG VALUE '@CONFIG', '@C'.
+GC0410 88 Switch-Is-DEBUG VALUE '@DEBUG', '@D'.
+GC0410 88 Switch-Is-DLL VALUE '@DLL'.
+GC0410 88 Switch-Is-EXECUTE VALUE '@EXECUTE', '@E'.
+GC0410 88 Switch-Is-EXTRA VALUE '@EXTRA', '@EX'.
+GC0410 88 Switch-Is-NOTRUNC VALUE '@NOTRUNC', '@N'.
+GC0410 88 Switch-Is-TRACE VALUE '@TRACE', '@T'.
+GC0410 88 Switch-Is-SOURCE VALUE '@SOURCE', '@S'.
+GC0410 88 Switch-Is-XREF VALUE '@XREF', '@X'.
+
+ 01 Switch-Keyword-And-Value PIC X(256).
+
+ 01 Switch-Value.
+ 05 SV-1 PIC X(1).
+ 05 FILLER PIC X(255).
+ 01 Switch-Value-Alt REDEFINES Switch-Value
+ PIC X(256).
+ 88 Valid-Config-Filename
+ VALUE 'BS2000', 'COBOL85', 'COBOL2002', 'DEFAULT',
+ 'IBM', 'MF', 'MVS'.
+
+ 01 Switches.
+ 05 S-ARGS PIC X(75) VALUE SPACES.
+ 05 S-CfgS.
+ 10 S-Cfg-BS2000 PIC X(1) VALUE ' '.
+ 10 S-Cfg-COBOL85 PIC X(1) VALUE ' '.
+ 10 S-Cfg-COBOL2002 PIC X(1) VALUE ' '.
+ 10 S-Cfg-DEFAULT PIC X(1) VALUE Selection-Char.
+ 10 S-Cfg-IBM PIC X(1) VALUE ' '.
+ 10 S-Cfg-MF PIC X(1) VALUE ' '.
+ 10 S-Cfg-MVS PIC X(1) VALUE ' '.
+ 05 S-EXTRA PIC X(75) VALUE SPACES.
+ 05 S-Yes-No-Switches.
+ 10 S-DEBUG PIC X(1) VALUE 'N'.
+ 10 S-DLL PIC X(1) VALUE 'N'.
+GC0410 10 S-XREF PIC X(1) VALUE 'N'.
+GC0410 10 S-SOURCE PIC X(1) VALUE 'N'.
+ 10 S-EXECUTE PIC X(1) VALUE 'N'.
+ 10 S-NOTRUNC PIC X(1) VALUE 'Y'.
+ 10 S-SUBROUTINE PIC X(1) VALUE 'A'.
+ 10 S-TRACE PIC X(1) VALUE 'N'.
+ 10 S-TRACEALL PIC X(1) VALUE 'N'.
+
+ 01 Tally USAGE BINARY-LONG.
+
+ SCREEN SECTION.
+ *>
+ *> Here is the layout of the OCic screen.
+ *>
+ *> Note that this program can utilize the traditional PC line-drawing characters,
+ *> if they are available.
+ *>
+ *> If this program is run on Windows, it must run with codepage 437 activated to
+ *> display the line-drawing characters. With a native Windows build or a
+ *> Windows/MinGW build, one could use the command "chcp 437" to set that codepage
+ *> for display within a Windows console window (that should be the default, though).
+ *> With a Windows/Cygwin build, set the environment variable CYGWIN to a value of
+ *> "codepage:oem" (this cannot be done from within the program though - you will
+ *> have to use the "Computer/Advanced System Settings/Environment Variables" (Vista or
+ *> Windows 7) function to define the variable. XP Users: use "My Computer/Properties/
+ *> Advanced/Environment Variables".
+ *>
+ *> To use OCic without the line-drawing characters, comment-out the first set of
+ *> 78 "LD" items and uncomment the second.
+ *>
+ *> The following sample screen layout shows how the screen looks with line-drawing
+ *> characters disabled.
+ *>
+ *>===================================================================================
+ *> OCic (2010/04/02 11:36) - OpenCOBOL V1.1 Interactive Compilation Windows 01
+ *> +-----------------------------------------------------------------------------+ 02
+ *> | Program: OCic F-Key: Select Opt | 03
+ *> | Folder: E:\OpenCOBOL\Samples Enter: Compile | 04
+ *> | Filename: OCic.cbl Esc: Quit | 05
+ *> +-----------------------------------------------------------------------------+ 06
+ *> On/Off Switches: Configuration: 07
+ *> +---------------------------------------------------------+-------------------+ 08
+ *> | F1 Compile debug lines F8 Produce source listing | S-F1 BS2000 | 09
+ *> | F2 Always make DLLs F9 Produce xref listing | S-F2 COBOL85 | 10
+ *> | F3 Pgm is a SUBROUTINE | S-F3 COBOL2002 | 11
+ *> | F4 Execute if compile OK | S-F4 > Default | 12
+ *> | F5 > No COMP/BINARY trunc | S-F5 IBM | 13
+ *> | F6 Trace procedures | S-F6 MicroFocus | 14
+ *> | F7 Trace proc + stmnts | S-F7 MVS | 15
+ *> +---------------------------------------------------------+-------------------+ 16
+ *> Additional "cobc" Switches (if any): 17
+ *> +-----------------------------------------------------------------------------+ 18
+ *> | -O2________________________________________________________________________ | 19
+ *> +-----------------------------------------------------------------------------+ 20
+ *> Program Execution Arguments (if any): 21
+ *> +-----------------------------------------------------------------------------+ 22
+ *> | ___________________________________________________________________________ | 23
+ *> +-----------------------------------------------------------------------------+ 24
+ *> OCic Copyright (C) 2009-2010, Gary L. Cutler, GPL 25
+ *>===================================================================================
+ *>12345678901234567890123456789012345678901234567890123456789012345678901234567890
+ *> 1 2 3 4 5 6 7 8
+ *>
+ *> USE THESE CHARS FOR LINE-DRAWING IF YOU HAVE ACCESS TO PC-DOS CODEPAGE 437:
+ *>
+ 78 LD-UL-Corner VALUE X"DA".
+ 78 LD-LL-Corner VALUE X"C0".
+ 78 LD-UR-Corner VALUE X"BF".
+ 78 LD-LR-Corner VALUE X"D9".
+ 78 LD-Upper-T VALUE X"C2".
+ 78 LD-Lower-T VALUE X"C1".
+ 78 LD-Horiz-Line VALUE X"C4".
+ 78 LD-Vert-Line VALUE X"B3".
+ *>
+ *> USE THESE CHARS FOR LINE-DRAWING IF YOU DO NOT HAVE ACCESS TO PC-DOS CODEPAGE 437:
+ *>
+ *> 78 LD-UL-Corner VALUE '+'.
+ *> 78 LD-LL-Corner VALUE '+'.
+ *> 78 LD-UR-Corner VALUE '+'.
+ *> 78 LD-LR-Corner VALUE '+'.
+ *> 78 LD-Upper-T VALUE '+'.
+ *> 78 LD-Lower-T VALUE '+'.
+ *> 78 LD-Horiz-Line VALUE '-'.
+ *> 78 LD-Vert-Line VALUE '|'.
+ *>
+ 01 Blank-Screen LINE 1 COLUMN 1 BLANK SCREEN.
+
+ 01 Switches-Screen BACKGROUND-COLOR COB-COLOR-BLACK
+ FOREGROUND-COLOR COB-COLOR-WHITE AUTO.
+ *>
+ *> GENERAL SCREEN FRAMEWORK
+ *>
+ 03 BACKGROUND-COLOR COB-COLOR-BLACK
+ FOREGROUND-COLOR COB-COLOR-BLUE HIGHLIGHT.
+ 05 LINE 02 COL 02 VALUE LD-UL-Corner.
+ 05 PIC X(77) FROM Horizontal-Line.
+ 05 COL 80 VALUE LD-UR-Corner.
+
+ 05 LINE 03 COL 02 VALUE LD-Vert-Line.
+ 05 COL 80 VALUE LD-Vert-Line.
+
+ 05 LINE 04 COL 02 VALUE LD-Vert-Line.
+ 05 COL 80 VALUE LD-Vert-Line.
+
+ 05 LINE 05 COL 02 VALUE LD-Vert-Line.
+ 05 COL 80 VALUE LD-Vert-Line.
+
+ 05 LINE 06 COL 02 VALUE LD-LL-Corner.
+ 05 PIC X(77) FROM Horizontal-Line.
+ 05 COL 80 VALUE LD-LR-Corner.
+
+ 05 LINE 08 COL 02 VALUE LD-UL-Corner.
+ 05 PIC X(57) FROM Horizontal-Line.
+ 05 COL 60 VALUE LD-Upper-T.
+ 05 PIC X(19) FROM Horizontal-Line.
+ 05 COL 80 VALUE LD-UR-Corner.
+
+ 05 LINE 09 COL 02 VALUE LD-Vert-Line.
+ 05 COL 60 VALUE LD-Vert-Line.
+ 05 COL 80 VALUE LD-Vert-Line.
+
+ 05 LINE 10 COL 02 VALUE LD-Vert-Line.
+ 05 COL 60 VALUE LD-Vert-Line.
+ 05 COL 80 VALUE LD-Vert-Line.
+
+ 05 LINE 11 COL 02 VALUE LD-Vert-Line.
+ 05 COL 60 VALUE LD-Vert-Line.
+ 05 COL 80 VALUE LD-Vert-Line.
+
+ 05 LINE 12 COL 02 VALUE LD-Vert-Line.
+ 05 COL 60 VALUE LD-Vert-Line.
+ 05 COL 80 VALUE LD-Vert-Line.
+
+ 05 LINE 13 COL 02 VALUE LD-Vert-Line.
+ 05 COL 60 VALUE LD-Vert-Line.
+ 05 COL 80 VALUE LD-Vert-Line.
+
+ 05 LINE 14 COL 02 VALUE LD-Vert-Line.
+ 05 COL 60 VALUE LD-Vert-Line.
+ 05 COL 80 VALUE LD-Vert-Line.
+
+ 05 LINE 15 COL 02 VALUE LD-Vert-Line.
+ 05 COL 60 VALUE LD-Vert-Line.
+ 05 COL 80 VALUE LD-Vert-Line.
+
+ 05 LINE 16 COL 02 VALUE LD-LL-Corner.
+ 05 PIC X(57) FROM Horizontal-Line.
+ 05 COL 60 VALUE LD-Lower-T.
+ 05 PIC X(19) FROM Horizontal-Line.
+ 05 COL 80 VALUE LD-LR-Corner.
+
+ 05 LINE 18 COL 02 VALUE LD-UL-Corner.
+ 05 PIC X(77) FROM Horizontal-Line.
+ 05 COL 80 VALUE LD-UR-Corner.
+
+ 05 LINE 19 COL 02 VALUE LD-Vert-Line.
+ 05 COL 80 VALUE LD-Vert-Line.
+
+ 05 LINE 20 COL 02 VALUE LD-LL-Corner.
+ 05 PIC X(77) FROM Horizontal-Line.
+ 05 COL 80 VALUE LD-LR-Corner.
+
+ 05 LINE 22 COL 02 VALUE LD-UL-Corner.
+ 05 PIC X(77) FROM Horizontal-Line.
+ 05 COL 80 VALUE LD-UR-Corner.
+
+ 05 LINE 23 COL 02 VALUE LD-Vert-Line.
+ 05 COL 80 VALUE LD-Vert-Line.
+
+ 05 LINE 24 COL 02 VALUE LD-LL-Corner.
+ 05 PIC X(77) FROM Horizontal-Line.
+ 05 COL 80 VALUE LD-LR-Corner.
+ *>
+ *> TOP AND BOTTOM LINES
+ *>
+ 03 BACKGROUND-COLOR COB-COLOR-BLUE BLINK
+ FOREGROUND-COLOR COB-COLOR-WHITE HIGHLIGHT.
+GC0410 05 LINE 01 COL 01 VALUE ' OCic ('.
+GC0410 05 PIC X(16) FROM OC-Compiled.
+GC0410 05 VALUE ') OpenCOBOL V1.1 06FEB2009 ' &
+GC0410 'Interactive Compilation '.
+GC0410 05 LINE 25 COL 01 PIC X(81) FROM Output-Message.
+ *>
+ *> LABELS
+ *>
+ 03 BACKGROUND-COLOR COB-COLOR-BLACK
+ FOREGROUND-COLOR COB-COLOR-CYAN HIGHLIGHT.
+ 05 LINE 07 COL 04 VALUE 'On/Off Switches:'.
+ 05 COL 62 VALUE 'Configuration:'.
+ 05 LINE 17 COL 04 VALUE 'Additional "cobc" Switches (if any
+ - '):'.
+ 05 LINE 21 COL 04 VALUE 'Program Execution Arguments (if an
+ - 'y):'.
+ *>
+ *> TOP SECTION BACKGROUND
+ *>
+ 03 BACKGROUND-COLOR COB-COLOR-BLACK
+ FOREGROUND-COLOR COB-COLOR-CYAN LOWLIGHT.
+ 05 LINE 03 COL 04 VALUE 'Program: '.
+ 05 LINE 04 COL 04 VALUE 'Folder: '.
+ 05 LINE 05 COL 04 VALUE 'Filename: '.
+
+ 05 LINE 03 COL 62 VALUE 'F-Key: Select Opt'.
+ 05 LINE 04 COL 62 VALUE 'Enter: Compile '.
+ 05 LINE 05 COL 62 VALUE 'Esc: Quit '.
+ *>
+ *> TOP SECTION PROGRAM INFO
+ *>
+ 03 BACKGROUND-COLOR COB-COLOR-BLACK
+ FOREGROUND-COLOR COB-COLOR-WHITE HIGHLIGHT.
+ 05 LINE 03 COL 14 PIC X(47) FROM Prog-Name.
+ 05 LINE 04 COL 14 PIC X(47) FROM Prog-Folder.
+ 05 LINE 05 COL 14 PIC X(47) FROM Prog-File-Name.
+ *>
+ *> MIDDLE LEFT SECTION F-KEYS
+ *>
+ 03 BACKGROUND-COLOR COB-COLOR-BLACK
+ FOREGROUND-COLOR COB-COLOR-WHITE HIGHLIGHT.
+ 05 LINE 09 COL 04 VALUE 'F1'.
+ 05 LINE 10 COL 04 VALUE 'F2'.
+ 05 LINE 11 COL 04 VALUE 'F3'.
+ 05 LINE 12 COL 04 VALUE 'F4'.
+ 05 LINE 13 COL 04 VALUE 'F5'.
+ 05 LINE 14 COL 04 VALUE 'F6'.
+ 05 LINE 15 COL 04 VALUE 'F7'.
+ 05 LINE 09 COL 32 VALUE 'F8'.
+ 05 LINE 10 COL 32 VALUE 'F9'.
+ *>
+ *> MIDDLE LEFT SECTION SWITCHES
+ *>
+ 03 BACKGROUND-COLOR COB-COLOR-BLACK
+ FOREGROUND-COLOR COB-COLOR-RED HIGHLIGHT.
+ 05 LINE 09 COL 07 PIC X(1) FROM S-DEBUG.
+ 05 LINE 10 COL 07 PIC X(1) FROM S-DLL.
+ 05 LINE 11 COL 07 PIC X(1) FROM S-SUBROUTINE.
+ 05 LINE 12 COL 07 PIC X(1) FROM S-EXECUTE.
+ 05 LINE 13 COL 07 PIC X(1) FROM S-NOTRUNC.
+ 05 LINE 14 COL 07 PIC X(1) FROM S-TRACE.
+ 05 LINE 15 COL 07 PIC X(1) FROM S-TRACEALL.
+ 05 LINE 09 COL 35 PIC X(1) FROM S-SOURCE.
+ 05 LINE 10 COL 35 PIC X(1) FROM S-XREF.
+ *>
+ *> MIDDLE LEFT SECTION BACKGROUND
+ *>
+ 03 BACKGROUND-COLOR COB-COLOR-BLACK
+ FOREGROUND-COLOR COB-COLOR-CYAN LOWLIGHT.
+ 05 LINE 09 COL 09 VALUE 'Compile debug lines '.
+ 05 LINE 10 COL 09 VALUE 'Always make DLLs '.
+ 05 LINE 11 COL 09 VALUE 'Pgm is a SUBROUTINE '.
+ 05 LINE 12 COL 09 VALUE 'Execute if compile OK '.
+ 05 LINE 13 COL 09 VALUE 'No COMP/BINARY trunc '.
+ 05 LINE 14 COL 09 VALUE 'Trace procedures '.
+ 05 LINE 15 COL 09 VALUE 'Trace proc + stmnts '.
+ 05 LINE 09 COL 37 VALUE 'Produce source listing'.
+ 05 LINE 10 COL 37 VALUE 'Produce xref listing '.
+ *>
+ *> MIDDLE RIGHT SECTION F-KEYS
+ *>
+ 03 BACKGROUND-COLOR COB-COLOR-BLACK
+ FOREGROUND-COLOR COB-COLOR-WHITE HIGHLIGHT.
+ 05 LINE 09 COL 62 VALUE 'S-F1'.
+ 05 LINE 10 COL 62 VALUE 'S-F2'.
+ 05 LINE 11 COL 62 VALUE 'S-F3'.
+ 05 LINE 12 COL 62 VALUE 'S-F4'.
+ 05 LINE 13 COL 62 VALUE 'S-F5'.
+ 05 LINE 14 COL 62 VALUE 'S-F6'.
+ 05 LINE 15 COL 62 VALUE 'S-F7'.
+ *>
+ *> MIDDLE RIGHT SECTION SWITCHES
+ *>
+ 03 BACKGROUND-COLOR COB-COLOR-BLACK
+ FOREGROUND-COLOR COB-COLOR-RED HIGHLIGHT.
+ 05 LINE 09 COL 67 PIC X(1) FROM S-Cfg-BS2000.
+ 05 LINE 10 COL 67 PIC X(1) FROM S-Cfg-COBOL85.
+ 05 LINE 11 COL 67 PIC X(1) FROM S-Cfg-COBOL2002.
+ 05 LINE 12 COL 67 PIC X(1) FROM S-Cfg-DEFAULT.
+ 05 LINE 13 COL 67 PIC X(1) FROM S-Cfg-IBM.
+ 05 LINE 14 COL 67 PIC X(1) FROM S-Cfg-MF.
+ 05 LINE 15 COL 67 PIC X(1) FROM S-Cfg-MVS.
+ *>
+ *> MIDDLE RIGHT SECTION BACKGROUND
+ *>
+ 03 BACKGROUND-COLOR COB-COLOR-BLACK
+ FOREGROUND-COLOR COB-COLOR-CYAN LOWLIGHT.
+ 05 LINE 09 COL 69 VALUE 'BS2000 '.
+ 05 LINE 10 COL 69 VALUE 'COBOL85 '.
+ 05 LINE 11 COL 69 VALUE 'COBOL2002 '.
+ 05 LINE 12 COL 69 VALUE 'Default '.
+ 05 LINE 13 COL 69 VALUE 'IBM '.
+ 05 LINE 14 COL 69 VALUE 'MicroFocus'.
+ 05 LINE 15 COL 69 VALUE 'MVS '.
+ *>
+ *> FREE-FORM OPTIONS FIELDS
+ *>
+ 03 BACKGROUND-COLOR COB-COLOR-BLACK
+ FOREGROUND-COLOR COB-COLOR-WHITE HIGHLIGHT.
+ 05 LINE 19 COL 04 PIC X(75) USING S-EXTRA.
+ 05 LINE 23 COL 04 PIC X(75) USING S-ARGS.
+ /
+ PROCEDURE DIVISION.
+ *****************************************************************
+ ** Legend to procedure names: **
+ ** **
+ ** 00x-xxx All MAIN driver procedures **
+ ** 0xx-xxx All GLOBAL UTILITY procedures **
+ ** 1xx-xxx All INITIALIZATION procedures **
+ ** 2xx-xxx All CORE PROCESSING procedures **
+ ** 9xx-xxx All TERMINATION procedures **
+ *****************************************************************
+ DECLARATIVES.
+ 000-File-Error SECTION.
+ USE AFTER STANDARD ERROR PROCEDURE ON Source-Code.
+ 000-Handle-Error.
+ COPY FileStat-Msgs
+ REPLACING STATUS BY FSM-Status
+ MSG BY FSM-Msg.
+ MOVE SPACES TO Output-Message
+ IF FSM-Status = 35
+ DISPLAY
+ 'File not found: "'
+ TRIM(File-Name,TRAILING)
+ '"'
+ END-DISPLAY
+ ELSE
+ DISPLAY
+ 'Error accessing file: "'
+ TRIM(File-Name,TRAILING)
+ '"'
+ END-DISPLAY
+ END-IF
+ GOBACK
+ .
+ END DECLARATIVES.
+ /
+ 000-Main SECTION.
+
+ PERFORM 100-Initialization
+GC0609 SET 88-Not-Complete TO TRUE
+GC0609 PERFORM UNTIL 88-Complete
+GC0609 PERFORM 200-Let-User-Set-Switches
+GC0609 PERFORM 210-Run-Compiler
+GC0410 IF (88-Compile-OK OR 88-Compile-OK-Warn)
+GC0410 AND (S-XREF NOT = SPACE OR S-SOURCE NOT = SPACE)
+GC0410 PERFORM 220-Make-Listing
+GC0410 END-IF
+GC0709 IF (S-EXECUTE NOT = SPACES)
+GC0709 AND (88-Output-File-Avail)
+GC0609 PERFORM 230-Run-Program
+GC0609 END-IF
+GC0609 END-PERFORM
+ .
+
+ 009-Done.
+ PERFORM 900-Terminate
+ .
+ * -- Control will NOT return
+ /
+ 010-Parse-Args SECTION.
+ *****************************************************************
+ ** Process a sequence of KEYWORD=VALUE items. These are items **
+ ** specified on the command-line to provide the initial **
+ ** options shown selected on the screen. When integrating **
+ ** OCic into an edirot or framework, include these switches on **
+ ** the ocic.exe command the editor/framework executes. Any **
+ ** underlined choice is the default value for that switch. **
+ ** **
+ ** @CONFIG=BS2000|COBOL85|COBOL2002|DEFAULT|IBM|MF|MVS **
+ ** ======= **
+ ** This switch specifies the default cobc compiler configura- **
+ ** tion file to be used **
+ ** **
+ ** @DEBUG=YES|NO **
+ ** == **
+ ** This switch specifies whether (YES) or not (NO) debugging **
+ ** lines (those with a "D" in column 7) will be compiled. **
+ ** **
+ ** @DLL=YES|NO **
+ ** == **
+ ** Use this switch to force ALL compiled programs to be built **
+ ** as DLLs ("@DLL=YES"). When main programs are built as DLLs **
+ ** they must be executed using the cobcrun utility. When **
+ ** "@DLL=NO" is in effect, main programs are generated as **
+ ** actual "exe" files and only subprograms will be generated **
+ ** as DLLs. **
+ ** **
+ ** @EXECUTE=YES|NO **
+ ** == **
+ ** This switch specifies whether ("@EXECUTE=YES") or not **
+ ** ("@EXECUTE=NO") the program will be executed after it is **
+ ** successfully compiled. **
+ ** **
+ ** @EXTRA=extra cobc argument(s) **
+ ** **
+ ** This switch allows you to specify additional cobc arguments **
+ ** that aren't managed by the other OC switches. If used, **
+ ** this must be the last switch specified on the command line, **
+ ** as everything that follows the "=" will be placed on the **
+ ** cobc command generated by OC. **
+ ** **
+ ** @NOTRUNC=YES|NO **
+ ** === **
+ ** This switch specifies whether (YES) or not (NO) the sup- **
+ ** pression of binary field truncation will occur. If a PIC **
+ ** 99 COMP field (one byte of storage), for example, is given **
+ ** the value 123, it may have its value truncated to 23 when **
+ ** DISPLAYed. Regardless of the NOTRUNC setting, internally **
+ ** the full precision of the field (allowing a maximum value **
+ ** of 255) will be preserved. Even though truncation - if it **
+ ** does occur - would appear to have a minimal disruption on **
+ ** program operation, it has a significant effect on program **
+ ** run-time speed. **
+ ** **
+ ** @TRACE=YES|NO|ALL **
+ ** == **
+ ** This switch controls whether or not code will be added to **
+ ** the object program to produce execution-time logic traces. **
+ ** A specification of "@TRACE=NO" means no such code will be **
+ ** produced. By specifying "@TRACE=YES", code will be genera- **
+ ** ted to display procedure names as they are entered. A **
+ ** "@TRACE=ALL" specification will generate not only procedure **
+ ** traces (as "@TRACE=YES" would) but also statement-level **
+ ** traces too! All trace output is written to STDERR, so **
+ ** adding a "2>file" to the execution of the program will pipe **
+ ** the trace output to a file. You may find it valuable to **
+ ** add your own DISPLAY statements to the debugging output via **
+ ** "DISPLAY xx UPON SYSERR" The SYSERR device corresponds to **
+ ** the Windows or UNIX STDERR device and will therefore honor **
+ ** any "2>file" placed at the end of your program's execution. **
+ ** Add a "D" in column 7 and you can control the generation or **
+ ** ignoring of these DISPLAY statements via the "@DEBUG" **
+ ** switch. **
+ ** **
+GC0410** @SOURCE=YES|NO **
+GC0410** == **
+GC0410** Use this switch to produce a source listing of the program, **
+GC0410** PROVIDED it compiles without errors. **
+ ** **
+GC0410** @XREF=YES|NO **
+GC0410** == **
+GC0410** Use this switch to produce a cross-reference listing of the **
+GC0410** program, PROVIDED it compiles without errors. **
+ *****************************************************************
+
+ 011-Init.
+ MOVE 1 TO I
+ .
+
+ 012-Extract-Kwd-And-Value.
+ PERFORM UNTIL I NOT < LENGTH(Command-Line-Args)
+ MOVE I TO J
+ UNSTRING Command-Line-Args
+ DELIMITED BY ALL SPACES
+ INTO Switch-Keyword-And-Value
+ WITH POINTER I
+ END-UNSTRING
+ IF Switch-Keyword-And-Value NOT = SPACES
+ UNSTRING Switch-Keyword-And-Value
+ DELIMITED BY '='
+ INTO Switch-Keyword, Switch-Value
+ END-UNSTRING
+ PERFORM 030-Process-Keyword
+ END-IF
+ END-PERFORM
+ .
+
+ 019-Done.
+ EXIT.
+
+ *****************************************************************
+ ** Since this program uses the SCREEN SECTION, it cannot do **
+ ** conventional console DISPLAY operations. This routine **
+ ** (which, I admit, is like using an H-bomb to hunt rabbits) **
+ ** will submit an "ECHO" command to the system to simulate a **
+ ** DISPLAY. **
+ *****************************************************************
+ 021-Build-And-Issue-Command.
+ DISPLAY
+ Output-Message
+ END-DISPLAY
+ .
+
+ 029-Done.
+ EXIT.
+ /
+ 030-Process-Keyword SECTION.
+ *****************************************************************
+ ** Process a single KEYWORD=VALUE item. **
+ *****************************************************************
+
+ 031-Init.
+ MOVE UPPER-CASE(Switch-Keyword) TO Switch-Keyword
+ SET 88-Switch-Is-Good TO TRUE
+ .
+
+ 032-Process.
+ EVALUATE TRUE
+ WHEN Switch-Is-EXTRA
+GC0410 MOVE J TO I
+ UNSTRING Command-Line-Args DELIMITED BY '='
+ INTO Dummy, S-EXTRA
+GC0410 WITH POINTER I
+GC0410 END-UNSTRING
+ MOVE LENGTH(Command-Line-Args) TO I
+ WHEN Switch-Is-CONFIG
+ MOVE 'CONFIG' TO Switch-Keyword
+ MOVE UPPER-CASE(Switch-Value)
+ TO Switch-Value
+ EVALUATE Switch-Value
+ WHEN 'BS2000'
+ MOVE SPACES TO S-CfgS
+ MOVE Selection-Char TO S-Cfg-BS2000
+ WHEN 'COBOL85'
+ MOVE SPACES TO S-CfgS
+ MOVE Selection-Char TO S-Cfg-COBOL85
+ WHEN 'COBOL2002'
+ MOVE SPACES TO S-CfgS
+ MOVE Selection-Char TO S-Cfg-COBOL2002
+ WHEN 'DEFAULT'
+ MOVE SPACES TO S-CfgS
+ MOVE Selection-Char TO S-Cfg-DEFAULT
+ WHEN 'IBM'
+ MOVE SPACES TO S-CfgS
+ MOVE Selection-Char TO S-Cfg-IBM
+ WHEN 'MF'
+ MOVE SPACES TO S-CfgS
+ MOVE Selection-Char TO S-Cfg-MF
+ WHEN 'MVS'
+ MOVE SPACES TO S-CfgS
+ MOVE Selection-Char TO S-Cfg-MVS
+ WHEN OTHER
+ MOVE 'An invalid /CONFIG switch value ' &
+ 'was specified on the command line ' &
+ '- ignored'
+ TO Output-Message
+ END-EVALUATE
+ WHEN Switch-Is-DEBUG
+ MOVE 'DEBUG' TO Switch-Keyword
+ MOVE UPPER-CASE(Switch-Value)
+ TO Switch-Value
+ PERFORM 040-Process-Yes-No-Value
+ IF 88-Switch-Is-Good
+ MOVE SV-1 TO S-DEBUG
+ END-IF
+GC0410 WHEN Switch-Is-DLL
+GC0410 MOVE 'DLL' TO Switch-Keyword
+GC0410 MOVE UPPER-CASE(Switch-Value)
+GC0410 TO Switch-Value
+GC0410 PERFORM 040-Process-Yes-No-Value
+GC0410 IF 88-Switch-Is-Good
+GC0410 MOVE SV-1 TO S-DLL
+GC0410 END-IF
+ WHEN Switch-Is-EXECUTE
+ MOVE 'EXECUTE' TO Switch-Keyword
+ MOVE UPPER-CASE(Switch-Value)
+ TO Switch-Value
+ PERFORM 040-Process-Yes-No-Value
+ IF 88-Switch-Is-Good
+ MOVE SV-1 TO S-EXECUTE
+ END-IF
+ WHEN Switch-Is-NOTRUNC
+ MOVE 'NOTRUNC' TO Switch-Keyword
+ MOVE UPPER-CASE(Switch-Value)
+ TO Switch-Value
+ PERFORM 040-Process-Yes-No-Value
+ IF 88-Switch-Is-Good
+ MOVE SV-1 TO S-NOTRUNC
+ END-IF
+GC0410 WHEN Switch-Is-SOURCE
+GC0410 MOVE 'SOURCE' TO Switch-Keyword
+GC0410 MOVE UPPER-CASE(Switch-Value)
+GC0410 TO Switch-Value
+GC0410 PERFORM 050-Process-Yes-No-All
+GC0410 IF 88-Switch-Is-Good
+GC0410 MOVE SV-1 TO S-SOURCE
+GC0410 END-IF
+ WHEN Switch-Is-TRACE
+ MOVE 'TRACE' TO Switch-Keyword
+ MOVE UPPER-CASE(Switch-Value)
+ TO Switch-Value
+ PERFORM 050-Process-Yes-No-All
+ IF 88-Switch-Is-Good
+ MOVE SV-1 TO S-TRACE
+ END-IF
+GC0410 WHEN Switch-Is-XREF
+GC0410 MOVE 'XREF' TO Switch-Keyword
+GC0410 MOVE UPPER-CASE(Switch-Value)
+GC0410 TO Switch-Value
+GC0410 PERFORM 050-Process-Yes-No-All
+GC0410 IF 88-Switch-Is-Good
+GC0410 MOVE SV-1 TO S-XREF
+GC0410 END-IF
+ WHEN OTHER
+ MOVE SPACES TO Output-Message
+ STRING '"'
+ TRIM(Switch-Keyword)
+ '" is not a valid switch ' &
+ '- ignored'
+ DELIMITED SIZE
+ INTO Output-Message
+ END-STRING
+ SET 88-Switch-Is-Bad TO TRUE
+ END-EVALUATE
+ .
+
+ 039-Done.
+ EXIT.
+ /
+ 040-Process-Yes-No-Value SECTION.
+ *****************************************************************
+ ** Process a switch value of YES or NO **
+ *****************************************************************
+
+ 042-Process.
+ EVALUATE SV-1
+ WHEN 'Y'
+ MOVE 'YES' TO Switch-Value
+ WHEN 'N'
+ MOVE 'NO' To Switch-Value
+ WHEN OTHER
+ MOVE SPACES TO Output-Message
+ STRING '*ERROR: "' TRIM(Switch-Value)
+ '" is not a valid value for the "'
+ TRIM(Switch-Keyword) '" switch'
+ DELIMITED SPACES
+ INTO Output-Message
+ END-STRING
+ SET 88-Switch-Is-Bad TO TRUE
+ END-EVALUATE
+ .
+
+ 049-Done.
+ EXIT.
+ /
+ 050-Process-Yes-No-All SECTION.
+ *****************************************************************
+ ** Process a switch value of YES, NO or ALL **
+ *****************************************************************
+
+ 052-Process.
+ IF SV-1 = 'A'
+ MOVE 'ALL' TO Switch-Value
+ ELSE
+ PERFORM 040-Process-Yes-No-Value
+ END-IF
+ .
+
+ 059-Done.
+ EXIT.
+ /
+ 060-Process-Yes-No-Auto SECTION.
+ *****************************************************************
+ ** Process a switch value of YES, NO or AUTO **
+ *****************************************************************
+
+ 061-Init.
+ IF SV-1 = 'A'
+ PERFORM 070-Find-LINKAGE-SECTION
+ IF 88-Compile-As-Subpgm
+ MOVE 'Y' TO Switch-Value
+ ELSE
+ MOVE 'N' TO Switch-Value
+ END-IF
+ ELSE
+ PERFORM 040-Process-Yes-No-Value
+ END-IF
+ .
+ /
+ 070-Find-LINKAGE-SECTION SECTION.
+ *****************************************************************
+ ** Determine if the program being compiled is a MAIN program **
+ *****************************************************************
+
+ 071-Init.
+ OPEN INPUT Source-Code
+ SET 88-Compile-As-Mainpgm TO TRUE
+ SET 88-More-To-1st-Prog TO TRUE
+ PERFORM UNTIL 88-1st-Prog-Complete
+ READ Source-Code AT END
+ CLOSE Source-Code
+ EXIT SECTION
+ END-READ
+ CALL 'CHECKSOURCE' USING Source-Code-Record
+ F-Source-Record-Type
+ END-CALL
+ IF 88-Source-Rec-Ident
+ SET 88-1st-Prog-Complete TO TRUE
+ END-IF
+ END-PERFORM
+ .
+
+ 072-Process-Source.
+ SET 88-Source-Rec-IgnoCOB-COLOR-RED TO TRUE
+ PERFORM UNTIL 88-Source-Rec-Linkage
+ OR 88-Source-Rec-Ident
+ READ Source-Code AT END
+ CLOSE Source-Code
+ EXIT SECTION
+ END-READ
+ CALL 'CHECKSOURCE' USING Source-Code-Record
+ F-Source-Record-Type
+ END-CALL
+ END-PERFORM
+ CLOSE Source-Code
+ IF 88-Source-Rec-Linkage
+ SET 88-Compile-As-Subpgm TO TRUE
+ END-IF
+ .
+
+ 079-Done.
+ EXIT.
+ /
+ 100-Initialization SECTION.
+ *****************************************************************
+ ** Perform all program-wide initialization operations **
+ *****************************************************************
+
+
+GC0909 101-Determine-OS-Type.
+GC0909 CALL 'GETOSTYPE'
+GC0909 END-CALL
+GC0909 MOVE RETURN-CODE TO OS-Type
+GC0909 EVALUATE TRUE
+GC0909 WHEN OS-Unknown
+GC0909 MOVE '\' TO Dir-Char
+GC0909 MOVE 'Unknown' TO OS-Type-Literal
+GC0310 MOVE COB-SCR-F11 TO CK-S-F1
+GC0310 MOVE COB-SCR-F12 TO CK-S-F2
+GC0310 MOVE COB-SCR-F13 TO CK-S-F3
+GC0310 MOVE COB-SCR-F14 TO CK-S-F4
+GC0310 MOVE COB-SCR-F15 TO CK-S-F5
+GC0310 MOVE COB-SCR-F16 TO CK-S-F6
+GC0310 MOVE COB-SCR-F17 TO CK-S-F7
+GC0909 WHEN OS-Windows
+GC0909 MOVE '\' TO Dir-Char
+GC0909 MOVE 'Windows' TO OS-Type-Literal
+GC0310 MOVE COB-SCR-F13 TO CK-S-F1
+GC0310 MOVE COB-SCR-F14 TO CK-S-F2
+GC0310 MOVE COB-SCR-F15 TO CK-S-F3
+GC0310 MOVE COB-SCR-F16 TO CK-S-F4
+GC0310 MOVE COB-SCR-F17 TO CK-S-F5
+GC0310 MOVE COB-SCR-F18 TO CK-S-F6
+GC0310 MOVE COB-SCR-F19 TO CK-S-F7
+GC0909 WHEN OS-Cygwin
+GC0909 MOVE '/' TO Dir-Char
+GC0410 MOVE 'Cygwin' TO OS-Type-Literal
+GC0310 MOVE COB-SCR-F11 TO CK-S-F1
+GC0310 MOVE COB-SCR-F12 TO CK-S-F2
+GC0310 MOVE COB-SCR-F13 TO CK-S-F3
+GC0310 MOVE COB-SCR-F14 TO CK-S-F4
+GC0310 MOVE COB-SCR-F15 TO CK-S-F5
+GC0310 MOVE COB-SCR-F16 TO CK-S-F6
+GC0310 MOVE COB-SCR-F17 TO CK-S-F7
+GC0909 WHEN OS-UNIX
+GC0909 MOVE '/' TO Dir-Char
+GC0410 MOVE 'UNIX ' TO OS-Type-Literal
+GC0310 MOVE COB-SCR-F11 TO CK-S-F1
+GC0310 MOVE COB-SCR-F12 TO CK-S-F2
+GC0310 MOVE COB-SCR-F13 TO CK-S-F3
+GC0310 MOVE COB-SCR-F14 TO CK-S-F4
+GC0310 MOVE COB-SCR-F15 TO CK-S-F5
+GC0310 MOVE COB-SCR-F16 TO CK-S-F6
+GC0310 MOVE COB-SCR-F17 TO CK-S-F7
+GC0909 END-EVALUATE
+GC0909 .
+
+ 102-Set-Environment-Vars.
+ SET ENVIRONMENT 'COB_SCREEN_EXCEPTIONS' TO 'Y'
+ SET ENVIRONMENT 'COB_SCREEN_ESC' TO 'Y'
+ .
+
+ 103-Generate-Cobc-Output-Fn.
+ ACCEPT Env-TEMP
+ FROM ENVIRONMENT "TEMP"
+ END-ACCEPT
+ MOVE SPACES TO Cobc-Output-File
+ STRING TRIM(Env-TEMP,TRAILING)
+GC0909 Dir-Char
+GC0909 'OC-Messages.TXT'
+ DELIMITED SIZE
+ INTO Cobc-Output-File
+ END-STRING
+ .
+
+ 104-Generate-Banner-Line-Info.
+ MOVE WHEN-COMPILED (1:12) TO OC-Compiled
+ INSPECT OC-Compiled
+ REPLACING ALL '/' BY ':'
+ AFTER INITIAL SPACE
+ .
+
+ 105-Establish-Switch-Settings.
+ ACCEPT Command-Line-Args
+ FROM COMMAND-LINE
+ END-ACCEPT
+ MOVE TRIM(Command-Line-Args, Leading)
+ TO Command-Line-Args
+ MOVE 0 TO Tally
+GC0410 INSPECT Command-Line-Args TALLYING Tally FOR ALL '@'
+ IF Tally = 0
+ MOVE Command-Line-Args TO File-Name
+ MOVE SPACES TO Command-Line-Args
+ ELSE
+GC0410 UNSTRING Command-Line-Args DELIMITED BY '@'
+ INTO File-Name, Dummy
+ END-UNSTRING
+ INSPECT Command-Line-Args
+GC0410 REPLACING FIRST '@' BY LOW-VALUES
+ UNSTRING Command-Line-Args
+ DELIMITED BY LOW-VALUES
+ INTO Dummy, Cmd
+ END-UNSTRING
+ MOVE SPACES TO Command-Line-Args
+GC0410 STRING '@' Cmd DELIMITED SIZE
+ INTO Command-Line-Args
+ END-STRING
+ END-IF
+ IF File-Name = SPACES
+ DISPLAY
+ 'No program filename was specified'
+ END-DISPLAY
+ PERFORM 900-Terminate
+ END-IF
+ PERFORM 010-Parse-Args
+ IF S-SUBROUTINE = 'A'
+ MOVE 'S' TO Switch-Keyword
+ MOVE 'A' TO Switch-Value
+ PERFORM 070-Find-LINKAGE-SECTION
+ IF 88-Compile-As-Subpgm
+ MOVE 'Y' TO S-SUBROUTINE
+ ELSE
+ MOVE 'N' TO S-SUBROUTINE
+ END-IF
+ END-IF
+ INSPECT S-Yes-No-Switches REPLACING ALL 'Y' BY Selection-Char
+ INSPECT S-Yes-No-Switches REPLACING ALL 'N' BY ' '
+ .
+
+ 106-Determine-Folder-Path.
+ Move 256 TO I
+GC0909 IF OS-Cygwin AND File-Name (2:1) = ':'
+GC0909 MOVE '\' TO Dir-Char
+GC0909 END-IF
+ PERFORM UNTIL I = 0 OR FN-Char (I) = Dir-Char
+ SUBTRACT 1 FROM I
+ END-PERFORM
+ IF I = 0
+ MOVE SPACES TO Prog-Folder
+ MOVE File-Name TO Prog-File-Name
+ ELSE
+ MOVE '*' TO FN-Char (I)
+ UNSTRING File-Name DELIMITED BY '*'
+ INTO Prog-Folder
+ Prog-File-Name
+ END-UNSTRING
+ MOVE Dir-Char TO FN-Char (I)
+ END-IF
+ UNSTRING Prog-File-Name DELIMITED BY '.'
+ INTO Prog-Name, Prog-Extension
+ END-UNSTRING
+ IF Prog-Folder = SPACES
+ ACCEPT Prog-Folder
+ FROM ENVIRONMENT 'CD'
+ END-ACCEPT
+GC0909 ELSE
+GC0909 CALL "CBL_CHANGE_DIR"
+GC0909 USING TRIM(Prog-Folder,TRAILING)
+GC0909 END-CALL
+ END-IF
+GC0909 IF OS-Cygwin AND File-Name (2:1) = ':'
+GC0909 MOVE '/' TO Dir-Char
+GC0909 END-IF
+ .
+
+GC0909 107-Other.
+GC0909 MOVE ALL LD-Horiz-Line TO Horizontal-Line.
+GC0410 MOVE CONCATENATE(' OCic for ',
+GC0410 TRIM(OS-Type-Literal,Trailing),
+GC0410 ' Copyright (C) 2009-2010, Gary L. Cutler,',
+GC0410 ' GPL')
+GC0410 TO Output-Message.
+GC0909 .
+GC0909
+ 109-Done.
+ EXIT.
+ /
+ 200-Let-User-Set-Switches SECTION.
+ *****************************************************************
+ ** Show the user the current switch settings and allow them to **
+ ** be changed. **
+ *****************************************************************
+
+ 201-Init.
+ SET 88-Switch-Changes TO TRUE
+ .
+
+ 202-Show-And-Change-Switches.
+ PERFORM UNTIL 88-No-Switch-Changes
+ ACCEPT
+ Switches-Screen
+ END-ACCEPT
+ IF COB-CRT-STATUS > 0
+ EVALUATE COB-CRT-STATUS
+ WHEN COB-SCR-F1
+ IF S-DEBUG = SPACE
+ MOVE Selection-Char TO S-DEBUG
+ ELSE
+ MOVE ' ' TO S-DEBUG
+ END-IF
+ WHEN COB-SCR-F2
+ IF S-DLL = SPACE
+ MOVE Selection-Char TO S-DLL
+ ELSE
+ MOVE ' ' TO S-DLL
+ END-IF
+ WHEN COB-SCR-F3
+ IF S-SUBROUTINE = SPACE
+ MOVE Selection-Char TO S-SUBROUTINE
+ MOVE ' ' TO S-EXECUTE
+ ELSE
+ MOVE ' ' TO S-SUBROUTINE
+ END-IF
+ WHEN COB-SCR-F4
+ IF S-EXECUTE = SPACE
+ AND S-SUBROUTINE = SPACE
+ MOVE Selection-Char TO S-EXECUTE
+ ELSE
+ MOVE ' ' TO S-EXECUTE
+ END-IF
+ WHEN COB-SCR-F5
+ IF S-NOTRUNC = SPACE
+ MOVE Selection-Char TO S-NOTRUNC
+ ELSE
+ MOVE ' ' TO S-NOTRUNC
+ END-IF
+ WHEN COB-SCR-F6
+ IF S-TRACE = SPACE
+ MOVE Selection-Char TO S-TRACE
+ MOVE ' ' TO S-TRACEALL
+ ELSE
+ MOVE ' ' TO S-TRACE
+ END-IF
+ WHEN COB-SCR-F7
+ IF S-TRACEALL = SPACE
+ MOVE Selection-Char TO S-TRACEALL
+ MOVE ' ' TO S-TRACE
+ ELSE
+ MOVE ' ' TO S-TRACEALL
+ END-IF
+GC0410 WHEN COB-SCR-F8
+GC0410 IF S-SOURCE = SPACE
+GC0410 MOVE Selection-Char TO S-SOURCE
+GC0410 ELSE
+GC0410 MOVE ' ' TO S-SOURCE
+GC0410 END-IF
+GC0410 WHEN COB-SCR-F9
+GC0410 IF S-XREF = SPACE
+GC0410 MOVE Selection-Char TO S-XREF
+GC0410 ELSE
+GC0410 MOVE ' ' TO S-XREF
+GC0410 END-IF
+ WHEN COB-SCR-ESC
+ PERFORM 900-Terminate
+GC0310 WHEN CK-S-F1
+ MOVE SPACES TO S-CfgS
+ MOVE Selection-Char TO S-Cfg-BS2000
+GC0310 WHEN CK-S-F2
+ MOVE SPACES TO S-CfgS
+ MOVE Selection-Char TO S-Cfg-COBOL85
+GC0310 WHEN CK-S-F3
+ MOVE SPACES TO S-CfgS
+ MOVE Selection-Char TO S-Cfg-COBOL2002
+GC0310 WHEN CK-S-F4
+ MOVE SPACES TO S-CfgS
+ MOVE Selection-Char TO S-Cfg-DEFAULT
+GC0310 WHEN CK-S-F5
+ MOVE SPACES TO S-CfgS
+ MOVE Selection-Char TO S-Cfg-IBM
+GC0310 WHEN CK-S-F6
+ MOVE SPACES TO S-CfgS
+ MOVE Selection-Char TO S-Cfg-MF
+GC0310 WHEN CK-S-F7
+ MOVE SPACES TO S-CfgS
+ MOVE Selection-Char TO S-Cfg-MVS
+ WHEN OTHER
+ MOVE 'An unsupported key was pressed'
+ TO Output-Message
+ END-EVALUATE
+ ELSE
+ SET 88-No-Switch-Changes TO TRUE
+ END-IF
+ END-PERFORM
+ .
+
+ 209-Done.
+ EXIT.
+ /
+ 210-Run-Compiler SECTION.
+ *****************************************************************
+ ** Run the compiler using the switch settings we've prepared. **
+ *****************************************************************
+
+ 211-Init.
+ MOVE SPACES TO Cmd
+ Cobc-Cmd
+ Output-Message
+ DISPLAY
+ Switches-Screen
+ END-DISPLAY
+ MOVE 1 TO I
+ EVALUATE TRUE
+ WHEN S-Cfg-BS2000 NOT = SPACES
+ MOVE 'bs2000' TO Config-File
+ WHEN S-Cfg-COBOL85 NOT = SPACES
+ MOVE 'cobol85' TO Config-File
+ WHEN S-Cfg-COBOL2002 NOT = SPACES
+ MOVE 'cobol2002' TO Config-File
+ WHEN S-Cfg-IBM NOT = SPACES
+ MOVE 'ibm' TO Config-File
+ WHEN S-Cfg-MF NOT = SPACES
+ MOVE 'mf' TO Config-File
+ WHEN S-Cfg-MVS NOT = SPACES
+ MOVE 'mvs' TO Config-File
+ WHEN OTHER
+ MOVE 'default' TO Config-File
+ END-EVALUATE
+ .
+
+ 212-Build-Compile-Command.
+GC0909 MOVE SPACES TO Cobc-Cmd
+GC0909 STRING 'cobc -std='
+GC0909 TRIM(Config-File,TRAILING)
+GC0909 ' '
+GC0909 INTO Cobc-Cmd
+GC0909 WITH POINTER I
+GC0909 END-STRING
+ IF S-SUBROUTINE NOT = ' '
+ STRING '-m '
+ DELIMITED SIZE INTO Cobc-Cmd
+ WITH POINTER I
+ END-STRING
+ ELSE
+ STRING '-x '
+ DELIMITED SIZE INTO Cobc-Cmd
+ WITH POINTER I
+ END-STRING
+ END-IF
+ IF S-DEBUG NOT = ' '
+ STRING '-fdebugging-line '
+ DELIMITED SIZE INTO Cobc-Cmd
+ WITH POINTER I
+ END-STRING
+ END-IF
+ IF S-NOTRUNC NOT = ' '
+ STRING '-fnotrunc '
+ DELIMITED SIZE INTO Cobc-Cmd
+ WITH POINTER I
+ END-STRING
+ END-IF
+ IF S-TRACEALL NOT = ' '
+GC0809 STRING '-ftraceall '
+ DELIMITED SIZE INTO Cobc-Cmd
+ WITH POINTER I
+ END-STRING
+ END-IF
+ IF S-TRACE NOT = ' '
+ STRING '-ftrace '
+ DELIMITED SIZE INTO Cobc-Cmd
+ WITH POINTER I
+ END-STRING
+ END-IF
+
+GC0709 IF S-EXTRA > SPACES
+GC0709 STRING ' '
+GC0709 TRIM(S-Extra,TRAILING)
+GC0709 ' '
+GC0709 DELIMITED SIZE INTO Cobc-Cmd
+GC0709 WITH POINTER I
+GC0709 END-STRING
+GC0709 END-IF
+GC0909 STRING TRIM(Prog-File-Name,TRAILING)
+GC0909 DELIMITED SIZE INTO Cobc-Cmd
+GC0909 WITH POINTER I
+GC0909 END-STRING
+ .
+
+ 213-Run-Compiler.
+GC0410 MOVE ' Compiling...' TO Output-Message
+GC0410 DISPLAY
+GC0410 Switches-Screen
+GC0410 END-DISPLAY
+GC0609 SET 88-Output-File-Avail TO TRUE
+ MOVE SPACES TO Cmd
+ STRING TRIM(Cobc-Cmd,TRAILING)
+ ' 2>'
+ TRIM(Cobc-Output-File,TRAILING)
+ DELIMITED SIZE
+ INTO Cmd
+ END-STRING
+ CALL 'SYSTEM'
+ USING TRIM(Cmd,TRAILING)
+ END-CALL
+GC0909 IF RETURN-CODE = 0
+GC0909 SET 88-Compile-OK TO TRUE
+GC0909 ELSE
+GC0909 SET 88-Compile-Failed TO TRUE
+GC0909 END-IF
+GC0909 IF 88-Compile-OK
+GC0909 OPEN INPUT Cobc-Output
+GC0909 READ Cobc-Output
+GC0909 AT END
+GC0909 CONTINUE
+GC0909 NOT AT END
+GC0909 SET 88-Compile-OK-Warn TO TRUE
+GC0909 END-READ
+GC0909 CLOSE Cobc-Output
+GC0909 END-IF
+GC0909 MOVE SPACES TO Output-Message
+ IF 88-Compile-OK
+GC0909 MOVE ' Compilation Was Successful' TO Output-Message
+GC0909 DISPLAY
+GC0909 Switches-Screen
+GC0909 END-DISPLAY
+GC0909 CALL 'C$SLEEP'
+GC0909 USING 2
+GC0909 END-CALL
+GC0909 MOVE SPACES TO Output-Message
+GC0609 SET 88-Complete TO TRUE
+ ELSE
+GC0909 DISPLAY
+GC0909 Blank-Screen
+GC0909 END-DISPLAY
+GC0909 IF 88-Compile-OK-Warn
+GC0909 DISPLAY ' Compilation was successful, but ' &
+GC0909 'warnings were generated:'
+SCROLL* AT LINE 24 COLUMN 1
+SCROLL* WITH SCROLL UP 1 LINE
+GC0909 END-DISPLAY
+GC0909 ELSE
+GC0909 DISPLAY 'Compilation Failed:'
+SCROLL* AT LINE 24 COLUMN 1
+SCROLL* WITH SCROLL UP 1 LINE
+GC0909 END-DISPLAY
+GC0909 END-IF
+GC0609 SET 88-Compile-Failed TO TRUE
+GC0609 SET 88-Complete TO TRUE
+GC0909 DISPLAY ' '
+SCROLL* AT LINE 24 COLUMN 1
+SCROLL* WITH SCROLL UP 1 LINE
+GC0909 END-DISPLAY
+GC0909 OPEN INPUT Cobc-Output
+GC0909 PERFORM FOREVER
+GC0909 READ Cobc-Output AT END
+GC0909 EXIT PERFORM
+GC0909 END-READ
+GC0909 DISPLAY TRIM(Cobc-Output-Rec,TRAILING)
+SCROLL* AT LINE 24 COLUMN 1
+SCROLL* WITH SCROLL UP 1 LINE
+GC0909 END-DISPLAY
+GC0909 END-PERFORM
+GC0909 CLOSE Cobc-Output
+GC0909 DISPLAY ' '
+SCROLL* AT LINE 24 COLUMN 1
+SCROLL* WITH SCROLL UP 2 LINES
+GC0909 END-DISPLAY
+GC0909 DISPLAY 'Press ENTER to close:'
+SCROLL* AT LINE 24 COLUMN 1
+SCROLL* WITH SCROLL UP 1 LINE
+GC0909 END-DISPLAY
+GC0909 ACCEPT Dummy
+GC0909 FROM CONSOLE
+GC0909 END-ACCEPT
+GC0909 DISPLAY
+GC0909 Blank-Screen
+GC0909 END-DISPLAY
+ END-IF
+ .
+
+ 219-Done.
+ IF 88-Compile-Failed
+ PERFORM 900-Terminate
+ END-IF
+ .
+ /
+GC0410 220-Make-Listing SECTION.
+GC0410*****************************************************************
+GC0410** Generate a source and/or xref listing using XREF **
+GC0410*****************************************************************
+GC0410
+GC0410 221-Init.
+GC0410 MOVE ' Generating cross-reference listing...'
+GC0410 TO Output-Message
+GC0410 DISPLAY
+GC0410 Switches-Screen
+GC0410 END-DISPLAY
+GC0410 CALL "CBL_DELETE_FILE"
+GC0410 USING CONCATENATE(TRIM(Prog-Name,Trailing),".lst")
+GC0410 END-CALL
+GC0410 MOVE 0 TO RETURN-CODE
+GC0410 .
+GC0410
+GC0410 213-Run-OCXref.
+GC0410 MOVE SPACES TO Output-Message
+GC0410 CALL 'LISTING'
+GC0410 USING S-SOURCE
+GC0410 S-XREF
+GC0410 File-Name
+GC0410 ON EXCEPTION
+GC0410 MOVE ' LISTING module is not available'
+GC0410 TO Output-Message
+GC0410 MOVE 1 TO RETURN-CODE
+GC0410 END-CALL
+GC0410 IF RETURN-CODE = 0
+GC0410 MOVE ' Listing generated'
+GC0410 TO Output-Message
+GC0410 IF OS-Windows OR OS-Cygwin
+GC0410 MOVE SPACES TO Cmd
+GC0410 STRING
+GC0410 'cmd /c '
+GC0410 TRIM(Prog-Name,TRAILING)
+GC0410 '.lst'
+GC0410 DELIMITED SIZE INTO Cmd
+GC0410 END-STRING
+GC0410 CALL 'SYSTEM'
+GC0410 USING TRIM(Cmd,TRAILING)
+GC0410 END-CALL
+GC0410 END-IF
+GC0410 ELSE
+GC0410 IF Output-Message = SPACES
+GC0410 MOVE ' Listing generation failed'
+GC0410 TO Output-Message
+GC0410 END-IF
+GC0410 END-IF
+GC0410 DISPLAY
+GC0410 Switches-Screen
+GC0410 END-DISPLAY
+GC0410 CALL 'C$SLEEP'
+GC0410 USING 2
+GC0410 END-CALL
+GC0410 .
+ /
+ 230-Run-Program SECTION.
+ *****************************************************************
+ ** Run the compiled program **
+ *****************************************************************
+
+ 232-Build-Command.
+GC0909 MOVE SPACES TO Cmd
+GC0909 MOVE 1 TO I
+ IF S-SUBROUTINE NOT = ' '
+ OR S-DLL NOT = ' '
+ STRING 'cobcrun ' DELIMITED SIZE
+ INTO Cmd
+ WITH POINTER I
+ END-STRING
+ END-IF
+ IF Prog-Folder NOT = SPACES
+GC0909 IF OS-Cygwin AND Prog-Folder (2:1) = ':'
+GC0909 STRING '/cygdrive/'
+GC0909 INTO Cmd
+GC0909 WITH POINTER I
+GC0909 END-STRING
+GC0909 STRING LOWER-CASE(Prog-Folder (1:1))
+GC0909 INTO Cmd
+GC0909 WITH POINTER I
+GC0909 END-STRING
+GC0909 PERFORM VARYING J FROM 3 BY 1
+GC0909 UNTIL J > LENGTH(TRIM(Prog-Folder))
+GC0909 IF Prog-Folder (J:1) = '\'
+GC0909 STRING '/'
+GC0909 INTO Cmd
+GC0909 WITH POINTER I
+GC0909 END-STRING
+GC0909 ELSE
+GC0909 STRING Prog-Folder (J:1)
+GC0909 INTO Cmd
+GC0909 WITH POINTER I
+GC0909 END-STRING
+GC0909 END-IF
+GC0909 END-PERFORM
+GC0909 ELSE
+GC0410 STRING '"' TRIM(Prog-Folder,TRAILING)
+GC0909 INTO Cmd
+GC0909 WITH POINTER I
+GC0909 END-STRING
+GC0909 END-IF
+GC0909 STRING Dir-Char
+GC0909 INTO Cmd
+GC0909 WITH POINTER I
+GC0909 END-STRING
+GC0909 ELSE
+GC0909 IF OS-Cygwin OR OS-UNIX
+GC0909 STRING './'
+GC0909 INTO Cmd
+GC0909 WITH POINTER I
+GC0909 END-STRING
+GC0909 END-IF
+ END-IF
+GC0909 STRING TRIM(Prog-Name,TRAILING)
+GC0909 INTO Cmd
+GC0909 WITH POINTER I
+GC0909 END-STRING
+GC0909 IF S-SUBROUTINE = ' '
+GC0909 AND S-DLL NOT = ' '
+GC0909 STRING '.exe' DELIMITED SIZE
+ INTO Cmd
+ WITH POINTER I
+ END-STRING
+ END-IF
+ IF S-ARGS NOT = SPACES
+GC0809 STRING ' ' TRIM(S-ARGS,TRAILING)
+ INTO Cmd
+ WITH POINTER I
+ END-STRING
+ END-IF
+ IF OS-Unknown OR OS-Windows
+GC0410 STRING '"&&pause'
+ INTO Cmd
+ WITH POINTER I
+ END-STRING
+ ELSE
+ STRING ';echo "Press ENTER to close...";read'
+ INTO Cmd
+ WITH POINTER I
+ END-STRING
+ END-IF
+ .
+
+ 233-Run-Program.
+GC0909 DISPLAY
+GC0909 Blank-Screen
+GC0909 END-DISPLAY
+
+ CALL 'SYSTEM'
+ USING TRIM(Cmd,TRAILING)
+ END-CALL
+ PERFORM 900-Terminate
+ .
+
+ 239-Done.
+ EXIT.
+ /
+ 900-Terminate SECTION.
+ *****************************************************************
+ ** Display a message and halt the program **
+ *****************************************************************
+
+ 901-Display-Message.
+GC0909 IF Output-Message > SPACES
+GC0909 DISPLAY
+GC0909 Switches-Screen
+GC0909 END-DISPLAY
+GC0909 CALL 'C$SLEEP'
+GC0909 USING 2
+GC0909 END-CALL
+GC0909 END-IF
+ DISPLAY
+ Blank-Screen
+ END-DISPLAY
+ .
+
+ 909-Done.
+ GOBACK
+ .
+
+ END PROGRAM OCic.
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. GETOSTYPE.
+ *****************************************************************
+ ** This subprogram determine the OS type the program is run- **
+ ** ning under, passing that result back in RETURN-CODE as fol- **
+ ** lows: **
+ ** **
+ ** 0: Cannot be determined **
+ ** 1: Native Windows or Windows/MinGW **
+ ** 2: Cygwin **
+ ** 3: UNIX/Linux/MacOS **
+ *****************************************************************
+ ** DATE CHANGE DESCRIPTION **
+ ** ====== ==================================================== **
+ ** GC0909 Initial coding. **
+ *****************************************************************
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ REPOSITORY.
+ FUNCTION ALL INTRINSIC.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 Env-Path PIC X(1024).
+ 01 Tally USAGE BINARY-LONG.
+ PROCEDURE DIVISION.
+ 000-Main SECTION.
+ 010-Get-TEMP-Var.
+ MOVE SPACES TO Env-Path
+ ACCEPT Env-Path
+ FROM ENVIRONMENT "PATH"
+ ON EXCEPTION
+ MOVE 0 TO RETURN-CODE
+ GOBACK
+ END-ACCEPT
+ IF Env-Path = SPACES
+ MOVE 0 TO RETURN-CODE
+ ELSE
+ MOVE 0 TO Tally
+ INSPECT Env-Path
+ TALLYING Tally FOR ALL ";"
+ IF Tally = 0 *> Must be some form of UNIX
+ MOVE 0 TO Tally
+ INSPECT Env-Path
+ TALLYING TALLY FOR ALL "/cygdrive/"
+ IF Tally = 0 *> UNIX/MacOS
+ MOVE 3 TO RETURN-CODE
+ ELSE *> Cygwin
+ MOVE 2 TO RETURN-CODE
+ END-IF
+ ELSE *> Assume Windows[/MinGW]
+ MOVE 1 TO RETURN-CODE
+ END-IF
+ END-IF
+ GOBACK
+ .
+ END PROGRAM GETOSTYPE.
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. CHECKSOURCE.
+ *****************************************************************
+ ** This subprogram will scan a line of source code it is given **
+ ** looking for "LINKAGE SECTION" or "IDENTIFICATION DIVISION". **
+ ** **
+ ** ****NOTE**** ****NOTE**** ****NOTE**** ****NOTE*** **
+ ** **
+ ** These two strings must be found IN THEIR ENTIRETY within **
+ ** the 1st 80 columns of program source records, and cannot **
+ ** follow either a "*>" sequence OR a "*" in col 7. **
+ *****************************************************************
+ ** DATE CHANGE DESCRIPTION **
+ ** ====== ==================================================== **
+ ** GC0809 Initial coding. **
+ *****************************************************************
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ REPOSITORY.
+ FUNCTION ALL INTRINSIC.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 Compressed-Src.
+ 05 CS-Char OCCURS 80 TIMES PIC X(1).
+
+ 01 Flags.
+ 05 F-Found-SPACE PIC X(1).
+ 88 88-Skipping-SPACE VALUE 'Y'.
+ 88 88-Not-Skipping-SPACE VALUE 'N'.
+
+ 01 I USAGE BINARY-CHAR.
+
+ 01 J USAGE BINARY-CHAR.
+ LINKAGE SECTION.
+ 01 Argument-1.
+ 02 A1-Char OCCURS 80 TIMES PIC X(1).
+
+ 01 Argument-2 PIC X(1).
+ 88 88-A2-LINKAGE-SECTION VALUE 'L'.
+ 88 88-A2-IDENTIFICATION-DIVISION VALUE 'I'.
+ 88 88-A2-Nothing-Special VALUE ' '.
+ PROCEDURE DIVISION USING Argument-1, Argument-2.
+ 000-Main SECTION.
+
+ 010-Initialize.
+ SET 88-A2-Nothing-Special TO TRUE
+ IF A1-Char (7) = '*'
+ GOBACK
+ END-IF
+ .
+
+ 020-Compress-Multiple-SPACES.
+ SET 88-Not-Skipping-SPACE TO TRUE
+ MOVE 0 TO J
+ MOVE SPACES TO Compressed-Src
+ PERFORM VARYING I FROM 1 BY 1
+ UNTIL I > 80
+ IF A1-Char (I) = SPACE
+ IF 88-Not-Skipping-SPACE
+ ADD 1 TO J
+ MOVE UPPER-CASE(A1-Char (I)) TO CS-Char (J)
+ SET 88-Skipping-SPACE TO TRUE
+ END-IF
+ ELSE
+ SET 88-Not-Skipping-SPACE TO TRUE
+ ADD 1 TO J
+ MOVE A1-Char (I) TO CS-Char (J)
+ END-IF
+ END-PERFORM
+ .
+
+ 030-Scan-Compressed-Src.
+ PERFORM VARYING I FROM 1 BY 1
+ UNTIL I > 66
+ EVALUATE TRUE
+ WHEN CS-Char (I) = '*'
+ IF Compressed-Src (I : 2) = '*>'
+ GOBACK
+ END-IF
+ WHEN (CS-Char (I) = 'L') AND (I < 66)
+ IF Compressed-Src (I : 15) = 'LINKAGE SECTION'
+ SET 88-A2-LINKAGE-SECTION TO TRUE
+ GOBACK
+ END-IF
+ WHEN (CS-Char (I) = 'I') AND (I < 58)
+ IF Compressed-Src (I : 23) = 'IDENTIFICATION ' &
+ 'DIVISION'
+ SET 88-A2-IDENTIFICATION-DIVISION TO TRUE
+ GOBACK
+ END-IF
+ END-EVALUATE
+ END-PERFORM
+ .
+
+ 099-Never-Found-Either-One.
+ GOBACK
+ .
+ END PROGRAM CHECKSOURCE.
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. LISTING.
+ *****************************************************************
+ ** This subprogram generates a cross-reference listing of an **
+ ** OpenCOBOL program. **
+ ** **
+ ** Linkage: CALL "LISTING" USING <source> **
+ ** <xref> **
+ ** <filename> **
+ ** **
+ ** Where: **
+ ** <source> is a PIC X(1) flag indicating **
+ ** whether or not a source listing **
+ ** should be produced (space=NO, **
+ ** non-space=yes) **
+ ** <xref> is a PIC X(1) flag indicating **
+ ** whether or not an xref listing **
+ ** should be produced (space=NO, **
+ ** non-space=yes) **
+ ** <filename> is the [path]filename of the **
+ ** program being listed and/or **
+ ** xreffed in a PIC X(256) form. **
+ *****************************************************************
+ ** **
+ ** AUTHOR: GARY L. CUTLER **
+ ** CutlerGL@gmail.com **
+ ** Copyright (C) 2010, Gary L. Cutler, GPL **
+ ** **
+ ** DATE-WRITTEN: April 1, 2010 **
+ ** **
+ *****************************************************************
+ ** DATE CHANGE DESCRIPTION **
+ ** ====== ==================================================== **
+ ** GC0410 Initial coding **
+ ** GC0710 Handle duplicate data names (i.e. "CORRESPONDING" or **
+ ** qualified items) better; ignore "END PROGRAM" recs **
+ ** so program name doesn't appear in listing. **
+ *****************************************************************
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ REPOSITORY.
+ FUNCTION ALL INTRINSIC.
+ INPUT-OUTPUT SECTION.
+ FILE-CONTROL.
+ SELECT Expand-Code ASSIGN TO Expanded-Src-Filename
+ ORGANIZATION IS LINE SEQUENTIAL.
+ SELECT Report-File ASSIGN TO Report-Filename
+ ORGANIZATION IS LINE SEQUENTIAL.
+ SELECT Sort-File ASSIGN TO DISK.
+ SELECT Source-Code ASSIGN TO Src-Filename
+ ORGANIZATION IS LINE SEQUENTIAL.
+ DATA DIVISION.
+ FILE SECTION.
+ FD Expand-Code.
+ 01 Expand-Code-Rec.
+ 05 ECR-1 PIC X.
+ 05 ECR-2-256 PIC X(256).
+ 01 Expand-Code-Rec-Alt.
+ 05 ECR-1-128 PIC X(128).
+ 05 ECR-129-256 PIC X(128).
+
+ FD Report-File.
+ 01 Report-Rec PIC X(135).
+
+ SD Sort-File.
+ 01 Sort-Rec.
+ 05 SR-Prog-ID PIC X(15).
+ 05 SR-Token-UC PIC X(32).
+ 05 SR-Token PIC X(32).
+ 05 SR-Section PIC X(15).
+ 05 SR-Line-No-Def PIC 9(6).
+ 05 SR-Reference.
+ 10 SR-Line-No-Ref PIC 9(6).
+ 10 SR-Ref-Flag PIC X(1).
+
+ FD Source-Code.
+ 01 Source-Code-Rec.
+GC0410 05 SCR-1-128.
+GC0410 10 FILLER PIC X(6).
+GC0410 10 SCR-7 PIC X(1).
+GC0410 10 FILLER PIC X(121).
+ 05 SCR-129-256 PIC X(128).
+
+ WORKING-STORAGE SECTION.
+ 78 Line-Nos-Per-Rec VALUE 8.
+
+ 01 Cmd PIC X(256).
+
+ 01 Delim PIC X(2).
+
+ 01 Detail-Line-S.
+ 05 DLS-Line-No PIC ZZZZZ9.
+ 05 FILLER PIC X(1).
+ 05 DLS-Statement PIC X(128).
+
+ 01 Detail-Line-X.
+ 05 DLX-Prog-ID PIC X(15).
+ 05 FILLER PIC X(1).
+ 05 DLX-Token PIC X(32).
+ 05 FILLER PIC X(1).
+ 05 DLX-Line-No-Def PIC ZZZZZ9.
+ 05 FILLER PIC X(1).
+ 05 DLX-Section PIC X(15).
+ 05 FILLER PIC X(1).
+ 05 DLX-Reference OCCURS Line-Nos-Per-Rec TIMES.
+ 10 DLX-Line-No-Ref PIC ZZZZZ9.
+ 10 DLX-Ref-Flag PIC X(1).
+ 10 FILLER PIC X(1).
+
+ 01 Dummy PIC X(1).
+
+ 01 Env-TEMP PIC X(256).
+
+ 01 Expanded-Src-Filename PIC X(256).
+
+ 01 Filename PIC X(256).
+
+ 01 Flags.
+GC0710 05 F-Duplicate PIC X(1).
+ 05 F-First-Record PIC X(1).
+ 05 F-In-Which-Pgm PIC X(1).
+ 88 In-Main-Module VALUE 'M'.
+ 88 In-Copybook VALUE 'C'.
+ 05 F-Last-Token-Ended-Sent PIC X(1).
+ 05 F-Processing-PICTURE PIC X(1).
+ 05 F-Token-Ended-Sentence PIC X(1).
+GC0710 05 F-Verb-Has-Been-Found PIC X(1).
+
+ 01 Group-Indicators.
+ 05 GI-Prog-ID PIC X(15).
+ 05 GI-Token PIC X(32).
+
+ 01 Heading-1S.
+ 05 FILLER PIC X(125) VALUE
+ "OpenCOBOL 1.1 06FEB2009 Source Listing - " &
+ "OCic Copyright (C) 2009-2010, Gary L. Cutler, GPL".
+ 05 H1S-Date PIC 9999/99/99.
+
+ 01 Heading-1X.
+ 05 FILLER PIC X(125) VALUE
+ "OpenCOBOL 1.1 06FEB2009 Cross-Reference Listing - " &
+ "OCic Copyright (C) 2009-2010, Gary L. Cutler, GPL".
+ 05 H1X-Date PIC 9999/99/99.
+
+ 01 Heading-2 PIC X(135).
+
+ 01 Heading-4S PIC X(16) VALUE
+ "Line Statement".
+
+ 01 Heading-4X PIC X(96) VALUE
+ "PROGRAM-ID Identifier/Register/Function Defn Wher
+ - "e Defined References (* = Updated)".
+
+ 01 Heading-5S PIC X(135) VALUE
+ "====== =====================================================
+ - "============================================================
+ - "===============".
+
+ 01 Heading-5X PIC X(135) VALUE
+ "=============== ================================ ====== ====
+ - "=========== ================================================
+ - "===============".
+
+ 01 Held-Reference PIC X(100).
+
+ 01 I USAGE BINARY-LONG.
+
+ 01 J USAGE BINARY-LONG.
+
+ 01 Lines-Left USAGE BINARY-LONG.
+
+ 01 Lines-Per-Page USAGE BINARY-LONG.
+
+ 01 Lines-Per-Page-ENV PIC X(256).
+
+ 01 Num-UserNames USAGE BINARY-LONG.
+
+ 01 PIC-X10 PIC X(10).
+
+ 01 PIC-X32 PIC X(32).
+
+ 01 PIC-X256 PIC X(256).
+
+ 01 Program-Path PIC X(256).
+
+ 01 Report-Filename PIC X(256).
+
+ 01 Reserved-Words.
+ 05 FILLER PIC X(33) VALUE "IABS".
+ 05 FILLER PIC X(33) VALUE "VACCEPT".
+ 05 FILLER PIC X(33) VALUE " ACCESS".
+ 05 FILLER PIC X(33) VALUE "IACOS".
+ 05 FILLER PIC X(33) VALUE " ACTIVE-CLASS".
+ 05 FILLER PIC X(33) VALUE "VADD".
+ 05 FILLER PIC X(33) VALUE " ADDRESS".
+ 05 FILLER PIC X(33) VALUE " ADVANCING".
+ 05 FILLER PIC X(33) VALUE "KAFTER".
+ 05 FILLER PIC X(33) VALUE " ALIGNED".
+ 05 FILLER PIC X(33) VALUE " ALL".
+ 05 FILLER PIC X(33) VALUE "VALLOCATE".
+ 05 FILLER PIC X(33) VALUE " ALPHABET".
+ 05 FILLER PIC X(33) VALUE " ALPHABETIC".
+ 05 FILLER PIC X(33) VALUE " ALPHABETIC-LOWER".
+ 05 FILLER PIC X(33) VALUE " ALPHABETIC-UPPER".
+ 05 FILLER PIC X(33) VALUE " ALPHANUMERIC".
+ 05 FILLER PIC X(33) VALUE " ALPHANUMERIC-EDITED".
+ 05 FILLER PIC X(33) VALUE " ALSO".
+ 05 FILLER PIC X(33) VALUE "VALTER".
+ 05 FILLER PIC X(33) VALUE " ALTERNATE".
+ 05 FILLER PIC X(33) VALUE " AND".
+ 05 FILLER PIC X(33) VALUE "IANNUITY".
+ 05 FILLER PIC X(33) VALUE " ANY".
+ 05 FILLER PIC X(33) VALUE " ANYCASE".
+ 05 FILLER PIC X(33) VALUE " ARE".
+ 05 FILLER PIC X(33) VALUE " AREA".
+ 05 FILLER PIC X(33) VALUE " AREAS".
+ 05 FILLER PIC X(33) VALUE " ARGUMENT-NUMBER".
+ 05 FILLER PIC X(33) VALUE " ARGUMENT-VALUE".
+ 05 FILLER PIC X(33) VALUE " AS".
+ 05 FILLER PIC X(33) VALUE " ASCENDING".
+ 05 FILLER PIC X(33) VALUE "IASIN".
+ 05 FILLER PIC X(33) VALUE " ASSIGN".
+ 05 FILLER PIC X(33) VALUE " AT".
+ 05 FILLER PIC X(33) VALUE "IATAN".
+ 05 FILLER PIC X(33) VALUE " AUTHOR".
+ 05 FILLER PIC X(33) VALUE " AUTO".
+ 05 FILLER PIC X(33) VALUE " AUTO-SKIP".
+ 05 FILLER PIC X(33) VALUE " AUTOMATIC".
+ 05 FILLER PIC X(33) VALUE " AUTOTERMINATE".
+ 05 FILLER PIC X(33) VALUE " BACKGROUND-COLOR".
+ 05 FILLER PIC X(33) VALUE " BASED".
+ 05 FILLER PIC X(33) VALUE " BEEP".
+ 05 FILLER PIC X(33) VALUE " BEFORE".
+ 05 FILLER PIC X(33) VALUE " BELL".
+ 05 FILLER PIC X(33) VALUE " BINARY".
+ 05 FILLER PIC X(33) VALUE " BINARY-C-LONG".
+ 05 FILLER PIC X(33) VALUE " BINARY-CHAR".
+ 05 FILLER PIC X(33) VALUE " BINARY-DOUBLE".
+ 05 FILLER PIC X(33) VALUE " BINARY-LONG".
+ 05 FILLER PIC X(33) VALUE " BINARY-SHORT".
+ 05 FILLER PIC X(33) VALUE " BIT".
+ 05 FILLER PIC X(33) VALUE " BLANK".
+ 05 FILLER PIC X(33) VALUE " BLINK".
+ 05 FILLER PIC X(33) VALUE " BLOCK".
+ 05 FILLER PIC X(33) VALUE " BOOLEAN".
+ 05 FILLER PIC X(33) VALUE " BOTTOM".
+ 05 FILLER PIC X(33) VALUE "YBY".
+ 05 FILLER PIC X(33) VALUE "IBYTE-LENGTH".
+ 05 FILLER PIC X(33) VALUE "MC01".
+ 05 FILLER PIC X(33) VALUE "MC02".
+ 05 FILLER PIC X(33) VALUE "MC03".
+ 05 FILLER PIC X(33) VALUE "MC04".
+ 05 FILLER PIC X(33) VALUE "MC05".
+ 05 FILLER PIC X(33) VALUE "MC06".
+ 05 FILLER PIC X(33) VALUE "MC07".
+ 05 FILLER PIC X(33) VALUE "MC08".
+ 05 FILLER PIC X(33) VALUE "MC09".
+ 05 FILLER PIC X(33) VALUE "MC10".
+ 05 FILLER PIC X(33) VALUE "MC11".
+ 05 FILLER PIC X(33) VALUE "MC12".
+ 05 FILLER PIC X(33) VALUE "VCALL".
+ 05 FILLER PIC X(33) VALUE "VCANCEL".
+ 05 FILLER PIC X(33) VALUE " CF".
+ 05 FILLER PIC X(33) VALUE " CH".
+ 05 FILLER PIC X(33) VALUE " CHAINING".
+ 05 FILLER PIC X(33) VALUE "ICHAR".
+ 05 FILLER PIC X(33) VALUE " CHARACTER".
+ 05 FILLER PIC X(33) VALUE " CHARACTERS".
+ 05 FILLER PIC X(33) VALUE " CLASS".
+ 05 FILLER PIC X(33) VALUE " CLASS-ID".
+ 05 FILLER PIC X(33) VALUE "VCLOSE".
+ 05 FILLER PIC X(33) VALUE "ICOB-CRT-STATUS".
+ 05 FILLER PIC X(33) VALUE " CODE".
+ 05 FILLER PIC X(33) VALUE " CODE-SET".
+ 05 FILLER PIC X(33) VALUE " COL".
+ 05 FILLER PIC X(33) VALUE " COLLATING".
+ 05 FILLER PIC X(33) VALUE " COLS".
+ 05 FILLER PIC X(33) VALUE " COLUMN".
+ 05 FILLER PIC X(33) VALUE " COLUMNS".
+ 05 FILLER PIC X(33) VALUE "ICOMBINED-DATETIME".
+ 05 FILLER PIC X(33) VALUE " COMMA".
+ 05 FILLER PIC X(33) VALUE " COMMAND-LINE".
+ 05 FILLER PIC X(33) VALUE "VCOMMIT".
+ 05 FILLER PIC X(33) VALUE " COMMON".
+ 05 FILLER PIC X(33) VALUE " COMP".
+ 05 FILLER PIC X(33) VALUE " COMP-1".
+ 05 FILLER PIC X(33) VALUE " COMP-2".
+ 05 FILLER PIC X(33) VALUE " COMP-3".
+ 05 FILLER PIC X(33) VALUE " COMP-4".
+ 05 FILLER PIC X(33) VALUE " COMP-5".
+ 05 FILLER PIC X(33) VALUE " COMP-X".
+ 05 FILLER PIC X(33) VALUE " COMPUTATIONAL".
+ 05 FILLER PIC X(33) VALUE " COMPUTATIONAL-1".
+ 05 FILLER PIC X(33) VALUE " COMPUTATIONAL-2".
+ 05 FILLER PIC X(33) VALUE " COMPUTATIONAL-3".
+ 05 FILLER PIC X(33) VALUE " COMPUTATIONAL-4".
+ 05 FILLER PIC X(33) VALUE " COMPUTATIONAL-5".
+ 05 FILLER PIC X(33) VALUE " COMPUTATIONAL-X".
+ 05 FILLER PIC X(33) VALUE "VCOMPUTE".
+ 05 FILLER PIC X(33) VALUE "ICONCATENATE".
+ 05 FILLER PIC X(33) VALUE " CONDITION".
+ 05 FILLER PIC X(33) VALUE "KCONFIGURATION".
+ 05 FILLER PIC X(33) VALUE "MCONSOLE".
+ 05 FILLER PIC X(33) VALUE " CONSTANT".
+ 05 FILLER PIC X(33) VALUE " CONTAINS".
+ 05 FILLER PIC X(33) VALUE " CONTENT".
+ 05 FILLER PIC X(33) VALUE "VCONTINUE".
+ 05 FILLER PIC X(33) VALUE " CONTROL".
+ 05 FILLER PIC X(33) VALUE " CONTROLS".
+ 05 FILLER PIC X(33) VALUE "KCONVERTING".
+ 05 FILLER PIC X(33) VALUE " COPY".
+ 05 FILLER PIC X(33) VALUE " CORR".
+ 05 FILLER PIC X(33) VALUE " CORRESPONDING".
+ 05 FILLER PIC X(33) VALUE "ICOS".
+ 05 FILLER PIC X(33) VALUE "KCOUNT".
+ 05 FILLER PIC X(33) VALUE " CRT".
+ 05 FILLER PIC X(33) VALUE " CURRENCY".
+ 05 FILLER PIC X(33) VALUE "ICURRENT-DATE".
+ 05 FILLER PIC X(33) VALUE " CURSOR".
+ 05 FILLER PIC X(33) VALUE " CYCLE".
+ 05 FILLER PIC X(33) VALUE "KDATA".
+ 05 FILLER PIC X(33) VALUE " DATA-POINTER".
+ 05 FILLER PIC X(33) VALUE " DATE".
+ 05 FILLER PIC X(33) VALUE " DATE-COMPILED".
+ 05 FILLER PIC X(33) VALUE " DATE-MODIFIED".
+ 05 FILLER PIC X(33) VALUE "IDATE-OF-INTEGER".
+ 05 FILLER PIC X(33) VALUE "IDATE-TO-YYYYMMDD".
+ 05 FILLER PIC X(33) VALUE " DATE-WRITTEN".
+ 05 FILLER PIC X(33) VALUE " DAY".
+ 05 FILLER PIC X(33) VALUE "IDAY-OF-INTEGER".
+ 05 FILLER PIC X(33) VALUE " DAY-OF-WEEK".
+ 05 FILLER PIC X(33) VALUE "IDAY-TO-YYYYDDD".
+ 05 FILLER PIC X(33) VALUE " DE".
+ 05 FILLER PIC X(33) VALUE " DEBUGGING".
+ 05 FILLER PIC X(33) VALUE " DECIMAL-POINT".
+ 05 FILLER PIC X(33) VALUE " DECLARATIVES".
+ 05 FILLER PIC X(33) VALUE " DEFAULT".
+ 05 FILLER PIC X(33) VALUE "VDELETE".
+ 05 FILLER PIC X(33) VALUE " DELIMITED".
+ 05 FILLER PIC X(33) VALUE "KDELIMITER".
+ 05 FILLER PIC X(33) VALUE " DEPENDING".
+ 05 FILLER PIC X(33) VALUE " DESCENDING".
+ 05 FILLER PIC X(33) VALUE " DESTINATION".
+ 05 FILLER PIC X(33) VALUE " DETAIL".
+ 05 FILLER PIC X(33) VALUE " DISABLE".
+ 05 FILLER PIC X(33) VALUE " DISK".
+ 05 FILLER PIC X(33) VALUE "VDISPLAY".
+ 05 FILLER PIC X(33) VALUE "VDIVIDE".
+ 05 FILLER PIC X(33) VALUE "KDIVISION".
+ 05 FILLER PIC X(33) VALUE "KDOWN".
+ 05 FILLER PIC X(33) VALUE " DUPLICATES".
+ 05 FILLER PIC X(33) VALUE " DYNAMIC".
+ 05 FILLER PIC X(33) VALUE "IE".
+ 05 FILLER PIC X(33) VALUE " EBCDIC".
+ 05 FILLER PIC X(33) VALUE " EC".
+ 05 FILLER PIC X(33) VALUE "VELSE".
+GC0710 05 FILLER PIC X(33) VALUE "KEND".
+ 05 FILLER PIC X(33) VALUE " END-ACCEPT".
+ 05 FILLER PIC X(33) VALUE " END-ADD".
+ 05 FILLER PIC X(33) VALUE " END-CALL".
+ 05 FILLER PIC X(33) VALUE " END-COMPUTE".
+ 05 FILLER PIC X(33) VALUE " END-DELETE".
+ 05 FILLER PIC X(33) VALUE " END-DISPLAY".
+ 05 FILLER PIC X(33) VALUE " END-DIVIDE".
+ 05 FILLER PIC X(33) VALUE " END-EVALUATE".
+ 05 FILLER PIC X(33) VALUE " END-IF".
+ 05 FILLER PIC X(33) VALUE " END-MULTIPLY".
+ 05 FILLER PIC X(33) VALUE " END-OF-PAGE".
+ 05 FILLER PIC X(33) VALUE " END-PERFORM".
+ 05 FILLER PIC X(33) VALUE " END-READ".
+ 05 FILLER PIC X(33) VALUE " END-RETURN".
+ 05 FILLER PIC X(33) VALUE " END-REWRITE".
+ 05 FILLER PIC X(33) VALUE " END-SEARCH".
+ 05 FILLER PIC X(33) VALUE " END-START".
+ 05 FILLER PIC X(33) VALUE " END-STRING".
+ 05 FILLER PIC X(33) VALUE " END-SUBTRACT".
+ 05 FILLER PIC X(33) VALUE " END-UNSTRING".
+ 05 FILLER PIC X(33) VALUE " END-WRITE".
+ 05 FILLER PIC X(33) VALUE "VENTRY".
+ 05 FILLER PIC X(33) VALUE "KENVIRONMENT".
+ 05 FILLER PIC X(33) VALUE " ENVIRONMENT-NAME".
+ 05 FILLER PIC X(33) VALUE " ENVIRONMENT-VALUE".
+ 05 FILLER PIC X(33) VALUE " EO".
+ 05 FILLER PIC X(33) VALUE " EOL".
+ 05 FILLER PIC X(33) VALUE " EOP".
+ 05 FILLER PIC X(33) VALUE " EOS".
+ 05 FILLER PIC X(33) VALUE " EQUAL".
+ 05 FILLER PIC X(33) VALUE "KEQUALS".
+ 05 FILLER PIC X(33) VALUE " ERASE".
+ 05 FILLER PIC X(33) VALUE " ERROR".
+ 05 FILLER PIC X(33) VALUE " ESCAPE".
+ 05 FILLER PIC X(33) VALUE "VEVALUATE".
+ 05 FILLER PIC X(33) VALUE " EXCEPTION".
+ 05 FILLER PIC X(33) VALUE "IEXCEPTION-FILE".
+ 05 FILLER PIC X(33) VALUE "IEXCEPTION-LOCATION".
+ 05 FILLER PIC X(33) VALUE " EXCEPTION-OBJECT".
+ 05 FILLER PIC X(33) VALUE "IEXCEPTION-STATEMENT".
+ 05 FILLER PIC X(33) VALUE "IEXCEPTION-STATUS".
+ 05 FILLER PIC X(33) VALUE " EXCLUSIVE".
+ 05 FILLER PIC X(33) VALUE "VEXIT".
+ 05 FILLER PIC X(33) VALUE "IEXP".
+ 05 FILLER PIC X(33) VALUE "IEXP10".
+ 05 FILLER PIC X(33) VALUE " EXTEND".
+ 05 FILLER PIC X(33) VALUE " EXTERNAL".
+ 05 FILLER PIC X(33) VALUE "IFACTORIAL".
+ 05 FILLER PIC X(33) VALUE " FACTORY".
+ 05 FILLER PIC X(33) VALUE " FALSE".
+ 05 FILLER PIC X(33) VALUE "KFD".
+ 05 FILLER PIC X(33) VALUE "KFILE".
+ 05 FILLER PIC X(33) VALUE " FILE-CONTROL".
+ 05 FILLER PIC X(33) VALUE " FILE-ID".
+ 05 FILLER PIC X(33) VALUE " FILLER".
+ 05 FILLER PIC X(33) VALUE " FINAL".
+ 05 FILLER PIC X(33) VALUE " FIRST".
+ 05 FILLER PIC X(33) VALUE " FLOAT-BINARY-16".
+ 05 FILLER PIC X(33) VALUE " FLOAT-BINARY-34".
+ 05 FILLER PIC X(33) VALUE " FLOAT-BINARY-7".
+ 05 FILLER PIC X(33) VALUE " FLOAT-DECIMAL-16".
+ 05 FILLER PIC X(33) VALUE " FLOAT-DECIMAL-34".
+ 05 FILLER PIC X(33) VALUE " FLOAT-EXTENDED".
+ 05 FILLER PIC X(33) VALUE " FLOAT-LONG".
+ 05 FILLER PIC X(33) VALUE " FLOAT-SHORT".
+ 05 FILLER PIC X(33) VALUE " FOOTING".
+ 05 FILLER PIC X(33) VALUE " FOR".
+ 05 FILLER PIC X(33) VALUE " FOREGROUND-COLOR".
+ 05 FILLER PIC X(33) VALUE " FOREVER".
+ 05 FILLER PIC X(33) VALUE " FORMAT".
+ 05 FILLER PIC X(33) VALUE "MFORMFEED".
+ 05 FILLER PIC X(33) VALUE "IFRACTION-PART".
+ 05 FILLER PIC X(33) VALUE "VFREE".
+ 05 FILLER PIC X(33) VALUE " FROM".
+ 05 FILLER PIC X(33) VALUE " FULL".
+ 05 FILLER PIC X(33) VALUE " FUNCTION".
+ 05 FILLER PIC X(33) VALUE " FUNCTION-ID".
+ 05 FILLER PIC X(33) VALUE " FUNCTION-POINTER".
+ 05 FILLER PIC X(33) VALUE "VGENERATE".
+ 05 FILLER PIC X(33) VALUE " GET".
+ 05 FILLER PIC X(33) VALUE "KGIVING".
+ 05 FILLER PIC X(33) VALUE " GLOBAL".
+ 05 FILLER PIC X(33) VALUE "VGO".
+ 05 FILLER PIC X(33) VALUE "VGOBACK".
+ 05 FILLER PIC X(33) VALUE " GREATER".
+ 05 FILLER PIC X(33) VALUE " GROUP".
+ 05 FILLER PIC X(33) VALUE " GROUP-USAGE".
+ 05 FILLER PIC X(33) VALUE " HEADING".
+ 05 FILLER PIC X(33) VALUE " HIGH-VALUE".
+ 05 FILLER PIC X(33) VALUE " HIGH-VALUES".
+ 05 FILLER PIC X(33) VALUE " HIGHLIGHT".
+ 05 FILLER PIC X(33) VALUE " I-O".
+ 05 FILLER PIC X(33) VALUE " I-O-CONTROL".
+ 05 FILLER PIC X(33) VALUE "KID".
+ 05 FILLER PIC X(33) VALUE "KIDENTIFICATION".
+ 05 FILLER PIC X(33) VALUE "VIF".
+ 05 FILLER PIC X(33) VALUE " IGNORE".
+ 05 FILLER PIC X(33) VALUE " IGNORING".
+ 05 FILLER PIC X(33) VALUE " IN".
+ 05 FILLER PIC X(33) VALUE " INDEX".
+ 05 FILLER PIC X(33) VALUE "KINDEXED".
+ 05 FILLER PIC X(33) VALUE " INDICATE".
+ 05 FILLER PIC X(33) VALUE " INFINITY".
+ 05 FILLER PIC X(33) VALUE " INHERITS".
+ 05 FILLER PIC X(33) VALUE " INITIAL".
+ 05 FILLER PIC X(33) VALUE " INITIALISED".
+ 05 FILLER PIC X(33) VALUE "VINITIALIZE".
+ 05 FILLER PIC X(33) VALUE " INITIALIZED".
+ 05 FILLER PIC X(33) VALUE "VINITIATE".
+ 05 FILLER PIC X(33) VALUE " INPUT".
+ 05 FILLER PIC X(33) VALUE "KINPUT-OUTPUT".
+ 05 FILLER PIC X(33) VALUE "VINSPECT".
+ 05 FILLER PIC X(33) VALUE " INSTALLATION".
+ 05 FILLER PIC X(33) VALUE "IINTEGER".
+ 05 FILLER PIC X(33) VALUE "IINTEGER-OF-DATE".
+ 05 FILLER PIC X(33) VALUE "IINTEGER-OF-DAY".
+ 05 FILLER PIC X(33) VALUE "IINTEGER-PART".
+ 05 FILLER PIC X(33) VALUE " INTERFACE".
+ 05 FILLER PIC X(33) VALUE " INTERFACE-ID".
+ 05 FILLER PIC X(33) VALUE "KINTO".
+ 05 FILLER PIC X(33) VALUE " INTRINSIC".
+ 05 FILLER PIC X(33) VALUE " INVALID".
+ 05 FILLER PIC X(33) VALUE " INVOKE".
+ 05 FILLER PIC X(33) VALUE " IS".
+ 05 FILLER PIC X(33) VALUE " JUST".
+ 05 FILLER PIC X(33) VALUE " JUSTIFIED".
+ 05 FILLER PIC X(33) VALUE " KEY".
+ 05 FILLER PIC X(33) VALUE " LABEL".
+ 05 FILLER PIC X(33) VALUE " LAST".
+ 05 FILLER PIC X(33) VALUE " LEADING".
+ 05 FILLER PIC X(33) VALUE " LEFT".
+ 05 FILLER PIC X(33) VALUE " LEFT-JUSTIFY".
+ 05 FILLER PIC X(33) VALUE "ILENGTH".
+ 05 FILLER PIC X(33) VALUE " LESS".
+ 05 FILLER PIC X(33) VALUE " LIMIT".
+ 05 FILLER PIC X(33) VALUE " LIMITS".
+ 05 FILLER PIC X(33) VALUE " LINAGE".
+ 05 FILLER PIC X(33) VALUE "ILINAGE-COUNTER".
+ 05 FILLER PIC X(33) VALUE " LINE".
+ 05 FILLER PIC X(33) VALUE " LINE-COUNTER".
+ 05 FILLER PIC X(33) VALUE " LINES".
+ 05 FILLER PIC X(33) VALUE "KLINKAGE".
+ 05 FILLER PIC X(33) VALUE "KLOCAL-STORAGE".
+ 05 FILLER PIC X(33) VALUE " LOCALE".
+ 05 FILLER PIC X(33) VALUE "ILOCALE-DATE".
+ 05 FILLER PIC X(33) VALUE "ILOCALE-TIME".
+ 05 FILLER PIC X(33) VALUE "ILOCALE-TIME-FROM-SECONDS".
+ 05 FILLER PIC X(33) VALUE " LOCK".
+ 05 FILLER PIC X(33) VALUE "ILOG".
+ 05 FILLER PIC X(33) VALUE "ILOG10".
+ 05 FILLER PIC X(33) VALUE " LOW-VALUE".
+ 05 FILLER PIC X(33) VALUE " LOW-VALUES".
+ 05 FILLER PIC X(33) VALUE " LOWER".
+ 05 FILLER PIC X(33) VALUE "ILOWER-CASE".
+ 05 FILLER PIC X(33) VALUE " LOWLIGHT".
+ 05 FILLER PIC X(33) VALUE " MANUAL".
+ 05 FILLER PIC X(33) VALUE "IMAX".
+ 05 FILLER PIC X(33) VALUE "IMEAN".
+ 05 FILLER PIC X(33) VALUE "IMEDIAN".
+ 05 FILLER PIC X(33) VALUE " MEMORY".
+ 05 FILLER PIC X(33) VALUE "VMERGE".
+ 05 FILLER PIC X(33) VALUE " METHOD".
+ 05 FILLER PIC X(33) VALUE " METHOD-ID".
+ 05 FILLER PIC X(33) VALUE "IMIDRANGE".
+ 05 FILLER PIC X(33) VALUE "IMIN".
+ 05 FILLER PIC X(33) VALUE " MINUS".
+ 05 FILLER PIC X(33) VALUE "IMOD".
+ 05 FILLER PIC X(33) VALUE " MODE".
+ 05 FILLER PIC X(33) VALUE "VMOVE".
+ 05 FILLER PIC X(33) VALUE " MULTIPLE".
+ 05 FILLER PIC X(33) VALUE "VMULTIPLY".
+ 05 FILLER PIC X(33) VALUE " NATIONAL".
+ 05 FILLER PIC X(33) VALUE " NATIONAL-EDITED".
+ 05 FILLER PIC X(33) VALUE " NATIVE".
+ 05 FILLER PIC X(33) VALUE " NEGATIVE".
+ 05 FILLER PIC X(33) VALUE " NESTED".
+ 05 FILLER PIC X(33) VALUE "VNEXT".
+ 05 FILLER PIC X(33) VALUE " NO".
+ 05 FILLER PIC X(33) VALUE " NOT".
+ 05 FILLER PIC X(33) VALUE " NULL".
+ 05 FILLER PIC X(33) VALUE " NULLS".
+ 05 FILLER PIC X(33) VALUE " NUMBER".
+ 05 FILLER PIC X(33) VALUE "INUMBER-OF-CALL-PARAMETERS".
+ 05 FILLER PIC X(33) VALUE " NUMBERS".
+ 05 FILLER PIC X(33) VALUE " NUMERIC".
+ 05 FILLER PIC X(33) VALUE " NUMERIC-EDITED".
+ 05 FILLER PIC X(33) VALUE "INUMVAL".
+ 05 FILLER PIC X(33) VALUE "INUMVAL-C".
+ 05 FILLER PIC X(33) VALUE " OBJECT".
+ 05 FILLER PIC X(33) VALUE " OBJECT-COMPUTER".
+ 05 FILLER PIC X(33) VALUE " OBJECT-REFERENCE".
+ 05 FILLER PIC X(33) VALUE " OCCURS".
+ 05 FILLER PIC X(33) VALUE " OF".
+ 05 FILLER PIC X(33) VALUE " OFF".
+ 05 FILLER PIC X(33) VALUE " OMITTED".
+ 05 FILLER PIC X(33) VALUE " ON".
+ 05 FILLER PIC X(33) VALUE " ONLY".
+ 05 FILLER PIC X(33) VALUE "VOPEN".
+ 05 FILLER PIC X(33) VALUE " OPTIONAL".
+ 05 FILLER PIC X(33) VALUE " OPTIONS".
+ 05 FILLER PIC X(33) VALUE " OR".
+ 05 FILLER PIC X(33) VALUE "IORD".
+ 05 FILLER PIC X(33) VALUE "IORD-MAX".
+ 05 FILLER PIC X(33) VALUE "IORD-MIN".
+ 05 FILLER PIC X(33) VALUE " ORDER".
+ 05 FILLER PIC X(33) VALUE " ORGANIZATION".
+ 05 FILLER PIC X(33) VALUE " OTHER".
+ 05 FILLER PIC X(33) VALUE " OUTPUT".
+ 05 FILLER PIC X(33) VALUE " OVERFLOW".
+ 05 FILLER PIC X(33) VALUE " OVERLINE".
+ 05 FILLER PIC X(33) VALUE " OVERRIDE".
+ 05 FILLER PIC X(33) VALUE " PACKED-DECIMAL".
+ 05 FILLER PIC X(33) VALUE " PADDING".
+ 05 FILLER PIC X(33) VALUE " PAGE".
+ 05 FILLER PIC X(33) VALUE " PAGE-COUNTER".
+ 05 FILLER PIC X(33) VALUE " PARAGRAPH".
+ 05 FILLER PIC X(33) VALUE "VPERFORM".
+ 05 FILLER PIC X(33) VALUE " PF".
+ 05 FILLER PIC X(33) VALUE " PH".
+ 05 FILLER PIC X(33) VALUE "IPI".
+ 05 FILLER PIC X(33) VALUE "KPIC".
+ 05 FILLER PIC X(33) VALUE "KPICTURE".
+ 05 FILLER PIC X(33) VALUE " PLUS".
+ 05 FILLER PIC X(33) VALUE "KPOINTER".
+ 05 FILLER PIC X(33) VALUE " POSITION".
+ 05 FILLER PIC X(33) VALUE " POSITIVE".
+ 05 FILLER PIC X(33) VALUE " PRESENT".
+ 05 FILLER PIC X(33) VALUE "IPRESENT-VALUE".
+ 05 FILLER PIC X(33) VALUE " PREVIOUS".
+ 05 FILLER PIC X(33) VALUE "MPRINTER".
+ 05 FILLER PIC X(33) VALUE " PRINTING".
+ 05 FILLER PIC X(33) VALUE "KPROCEDURE".
+ 05 FILLER PIC X(33) VALUE " PROCEDURE-POINTER".
+ 05 FILLER PIC X(33) VALUE " PROCEDURES".
+ 05 FILLER PIC X(33) VALUE " PROCEED".
+ 05 FILLER PIC X(33) VALUE " PROGRAM".
+ 05 FILLER PIC X(33) VALUE "KPROGRAM-ID".
+ 05 FILLER PIC X(33) VALUE " PROGRAM-POINTER".
+ 05 FILLER PIC X(33) VALUE " PROMPT".
+ 05 FILLER PIC X(33) VALUE " PROPERTY".
+ 05 FILLER PIC X(33) VALUE " PROTOTYPE".
+ 05 FILLER PIC X(33) VALUE " QUOTE".
+ 05 FILLER PIC X(33) VALUE " QUOTES".
+ 05 FILLER PIC X(33) VALUE " RAISE".
+ 05 FILLER PIC X(33) VALUE " RAISING".
+ 05 FILLER PIC X(33) VALUE "IRANDOM".
+ 05 FILLER PIC X(33) VALUE "IRANGE".
+ 05 FILLER PIC X(33) VALUE " RD".
+ 05 FILLER PIC X(33) VALUE "VREAD".
+ 05 FILLER PIC X(33) VALUE "VREADY".
+ 05 FILLER PIC X(33) VALUE " RECORD".
+ 05 FILLER PIC X(33) VALUE " RECORDING".
+ 05 FILLER PIC X(33) VALUE " RECORDS".
+ 05 FILLER PIC X(33) VALUE " RECURSIVE".
+ 05 FILLER PIC X(33) VALUE "KREDEFINES".
+ 05 FILLER PIC X(33) VALUE " REEL".
+ 05 FILLER PIC X(33) VALUE " REFERENCE".
+ 05 FILLER PIC X(33) VALUE " RELATIVE".
+ 05 FILLER PIC X(33) VALUE "VRELEASE".
+ 05 FILLER PIC X(33) VALUE "IREM".
+ 05 FILLER PIC X(33) VALUE " REMAINDER".
+ 05 FILLER PIC X(33) VALUE " REMARKS".
+ 05 FILLER PIC X(33) VALUE " REMOVAL".
+ 05 FILLER PIC X(33) VALUE "KRENAMES".
+ 05 FILLER PIC X(33) VALUE "KREPLACING".
+ 05 FILLER PIC X(33) VALUE "KREPORT".
+ 05 FILLER PIC X(33) VALUE " REPORTING".
+ 05 FILLER PIC X(33) VALUE " REPORTS".
+ 05 FILLER PIC X(33) VALUE " REPOSITORY".
+ 05 FILLER PIC X(33) VALUE " REPRESENTS-NOT-A-NUMBER".
+ 05 FILLER PIC X(33) VALUE " REQUIRED".
+ 05 FILLER PIC X(33) VALUE " RESERVE".
+ 05 FILLER PIC X(33) VALUE " RESUME".
+ 05 FILLER PIC X(33) VALUE " RETRY".
+ 05 FILLER PIC X(33) VALUE "VRETURN".
+ 05 FILLER PIC X(33) VALUE "IRETURN-CODE".
+ 05 FILLER PIC X(33) VALUE "KRETURNING".
+ 05 FILLER PIC X(33) VALUE "IREVERSE".
+ 05 FILLER PIC X(33) VALUE " REVERSE-VIDEO".
+ 05 FILLER PIC X(33) VALUE " REWIND".
+ 05 FILLER PIC X(33) VALUE "VREWRITE".
+ 05 FILLER PIC X(33) VALUE " RF".
+ 05 FILLER PIC X(33) VALUE " RH".
+ 05 FILLER PIC X(33) VALUE " RIGHT".
+ 05 FILLER PIC X(33) VALUE " RIGHT-JUSTIFY".
+ 05 FILLER PIC X(33) VALUE "VROLLBACK".
+ 05 FILLER PIC X(33) VALUE " ROUNDED".
+ 05 FILLER PIC X(33) VALUE " RUN".
+ 05 FILLER PIC X(33) VALUE " SAME".
+ 05 FILLER PIC X(33) VALUE "KSCREEN".
+ 05 FILLER PIC X(33) VALUE " SCROLL".
+ 05 FILLER PIC X(33) VALUE "KSD".
+ 05 FILLER PIC X(33) VALUE "VSEARCH".
+ 05 FILLER PIC X(33) VALUE "ISECONDS-FROM-FORMATTED-TIME".
+ 05 FILLER PIC X(33) VALUE "ISECONDS-PAST-MIDNIGHT".
+ 05 FILLER PIC X(33) VALUE "KSECTION".
+ 05 FILLER PIC X(33) VALUE " SECURE".
+ 05 FILLER PIC X(33) VALUE " SECURITY".
+ 05 FILLER PIC X(33) VALUE " SEGMENT-LIMIT".
+ 05 FILLER PIC X(33) VALUE " SELECT".
+ 05 FILLER PIC X(33) VALUE " SELF".
+ 05 FILLER PIC X(33) VALUE " SENTENCE".
+ 05 FILLER PIC X(33) VALUE " SEPARATE".
+ 05 FILLER PIC X(33) VALUE " SEQUENCE".
+ 05 FILLER PIC X(33) VALUE " SEQUENTIAL".
+ 05 FILLER PIC X(33) VALUE "VSET".
+ 05 FILLER PIC X(33) VALUE " SHARING".
+ 05 FILLER PIC X(33) VALUE "ISIGN".
+ 05 FILLER PIC X(33) VALUE " SIGNED".
+ 05 FILLER PIC X(33) VALUE " SIGNED-INT".
+ 05 FILLER PIC X(33) VALUE " SIGNED-LONG".
+ 05 FILLER PIC X(33) VALUE " SIGNED-SHORT".
+ 05 FILLER PIC X(33) VALUE "ISIN".
+ 05 FILLER PIC X(33) VALUE " SIZE".
+ 05 FILLER PIC X(33) VALUE "VSORT".
+ 05 FILLER PIC X(33) VALUE " SORT-MERGE".
+ 05 FILLER PIC X(33) VALUE "ISORT-RETURN".
+ 05 FILLER PIC X(33) VALUE " SOURCE".
+ 05 FILLER PIC X(33) VALUE " SOURCE-COMPUTER".
+ 05 FILLER PIC X(33) VALUE " SOURCES".
+ 05 FILLER PIC X(33) VALUE " SPACE".
+ 05 FILLER PIC X(33) VALUE " SPACE-FILL".
+ 05 FILLER PIC X(33) VALUE " SPACES".
+ 05 FILLER PIC X(33) VALUE " SPECIAL-NAMES".
+ 05 FILLER PIC X(33) VALUE "ISQRT".
+ 05 FILLER PIC X(33) VALUE " STANDARD".
+ 05 FILLER PIC X(33) VALUE " STANDARD-1".
+ 05 FILLER PIC X(33) VALUE " STANDARD-2".
+ 05 FILLER PIC X(33) VALUE "ISTANDARD-DEVIATION".
+ 05 FILLER PIC X(33) VALUE "VSTART".
+ 05 FILLER PIC X(33) VALUE " STATUS".
+ 05 FILLER PIC X(33) VALUE "VSTOP".
+ 05 FILLER PIC X(33) VALUE "ISTORED-CHAR-LENGTH".
+ 05 FILLER PIC X(33) VALUE "VSTRING".
+ 05 FILLER PIC X(33) VALUE "ISUBSTITUTE".
+ 05 FILLER PIC X(33) VALUE "ISUBSTITUTE-CASE".
+ 05 FILLER PIC X(33) VALUE "VSUBTRACT".
+ 05 FILLER PIC X(33) VALUE "ISUM".
+ 05 FILLER PIC X(33) VALUE " SUPER".
+ 05 FILLER PIC X(33) VALUE "VSUPPRESS".
+ 05 FILLER PIC X(33) VALUE "MSWITCH-1".
+ 05 FILLER PIC X(33) VALUE "MSWITCH-2".
+ 05 FILLER PIC X(33) VALUE "MSWITCH-3".
+ 05 FILLER PIC X(33) VALUE "MSWITCH-4".
+ 05 FILLER PIC X(33) VALUE "MSWITCH-5".
+ 05 FILLER PIC X(33) VALUE "MSWITCH-6".
+ 05 FILLER PIC X(33) VALUE "MSWITCH-7".
+ 05 FILLER PIC X(33) VALUE "MSWITCH-8".
+ 05 FILLER PIC X(33) VALUE " SYMBOLIC".
+ 05 FILLER PIC X(33) VALUE " SYNC".
+ 05 FILLER PIC X(33) VALUE " SYNCHRONIZED".
+ 05 FILLER PIC X(33) VALUE "MSYSERR".
+ 05 FILLER PIC X(33) VALUE "MSYSIN".
+ 05 FILLER PIC X(33) VALUE "MSYSIPT".
+ 05 FILLER PIC X(33) VALUE "MSYSLIST".
+ 05 FILLER PIC X(33) VALUE "MSYSLST".
+ 05 FILLER PIC X(33) VALUE "MSYSOUT".
+ 05 FILLER PIC X(33) VALUE " SYSTEM-DEFAULT".
+ 05 FILLER PIC X(33) VALUE " TABLE".
+ 05 FILLER PIC X(33) VALUE "KTALLYING".
+ 05 FILLER PIC X(33) VALUE "ITAN".
+ 05 FILLER PIC X(33) VALUE " TAPE".
+ 05 FILLER PIC X(33) VALUE "VTERMINATE".
+ 05 FILLER PIC X(33) VALUE " TEST".
+ 05 FILLER PIC X(33) VALUE "ITEST-DATE-YYYYMMDD".
+ 05 FILLER PIC X(33) VALUE "ITEST-DAY-YYYYDDD".
+ 05 FILLER PIC X(33) VALUE " THAN".
+ 05 FILLER PIC X(33) VALUE " THEN".
+ 05 FILLER PIC X(33) VALUE " THROUGH".
+ 05 FILLER PIC X(33) VALUE " THRU".
+ 05 FILLER PIC X(33) VALUE " TIME".
+ 05 FILLER PIC X(33) VALUE " TIMES".
+ 05 FILLER PIC X(33) VALUE "KTO".
+ 05 FILLER PIC X(33) VALUE " TOP".
+ 05 FILLER PIC X(33) VALUE " TRAILING".
+ 05 FILLER PIC X(33) VALUE " TRAILING-SIGN".
+ 05 FILLER PIC X(33) VALUE "VTRANSFORM".
+ 05 FILLER PIC X(33) VALUE "ITRIM".
+ 05 FILLER PIC X(33) VALUE " TRUE".
+ 05 FILLER PIC X(33) VALUE " TYPE".
+ 05 FILLER PIC X(33) VALUE " TYPEDEF".
+ 05 FILLER PIC X(33) VALUE " UNDERLINE".
+ 05 FILLER PIC X(33) VALUE " UNIT".
+ 05 FILLER PIC X(33) VALUE " UNIVERSAL".
+ 05 FILLER PIC X(33) VALUE "VUNLOCK".
+ 05 FILLER PIC X(33) VALUE " UNSIGNED".
+ 05 FILLER PIC X(33) VALUE " UNSIGNED-INT".
+ 05 FILLER PIC X(33) VALUE " UNSIGNED-LONG".
+ 05 FILLER PIC X(33) VALUE " UNSIGNED-SHORT".
+ 05 FILLER PIC X(33) VALUE "VUNSTRING".
+ 05 FILLER PIC X(33) VALUE " UNTIL".
+ 05 FILLER PIC X(33) VALUE "KUP".
+ 05 FILLER PIC X(33) VALUE " UPDATE".
+ 05 FILLER PIC X(33) VALUE " UPON".
+ 05 FILLER PIC X(33) VALUE " UPPER".
+ 05 FILLER PIC X(33) VALUE "IUPPER-CASE".
+ 05 FILLER PIC X(33) VALUE " USAGE".
+ 05 FILLER PIC X(33) VALUE "VUSE".
+ 05 FILLER PIC X(33) VALUE " USER-DEFAULT".
+ 05 FILLER PIC X(33) VALUE "KUSING".
+ 05 FILLER PIC X(33) VALUE " VAL-STATUS".
+ 05 FILLER PIC X(33) VALUE " VALID".
+ 05 FILLER PIC X(33) VALUE " VALIDATE".
+ 05 FILLER PIC X(33) VALUE " VALIDATE-STATUS".
+ 05 FILLER PIC X(33) VALUE " VALUE".
+ 05 FILLER PIC X(33) VALUE " VALUES".
+ 05 FILLER PIC X(33) VALUE "IVARIANCE".
+ 05 FILLER PIC X(33) VALUE "KVARYING".
+ 05 FILLER PIC X(33) VALUE " WAIT".
+ 05 FILLER PIC X(33) VALUE "VWHEN".
+ 05 FILLER PIC X(33) VALUE "IWHEN-COMPILED".
+ 05 FILLER PIC X(33) VALUE " WITH".
+ 05 FILLER PIC X(33) VALUE " WORDS".
+ 05 FILLER PIC X(33) VALUE "KWORKING-STORAGE".
+ 05 FILLER PIC X(33) VALUE "VWRITE".
+ 05 FILLER PIC X(33) VALUE "IYEAR-TO-YYYY".
+ 05 FILLER PIC X(33) VALUE " YYYYDDD".
+ 05 FILLER PIC X(33) VALUE " YYYYMMDD".
+ 05 FILLER PIC X(33) VALUE " ZERO".
+ 05 FILLER PIC X(33) VALUE " ZERO-FILL".
+ 05 FILLER PIC X(33) VALUE " ZEROES".
+ 05 FILLER PIC X(33) VALUE " ZEROS".
+ 01 Reserved-Word-Table REDEFINES Reserved-Words.
+ 05 Reserved-Word OCCURS 591 TIMES
+ ASCENDING KEY RW-Word
+ INDEXED RW-Idx.
+ 10 RW-Type PIC X(1).
+ 10 RW-Word PIC X(32).
+
+ 01 Saved-Section PIC X(15).
+
+ 01 Search-Token PIC X(32).
+
+ 01 Source-Line-No PIC 9(6).
+
+ 01 Src-Ptr USAGE BINARY-LONG.
+
+ 01 Syntax-Parsing-Items.
+ 05 SPI-Current-Char PIC X(1).
+ 88 Current-Char-Is-Punct VALUE "=", "(", ")", "*", "/",
+ "&", ";", ",", "<", ">",
+ ":".
+ 88 Current-Char-Is-Quote VALUE '"', "'".
+ 88 Current-Char-Is-X VALUE "x", "X".
+ 88 Current-Char-Is-Z VALUE "z", "Z".
+ 05 SPI-Current-Division PIC X(1).
+ 88 In-IDENTIFICATION-DIVISION VALUE "I", "?".
+ 88 In-ENVIRONMENT-DIVISION VALUE "E".
+ 88 In-DATA-DIVISION VALUE "D".
+ 88 In-PROCEDURE-DIVISION VALUE "P".
+ 05 SPI-Current-Line-No PIC 9(6).
+ 05 SPI-Current-Program-ID.
+ 10 FILLER PIC X(12).
+ 10 SPI-CP-13-15 PIC X(3).
+ 05 SPI-Current-Section.
+ 10 SPI-CS-1 PIC X(1).
+ 10 SPI-CS-2-14.
+ 15 FILLER PIC X(10).
+ 15 SPI-CS-11-14 PIC X(3).
+ 10 SPI-CS-15 PIC X(1).
+ 05 SPI-Current-Token PIC X(32).
+ 05 SPI-Current-Token-UC PIC X(32).
+ 05 SPI-Current-Verb PIC X(12).
+ 05 SPI-Next-Char PIC X(1).
+ 88 Next-Char-Is-Quote VALUE '"', "'".
+ 05 SPI-Prior-Token PIC X(32).
+ 05 SPI-Token-Type PIC X(1).
+ 88 Token-Is-EOF VALUE HIGH-VALUES.
+ 88 Token-Is-Identifier VALUE "I".
+ 88 Token-Is-Key-Word VALUE "K", "V".
+ 88 Token-Is-Literal-Alpha VALUE "L".
+ 88 Token-Is-Literal-Number VALUE "N".
+ 88 Token-Is-Verb VALUE "V".
+GC0710 88 Token-Is-Reserved-Word VALUE " ".
+
+ 01 Tally USAGE BINARY-LONG.
+
+ 01 Todays-Date PIC 9(8).
+
+ LINKAGE SECTION.
+ 01 Produce-Source-Listing PIC X(1).
+ 01 Produce-Xref-Listing PIC X(1).
+ 01 Src-Filename PIC X(256).
+ /
+ PROCEDURE DIVISION USING Produce-Source-Listing
+ Produce-Xref-Listing
+ Src-Filename.
+ 000-Main SECTION.
+ 001-Init.
+ PERFORM 100-Initialization
+ PERFORM 200-Execute-cobc
+ OPEN OUTPUT Report-File
+ IF Produce-Source-Listing NOT = SPACE
+ PERFORM 500-Produce-Source-Listing
+ END-IF
+ IF Produce-Xref-Listing NOT = SPACE
+ SORT Sort-File
+ ASCENDING KEY SR-Prog-ID
+ SR-Token-UC
+ SR-Line-No-Ref
+ INPUT PROCEDURE 300-Tokenize-Source
+ OUTPUT PROCEDURE 400-Produce-Xref-Listing
+ END-IF
+ CLOSE Report-File
+ GOBACK
+ .
+ /
+ 100-Initialization SECTION.
+ *****************************************************************
+ ** Perform all program-wide initialization operations **
+ *****************************************************************
+ 101-Establish-Working-Env.
+ MOVE TRIM(Src-Filename,Leading) TO Src-Filename
+ ACCEPT Env-TEMP
+ FROM ENVIRONMENT "TEMP"
+ END-ACCEPT
+ ACCEPT Lines-Per-Page-ENV
+ FROM ENVIRONMENT "OCXREF_LINES"
+ END-ACCEPT
+ INSPECT Src-Filename REPLACING ALL "\" BY "/"
+ INSPECT Env-TEMP REPLACING ALL "\" BY "/"
+ MOVE Src-Filename TO Program-Path
+ MOVE Program-Path TO Heading-2
+ CALL "C$JUSTIFY"
+ USING Heading-2, "Right"
+ END-CALL
+ MOVE LENGTH(TRIM(Src-Filename,Trailing)) TO I
+ MOVE 0 TO J
+ PERFORM UNTIL Src-Filename(I:1) = '/'
+ OR I = 0
+ SUBTRACT 1 FROM I
+ ADD 1 TO J
+ END-PERFORM
+ UNSTRING Src-Filename((I + 1):J) DELIMITED BY "."
+ INTO Filename, Dummy
+ END-UNSTRING
+ STRING TRIM(Env-TEMP,Trailing)
+ "/"
+ TRIM(Filename,Trailing)
+ ".i"
+ DELIMITED SIZE
+ INTO Expanded-Src-Filename
+ END-STRING
+ STRING Program-Path(1:I)
+ TRIM(Filename,Trailing)
+ ".lst"
+ DELIMITED SIZE
+ INTO Report-Filename
+ END-STRING
+ IF Lines-Per-Page-ENV NOT = SPACES
+ MOVE NUMVAL(Lines-Per-Page-ENV) TO Lines-Per-Page
+ ELSE
+ MOVE 60 TO Lines-Per-Page
+ END-IF
+ ACCEPT Todays-Date
+ FROM DATE YYYYMMDD
+ END-ACCEPT
+ MOVE Todays-Date TO H1X-Date
+ H1S-Date
+ MOVE "????????????..." TO SPI-Current-Program-ID
+ MOVE SPACES TO SPI-Current-Verb
+ Held-Reference
+ MOVE "Y" TO F-First-Record
+ .
+ /
+ 200-Execute-cobc SECTION.
+ 201-Build-Cmd.
+ STRING "cobc -E "
+ TRIM(Program-Path, Trailing)
+ " > "
+ TRIM(Expanded-Src-Filename,Trailing)
+ DELIMITED SIZE
+ INTO Cmd
+ END-STRING
+ CALL "SYSTEM"
+ USING Cmd
+ END-CALL
+ IF RETURN-CODE NOT = 0
+ DISPLAY
+ "Cross-reference terminated by previous errors"
+ UPON SYSERR
+ END-DISPLAY
+ GOBACK
+ END-IF
+ .
+
+ 209-Exit.
+ EXIT
+ .
+ /
+ 300-Tokenize-Source SECTION.
+ 301-Driver.
+ OPEN INPUT Expand-Code
+ MOVE SPACES TO Expand-Code-Rec
+ MOVE 256 TO Src-Ptr
+ MOVE 0 TO Num-UserNames
+ SPI-Current-Line-No
+ MOVE "?" TO SPI-Current-Division
+GC0710 MOVE "N" TO F-Verb-Has-Been-Found.
+ PERFORM FOREVER
+ PERFORM 310-Get-Token
+ IF Token-Is-EOF
+ EXIT PERFORM
+ END-IF
+ MOVE UPPER-CASE(SPI-Current-Token)
+ TO SPI-Current-Token-UC
+ IF Token-Is-Verb
+ MOVE SPI-Current-Token-UC TO SPI-Current-Verb
+ SPI-Prior-Token
+ IF Held-Reference NOT = SPACES
+ MOVE Held-Reference TO Sort-Rec
+ MOVE SPACES TO Held-Reference
+ RELEASE Sort-Rec
+ END-IF
+ END-IF
+ EVALUATE TRUE
+ WHEN In-IDENTIFICATION-DIVISION
+ PERFORM 320-IDENTIFICATION-DIVISION
+ WHEN In-ENVIRONMENT-DIVISION
+ PERFORM 330-ENVIRONMENT-DIVISION
+ WHEN In-DATA-DIVISION
+ PERFORM 340-DATA-DIVISION
+ WHEN In-PROCEDURE-DIVISION
+ PERFORM 350-PROCEDURE-DIVISION
+ END-EVALUATE
+ IF Token-Is-Key-Word
+ MOVE SPI-Current-Token-UC TO SPI-Prior-Token
+ END-IF
+ IF F-Token-Ended-Sentence = "Y"
+ AND SPI-Current-Division NOT = "I"
+ MOVE SPACES TO SPI-Prior-Token
+ SPI-Current-Verb
+ END-IF
+
+ END-PERFORM
+ CLOSE Expand-Code
+ EXIT SECTION
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 310-Get-Token.
+ *>-- Position to 1st non-blank character
+ MOVE F-Token-Ended-Sentence TO F-Last-Token-Ended-Sent
+ MOVE "N" TO F-Token-Ended-Sentence
+ PERFORM UNTIL Expand-Code-Rec(Src-Ptr : 1) NOT = SPACE
+ IF Src-Ptr > 255
+ READ Expand-Code AT END
+ IF Held-Reference NOT = SPACES
+ MOVE Held-Reference TO Sort-Rec
+ MOVE SPACES TO Held-Reference
+ RELEASE Sort-Rec
+ END-IF
+ SET Token-Is-EOF TO TRUE
+ MOVE 0 TO SPI-Current-Line-No
+ EXIT PARAGRAPH
+ END-READ
+ IF ECR-1 = "#"
+ PERFORM 311-Control-Record
+ ELSE
+ PERFORM 312-Expand-Code-Record
+ END-IF
+ ELSE
+ ADD 1 TO Src-Ptr
+ END-IF
+ END-PERFORM
+ *>-- Extract token string
+ MOVE Expand-Code-Rec(Src-Ptr : 1) TO SPI-Current-Char
+ MOVE Expand-Code-Rec(Src-Ptr + 1: 1) TO SPI-Next-Char
+ IF SPI-Current-Char = "."
+ ADD 1 TO Src-Ptr
+ MOVE SPI-Current-Char TO SPI-Current-Token
+ MOVE SPACE TO SPI-Token-Type
+ MOVE "Y" TO F-Token-Ended-Sentence
+ EXIT PARAGRAPH
+ END-IF
+ IF Current-Char-Is-Punct
+ AND SPI-Current-Char = "="
+ AND SPI-Current-Division = "P"
+ ADD 1 TO Src-Ptr
+ MOVE "EQUALS" TO SPI-Current-Token
+ MOVE "K" TO SPI-Token-Type
+ EXIT PARAGRAPH
+ END-IF
+ IF Current-Char-Is-Punct *> So subscripts don't get flagged w/ "*"
+ AND SPI-Current-Char = "("
+ AND SPI-Current-Division = "P"
+ MOVE SPACES TO SPI-Prior-Token
+ END-IF
+ IF Current-Char-Is-Punct
+ ADD 1 TO Src-Ptr
+ MOVE SPI-Current-Char TO SPI-Current-Token
+ MOVE SPACE TO SPI-Token-Type
+ EXIT PARAGRAPH
+ END-IF
+ IF Current-Char-Is-Quote
+ ADD 1 TO Src-Ptr
+ UNSTRING Expand-Code-Rec
+ DELIMITED BY SPI-Current-Char
+ INTO SPI-Current-Token
+ WITH POINTER Src-Ptr
+ END-UNSTRING
+ IF Expand-Code-Rec(Src-Ptr : 1) = "."
+ MOVE "Y" TO F-Token-Ended-Sentence
+ ADD 1 TO Src-Ptr
+ END-IF
+ SET Token-Is-Literal-Alpha TO TRUE
+ EXIT PARAGRAPH
+ END-IF
+ IF Current-Char-Is-X AND Next-Char-Is-Quote
+ ADD 2 TO Src-Ptr
+ UNSTRING Expand-Code-Rec
+ DELIMITED BY SPI-Next-Char
+ INTO SPI-Current-Token
+ WITH POINTER Src-Ptr
+ END-UNSTRING
+ IF Expand-Code-Rec(Src-Ptr : 1) = "."
+ MOVE "Y" TO F-Token-Ended-Sentence
+ ADD 1 TO Src-Ptr
+ END-IF
+ SET Token-Is-Literal-Number TO TRUE
+ EXIT PARAGRAPH
+ END-IF
+ IF Current-Char-Is-Z AND Next-Char-Is-Quote
+ ADD 2 TO Src-Ptr
+ UNSTRING Expand-Code-Rec
+ DELIMITED BY SPI-Next-Char
+ INTO SPI-Current-Token
+ WITH POINTER Src-Ptr
+ END-UNSTRING
+ IF Expand-Code-Rec(Src-Ptr : 1) = "."
+ MOVE "Y" TO F-Token-Ended-Sentence
+ ADD 1 TO Src-Ptr
+ END-IF
+ SET Token-Is-Literal-Alpha TO TRUE
+ EXIT PARAGRAPH
+ END-IF
+ IF F-Processing-PICTURE = "Y"
+ UNSTRING Expand-Code-Rec
+ DELIMITED BY ". " OR " "
+ INTO SPI-Current-Token
+ DELIMITER IN Delim
+ WITH POINTER Src-Ptr
+ END-UNSTRING
+ IF Delim = ". "
+ MOVE "Y" TO F-Token-Ended-Sentence
+ ADD 1 TO Src-Ptr
+ END-IF
+ IF UPPER-CASE(SPI-Current-Token) = "IS"
+ MOVE SPACE TO SPI-Token-Type
+ EXIT PARAGRAPH
+ ELSE
+ MOVE "N" TO F-Processing-PICTURE
+ MOVE SPACE TO SPI-Token-Type
+ EXIT PARAGRAPH
+ END-IF
+ END-IF
+ UNSTRING Expand-Code-Rec
+ DELIMITED BY ". " OR " " OR "=" OR "(" OR ")" OR "*"
+ OR "/" OR "&" OR ";" OR "," OR "<"
+ OR ">" OR ":"
+ INTO SPI-Current-Token
+ DELIMITER IN Delim
+ WITH POINTER Src-Ptr
+ END-UNSTRING
+ IF Delim = ". "
+ MOVE "Y" TO F-Token-Ended-Sentence
+ END-IF
+ IF Delim NOT = ". " AND " "
+ SUBTRACT 1 FROM Src-Ptr
+ END-IF
+ *>-- Classify Token
+ MOVE UPPER-CASE(SPI-Current-Token) TO Search-Token
+ IF Search-Token = "EQUAL" OR "EQUALS"
+ MOVE "EQUALS" TO SPI-Current-Token
+ MOVE "K" TO SPI-Token-Type
+ EXIT PARAGRAPH
+ END-IF
+ SEARCH ALL Reserved-Word
+ WHEN RW-Word (RW-Idx) = Search-Token
+ MOVE RW-Type (RW-Idx) TO SPI-Token-Type
+GC0710 IF Token-Is-Verb
+GC0710 MOVE "Y" TO F-Verb-Has-Been-Found
+GC0710 END-IF
+ EXIT PARAGRAPH
+ END-SEARCH
+ *>-- Not a reserved word, must be a user name
+ SET Token-Is-Identifier TO TRUE *> NEEDS EXPANSION!!!!
+ PERFORM 313-Check-For-Numeric-Token
+ IF Token-Is-Literal-Number
+ IF (F-Last-Token-Ended-Sent = "Y")
+ AND (SPI-Current-Division = "D")
+ MOVE "LEVEL #" TO SPI-Current-Token
+ MOVE "K" TO SPI-Token-Type
+ EXIT PARAGRAPH
+ ELSE
+ EXIT PARAGRAPH
+ END-IF
+ END-IF
+ EXIT PARAGRAPH
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 311-Control-Record.
+ UNSTRING ECR-2-256
+ DELIMITED BY '"'
+ INTO PIC-X10, PIC-X256, Dummy
+ END-UNSTRING
+ INSPECT PIC-X10 REPLACING ALL '"' BY SPACE
+ COMPUTE I = NUMVAL(PIC-X10) - 1
+ IF TRIM(PIC-X256,Trailing) = TRIM(Program-Path,Trailing)
+ MOVE I TO SPI-Current-Line-No
+ SET In-Main-Module TO TRUE
+ IF Saved-Section NOT = SPACES
+ MOVE Saved-Section TO SPI-Current-Section
+ END-IF
+ ELSE
+ SET In-Copybook TO TRUE
+ IF Saved-Section = SPACES
+ MOVE SPI-Current-Section TO Saved-Section
+ END-IF
+ MOVE LENGTH(TRIM(PIC-X256,Trailing)) TO I
+ MOVE 0 TO J
+ PERFORM UNTIL PIC-X256(I:1) = '/'
+ OR I = 0
+ SUBTRACT 1 FROM I
+ ADD 1 TO J
+ END-PERFORM
+ UNSTRING PIC-X256((I + 1):J) DELIMITED BY "."
+ INTO Filename, Dummy
+ END-UNSTRING
+ MOVE "[" TO SPI-CS-1
+ MOVE Filename TO SPI-CS-2-14
+ IF SPI-CS-11-14 NOT = SPACES
+ MOVE "..." TO SPI-CS-11-14
+ END-IF
+ MOVE "]" TO SPI-CS-15
+ END-IF
+ MOVE SPACES TO Expand-Code-Rec *> Force another READ
+ MOVE 256 TO Src-Ptr
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 312-Expand-Code-Record.
+ MOVE 1 TO Src-Ptr
+ IF In-Main-Module
+ ADD 1 To SPI-Current-Line-No
+ END-IF
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 313-Check-For-Numeric-Token.
+ MOVE SPI-Current-Token TO PIC-X32
+ INSPECT PIC-X32
+ REPLACING TRAILING SPACES BY "0"
+ IF PIC-X32 IS NUMERIC *> Simple Unsigned Integer
+ SET Token-Is-Literal-Number TO TRUE
+ EXIT PARAGRAPH
+ END-IF
+ IF PIC-X32(1:1) = "+" OR "-"
+ MOVE "0" TO PIC-X32(1:1)
+ END-IF
+ MOVE 0 TO Tally
+ INSPECT PIC-X32
+ TALLYING Tally FOR ALL "."
+ IF Tally = 1
+ INSPECT PIC-X32 REPLACING ALL "." BY "0"
+ END-IF
+ IF PIC-X32 IS NUMERIC
+ SET Token-Is-Literal-Number TO TRUE
+ EXIT PARAGRAPH
+ END-IF
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 320-IDENTIFICATION-DIVISION.
+GC0710 MOVE "N" TO F-Verb-Has-Been-Found
+ IF Token-Is-Key-Word AND SPI-Current-Token = "DIVISION"
+ MOVE SPI-Prior-Token TO SPI-Current-Division
+ EXIT PARAGRAPH
+ END-IF
+ IF SPI-Prior-Token = "PROGRAM-ID"
+ MOVE SPACES TO SPI-Prior-Token
+ MOVE SPI-Current-Token TO SPI-Current-Program-ID
+ IF SPI-CP-13-15 NOT = SPACES
+ MOVE "..." TO SPI-CP-13-15
+ END-IF
+ EXIT PARAGRAPH
+ END-IF
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 330-ENVIRONMENT-DIVISION.
+ IF Token-Is-Key-Word AND SPI-Current-Token = "DIVISION"
+ MOVE SPI-Prior-Token TO SPI-Current-Division
+ EXIT PARAGRAPH
+ END-IF
+ IF Token-Is-Key-Word AND SPI-Current-Token = "SECTION"
+ MOVE SPI-Prior-Token TO SPI-Current-Section
+ EXIT PARAGRAPH
+ END-IF
+ IF Token-Is-Identifier
+ PERFORM 361-Release-Ref
+ END-IF
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 340-DATA-DIVISION.
+ IF Token-Is-Key-Word AND SPI-Current-Token = "DIVISION"
+ MOVE SPI-Prior-Token TO SPI-Current-Division
+ EXIT PARAGRAPH
+ END-IF
+ IF Token-Is-Key-Word AND SPI-Current-Token = "SECTION"
+ MOVE SPI-Prior-Token TO SPI-Current-Section
+ EXIT PARAGRAPH
+ END-IF
+ IF (SPI-Current-Token = "PIC" OR "PICTURE")
+ AND (Token-Is-Key-Word)
+ MOVE "Y" TO F-Processing-PICTURE
+ EXIT PARAGRAPH
+ END-IF
+GC0710 IF Token-Is-Reserved-Word
+GC0710 AND SPI-Prior-Token = "LEVEL #"
+GC0710 MOVE SPACES TO SPI-Prior-Token
+GC0710 EXIT PARAGRAPH
+GC0710 END-IF
+ IF Token-Is-Identifier
+ EVALUATE SPI-Prior-Token
+ WHEN "FD"
+ PERFORM 360-Release-Def
+ MOVE SPACES TO SPI-Prior-Token
+ WHEN "SD"
+ PERFORM 360-Release-Def
+ MOVE SPACES TO SPI-Prior-Token
+ WHEN "LEVEL #"
+ PERFORM 360-Release-Def
+ MOVE SPACES TO SPI-Prior-Token
+ WHEN "INDEXED"
+ PERFORM 360-Release-Def
+ MOVE SPACES TO SPI-Prior-Token
+ WHEN "USING"
+ PERFORM 362-Release-Upd
+ MOVE SPACES TO SPI-Prior-Token
+ WHEN "INTO"
+ PERFORM 362-Release-Upd
+ MOVE SPACES TO SPI-Prior-Token
+ WHEN OTHER
+ PERFORM 361-Release-Ref
+ END-EVALUATE
+ EXIT PARAGRAPH
+ END-IF
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 350-PROCEDURE-DIVISION.
+ IF SPI-Current-Section NOT = "PROCEDURE"
+ MOVE "PROCEDURE" TO SPI-Current-Section
+ END-IF
+GC0710 IF SPI-Current-Token-UC = "PROGRAM"
+GC0710 AND SPI-Prior-Token = "END"
+GC0710 MOVE "?" TO SPI-Current-Division
+GC0710 EXIT PARAGRAPH
+GC0710 END-IF
+ IF Token-Is-Key-Word AND SPI-Current-Token = "DIVISION"
+ MOVE SPI-Prior-Token TO SPI-Current-Division
+ EXIT PARAGRAPH
+ END-IF
+ IF SPI-Current-Verb = SPACES
+GC0710 AND F-Verb-Has-Been-Found = "Y"
+ IF Token-Is-Identifier
+ PERFORM 360-Release-Def
+ MOVE SPACES TO SPI-Prior-Token
+ END-IF
+ EXIT PARAGRAPH
+ END-IF
+ IF NOT Token-Is-Identifier
+ EXIT PARAGRAPH
+ END-IF
+ EVALUATE SPI-Current-Verb
+ WHEN "ACCEPT"
+ PERFORM 351-ACCEPT
+ WHEN "ADD"
+ PERFORM 351-ADD
+ WHEN "ALLOCATE"
+ PERFORM 351-ALLOCATE
+ WHEN "CALL"
+ PERFORM 351-CALL
+ WHEN "COMPUTE"
+ PERFORM 351-COMPUTE
+ WHEN "DIVIDE"
+ PERFORM 351-DIVIDE
+ WHEN "FREE"
+ PERFORM 351-FREE
+ WHEN "INITIALIZE"
+ PERFORM 351-INITIALIZE
+ WHEN "INSPECT"
+ PERFORM 351-INSPECT
+ WHEN "MOVE"
+ PERFORM 351-MOVE
+ WHEN "MULTIPLY"
+ PERFORM 351-MULTIPLY
+ WHEN "PERFORM"
+ PERFORM 351-PERFORM
+ WHEN "SET"
+ PERFORM 351-SET
+ WHEN "STRING"
+ PERFORM 351-STRING
+ WHEN "SUBTRACT"
+ PERFORM 351-SUBTRACT
+ WHEN "TRANSFORM"
+ PERFORM 351-TRANSFORM
+ WHEN "UNSTRING"
+ PERFORM 351-UNSTRING
+ WHEN OTHER
+ PERFORM 361-Release-Ref
+ END-EVALUATE
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 351-ACCEPT.
+ EVALUATE SPI-Prior-Token
+ WHEN "ACCEPT"
+ PERFORM 362-Release-Upd
+ MOVE SPACES TO SPI-Prior-Token
+ WHEN OTHER
+ PERFORM 361-Release-Ref
+ END-EVALUATE
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 351-ADD.
+ EVALUATE SPI-Prior-Token
+ WHEN "GIVING"
+ PERFORM 362-Release-Upd
+ WHEN "TO"
+ PERFORM 362-Release-Upd
+ WHEN OTHER
+ PERFORM 361-Release-Ref
+ END-EVALUATE
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 351-ALLOCATE.
+ EVALUATE SPI-Prior-Token
+ WHEN "ALLOCATE"
+ PERFORM 362-Release-Upd
+ MOVE SPACES TO SPI-Prior-Token
+ WHEN "RETURNING"
+ PERFORM 362-Release-Upd
+ WHEN OTHER
+ PERFORM 361-Release-Ref
+ END-EVALUATE
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 351-CALL.
+ EVALUATE SPI-Prior-Token
+ WHEN "RETURNING"
+ PERFORM 362-Release-Upd
+ WHEN "GIVING"
+ PERFORM 362-Release-Upd
+ WHEN OTHER
+ PERFORM 361-Release-Ref
+ END-EVALUATE
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 351-COMPUTE.
+ EVALUATE SPI-Prior-Token
+ WHEN "COMPUTE"
+ PERFORM 362-Release-Upd
+ WHEN OTHER
+ PERFORM 361-Release-Ref
+ END-EVALUATE
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 351-DIVIDE.
+ EVALUATE SPI-Prior-Token
+ WHEN "INTO"
+ PERFORM 363-Set-Upd
+ MOVE Sort-Rec TO Held-Reference
+ WHEN "GIVING"
+ IF Held-Reference NOT = SPACES
+ MOVE Held-Reference To Sort-Rec
+ MOVE SPACES To Held-Reference
+ SR-Ref-Flag
+ RELEASE Sort-Rec
+ END-IF
+ PERFORM 362-Release-Upd
+ WHEN "REMAINDER"
+ PERFORM 362-Release-Upd
+ WHEN OTHER
+ PERFORM 361-Release-Ref
+ END-EVALUATE
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 351-FREE.
+ PERFORM 362-Release-Upd
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 351-INITIALIZE.
+ EVALUATE SPI-Prior-Token
+ WHEN "INITIALIZE"
+ PERFORM 362-Release-Upd
+ WHEN "REPLACING"
+ PERFORM 361-Release-Ref
+ END-EVALUATE
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 351-INSPECT.
+ EVALUATE SPI-Prior-Token
+ WHEN "INSPECT"
+ PERFORM 364-Set-Ref
+ MOVE SPACES TO Held-Reference
+ MOVE SPACES TO SPI-Prior-Token
+ WHEN "TALLYING"
+ PERFORM 362-Release-Upd
+ MOVE SPACES TO SPI-Prior-Token
+ WHEN "REPLACING"
+ IF Held-Reference NOT = SPACES
+ MOVE Held-Reference TO Sort-Rec
+ MOVE SPACES TO Held-Reference
+ MOVE "*" TO SR-Ref-Flag
+ RELEASE Sort-Rec
+ END-IF
+ MOVE SPACES TO SPI-Prior-Token
+ WHEN "CONVERTING"
+ IF Held-Reference NOT = SPACES
+ MOVE Held-Reference TO Sort-Rec
+ MOVE SPACES TO Held-Reference
+ MOVE "*" TO SR-Ref-Flag
+ RELEASE Sort-Rec
+ END-IF
+ MOVE SPACES TO SPI-Prior-Token
+ WHEN OTHER
+ PERFORM 361-Release-Ref
+ END-EVALUATE
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 351-MOVE.
+ EVALUATE SPI-Prior-Token
+ WHEN "TO"
+ PERFORM 362-Release-Upd
+ WHEN OTHER
+ PERFORM 361-Release-Ref
+ END-EVALUATE
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 351-MULTIPLY.
+ EVALUATE SPI-Prior-Token
+ WHEN "BY"
+ PERFORM 363-Set-Upd
+ MOVE Sort-Rec TO Held-Reference
+ WHEN "GIVING"
+ MOVE Held-Reference TO Sort-Rec
+ MOVE SPACES TO Held-Reference
+ SR-Ref-Flag
+ RELEASE Sort-Rec
+ PERFORM 362-Release-Upd
+ WHEN OTHER
+ PERFORM 361-Release-Ref
+ END-EVALUATE
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 351-PERFORM.
+ EVALUATE SPI-Prior-Token
+ WHEN "VARYING"
+ PERFORM 362-Release-Upd
+ MOVE SPACES TO SPI-Prior-Token
+ WHEN "AFTER"
+ PERFORM 362-Release-Upd
+ MOVE SPACES TO SPI-Prior-Token
+ WHEN OTHER
+ PERFORM 361-Release-Ref
+ END-EVALUATE
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 351-SET.
+ EVALUATE SPI-Prior-Token
+ WHEN "SET"
+ PERFORM 362-Release-Upd
+ WHEN OTHER
+ PERFORM 361-Release-Ref
+ END-EVALUATE
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 351-STRING.
+ EVALUATE SPI-Prior-Token
+ WHEN "INTO"
+ PERFORM 362-Release-Upd
+ WHEN "POINTER"
+ PERFORM 362-Release-Upd
+ WHEN OTHER
+ PERFORM 361-Release-Ref
+ END-EVALUATE
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 351-SUBTRACT.
+ EVALUATE SPI-Prior-Token
+ WHEN "GIVING"
+ PERFORM 362-Release-Upd
+ WHEN "FROM"
+ PERFORM 362-Release-Upd
+ WHEN OTHER
+ PERFORM 361-Release-Ref
+ END-EVALUATE
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 351-TRANSFORM.
+ EVALUATE SPI-Prior-Token
+ WHEN "TRANSFORM"
+ PERFORM 362-Release-Upd
+ MOVE SPACES TO SPI-Prior-Token
+ WHEN OTHER
+ PERFORM 361-Release-Ref
+ END-EVALUATE
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 351-UNSTRING.
+ EVALUATE SPI-Prior-Token
+ WHEN "INTO"
+ PERFORM 362-Release-Upd
+ WHEN "DELIMITER"
+ PERFORM 362-Release-Upd
+ WHEN "COUNT"
+ PERFORM 362-Release-Upd
+ WHEN "POINTER"
+ PERFORM 362-Release-Upd
+ WHEN "TALLYING"
+ PERFORM 362-Release-Upd
+ WHEN OTHER
+ PERFORM 361-Release-Ref
+ END-EVALUATE
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 360-Release-Def.
+ MOVE SPACES TO Sort-Rec
+ MOVE SPI-Current-Program-ID TO SR-Prog-ID
+ MOVE SPI-Current-Token-UC TO SR-Token-UC
+ MOVE SPI-Current-Token TO SR-Token
+ MOVE SPI-Current-Section TO SR-Section
+ MOVE SPI-Current-Line-No TO SR-Line-No-Def
+ MOVE 0 TO SR-Line-No-Ref
+ RELEASE Sort-Rec
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 361-Release-Ref.
+ PERFORM 364-Set-Ref
+ RELEASE Sort-Rec
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 362-Release-Upd.
+ PERFORM 363-Set-Upd
+ RELEASE Sort-Rec
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 363-Set-Upd.
+ MOVE SPACES TO Sort-Rec
+ MOVE SPI-Current-Program-ID TO SR-Prog-ID
+ MOVE SPI-Current-Token-UC TO SR-Token-UC
+ MOVE SPI-Current-Token TO SR-Token
+ MOVE SPI-Current-Section TO SR-Section
+ MOVE SPI-Current-Line-No TO SR-Line-No-Ref
+ MOVE "*" TO SR-Ref-Flag
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 364-Set-Ref.
+ MOVE SPACES TO Sort-Rec
+ MOVE SPI-Current-Program-ID TO SR-Prog-ID
+ MOVE SPI-Current-Token-UC TO SR-Token-UC
+ MOVE SPI-Current-Token TO SR-Token
+ MOVE SPI-Current-Section TO SR-Section
+ MOVE SPI-Current-Line-No TO SR-Line-No-Ref
+ .
+ /
+ 400-Produce-Xref-Listing SECTION.
+ 401-Init.
+ MOVE SPACES TO Detail-Line-X
+ Group-Indicators
+ MOVE 0 TO I
+ Lines-Left
+GC0710 MOVE 'N' TO F-Duplicate
+ .
+
+ 402-Process-Sorted-Recs.
+ PERFORM FOREVER
+ RETURN Sort-File AT END
+ EXIT PERFORM
+ END-RETURN
+ IF SR-Prog-ID NOT = GI-Prog-ID
+ OR SR-Token-UC NOT = GI-Token
+GC0710 MOVE 'N' TO F-Duplicate
+ IF Detail-Line-X NOT = SPACES
+ PERFORM 410-Generate-Report-Line
+ END-IF
+ IF SR-Prog-ID NOT = GI-Prog-ID
+ MOVE 0 TO Lines-Left
+ END-IF
+ MOVE SR-Prog-ID TO GI-Prog-ID
+ MOVE SR-Token-UC TO GI-Token
+ END-IF
+GC0710 IF SR-Token-UC = GI-Token
+GC0710 AND SR-Line-No-Def NOT = SPACES
+GC0710 AND Detail-Line-X NOT = SPACES
+GC0710 MOVE 'Y' TO F-Duplicate
+GC0710 PERFORM 410-Generate-Report-Line
+GC0710 MOVE 0 TO I
+GC0710 MOVE SR-Prog-ID TO DLX-Prog-ID
+GC0710 MOVE ' (Duplicate Definition)' TO DLX-Token
+GC0710 MOVE SR-Section TO DLX-Section
+GC0710 MOVE SR-Line-No-Def TO DLX-Line-No-Def
+GC0710 EXIT PERFORM CYCLE
+GC0710 END-IF
+GC0710 IF SR-Token-UC = GI-Token
+GC0710 AND SR-Line-No-Def = SPACES
+GC0710 AND F-Duplicate = 'Y'
+GC0710 MOVE 'N' TO F-Duplicate
+GC0710 PERFORM 410-Generate-Report-Line
+GC0710 MOVE 0 TO I
+GC0710 MOVE SR-Prog-ID TO DLX-Prog-ID
+GC0710 MOVE ' (Duplicate References)' TO DLX-Token
+GC0710 END-IF
+ IF Detail-Line-X = SPACES
+ MOVE SR-Prog-ID TO DLX-Prog-ID
+ MOVE SR-Token TO DLX-Token
+ MOVE SR-Section TO DLX-Section
+ IF SR-Line-No-Def NOT = SPACES
+ MOVE SR-Line-No-Def TO DLX-Line-No-Def
+ END-IF
+ END-IF
+ IF SR-Reference > '000000'
+ ADD 1 TO I
+ IF I > Line-Nos-Per-Rec
+ PERFORM 410-Generate-Report-Line
+ MOVE 1 TO I
+ END-IF
+ MOVE SR-Line-No-Ref TO DLX-Line-No-Ref (I)
+ MOVE SR-Ref-Flag TO DLX-Ref-Flag (I)
+ END-IF
+ END-PERFORM
+ IF Detail-Line-X NOT = SPACES
+ PERFORM 410-Generate-Report-Line
+ END-IF
+ EXIT SECTION
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 410-Generate-Report-Line.
+ IF Lines-Left < 1
+ IF F-First-Record = "Y"
+ MOVE "N" TO F-First-Record
+ WRITE Report-Rec FROM Heading-1X BEFORE 1
+ ELSE
+ MOVE SPACES TO Report-Rec
+ WRITE Report-Rec BEFORE PAGE
+ MOVE SPACES TO Report-Rec
+ WRITE Report-Rec BEFORE 1
+ WRITE Report-Rec FROM Heading-1X BEFORE 1
+ END-IF
+ WRITE Report-Rec FROM Heading-2 BEFORE 1
+ WRITE Report-Rec FROM Heading-4X BEFORE 1
+ WRITE Report-Rec FROM Heading-5X BEFORE 1
+ COMPUTE
+ Lines-Left = Lines-Per-Page - 4
+ END-COMPUTE
+ END-IF
+ WRITE Report-Rec FROM Detail-Line-X BEFORE 1
+ MOVE SPACES TO Detail-Line-X
+ MOVE 0 TO I
+ SUBTRACT 1 FROM Lines-Left
+ .
+ /
+ 500-Produce-Source-Listing SECTION.
+ 501-Generate-Source-Listing.
+ OPEN INPUT Source-Code
+ Expand-Code
+ MOVE 0 TO Source-Line-No
+ PERFORM FOREVER
+ READ Expand-Code AT END
+ EXIT PERFORM
+ END-READ
+ IF ECR-1 = "#"
+ PERFORM 510-Control-Record
+ ELSE
+ PERFORM 520-Expand-Code-Record
+ END-IF
+ END-PERFORM
+ CLOSE Source-Code
+ Expand-Code
+ EXIT SECTION
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 510-Control-Record.
+ UNSTRING ECR-2-256
+ DELIMITED BY '"'
+ INTO PIC-X10, PIC-X256, Dummy
+ END-UNSTRING
+ IF TRIM(PIC-X256,Trailing) = TRIM(Program-Path,Trailing) *> Main Pgm
+ SET In-Main-Module TO TRUE
+ IF Source-Line-No > 0
+ READ Expand-Code END-READ
+ END-IF
+ ELSE *> COPY
+ SET In-Copybook TO TRUE
+ END-IF
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 520-Expand-Code-Record.
+ IF In-Main-Module
+ ADD 1 To SPI-Current-Line-No
+ READ Source-Code AT END NEXT SENTENCE END-READ
+ ADD 1 TO Source-Line-No
+ MOVE SPACES TO Detail-Line-S
+ MOVE Source-Line-No TO DLS-Line-No
+ MOVE SCR-1-128 TO DLS-Statement
+GC0410 IF SCR-7 = "/"
+GC0410 MOVE 0 TO Lines-Left
+GC0410 END-IF
+ PERFORM 530-Generate-Source-Line
+ IF SCR-129-256 NOT = SPACES
+ MOVE SPACES TO Detail-Line-S
+ MOVE SCR-129-256 TO DLS-Statement
+ PERFORM 530-Generate-Source-Line
+ END-IF
+ ELSE
+ IF Expand-Code-Rec NOT = SPACES
+ MOVE SPACES TO Detail-Line-S
+ MOVE ECR-1-128 TO DLS-Statement
+ PERFORM 530-Generate-Source-Line
+ IF ECR-129-256 NOT = SPACES
+ MOVE SPACES TO Detail-Line-S
+ MOVE ECR-129-256 TO DLS-Statement
+ PERFORM 530-Generate-Source-Line
+ END-IF
+ END-IF
+ END-IF
+ .
+ *>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ 530-Generate-Source-Line.
+ IF Lines-Left < 1
+ IF F-First-Record = "Y"
+ MOVE "N" TO F-First-Record
+ WRITE Report-Rec FROM Heading-1S BEFORE 1
+ ELSE
+ MOVE SPACES TO Report-Rec
+ WRITE Report-Rec BEFORE PAGE
+ MOVE SPACES TO Report-Rec
+ WRITE Report-Rec BEFORE 1
+ WRITE Report-Rec FROM Heading-1S BEFORE 1
+ END-IF
+ WRITE Report-Rec FROM Heading-2 BEFORE 1
+ WRITE Report-Rec FROM Heading-4S BEFORE 1
+ WRITE Report-Rec FROM Heading-5S BEFORE 1
+ COMPUTE
+ Lines-Left = Lines-Per-Page - 4
+ END-COMPUTE
+ END-IF
+ WRITE Report-Rec FROM Detail-Line-S BEFORE 1
+ MOVE SPACES TO Detail-Line-S
+ SUBTRACT 1 FROM Lines-Left
+ .
+
+ END PROGRAM LISTING.
|