1 IDENTIFICATION DIVISION. 2 PROGRAM-ID. OCic. 3 ***************************************************************** 4 ** This program provides a Textual User Interface (TUI) to the ** 5 ** process of compiling and (optionally) executing an OpenCOBOL** 6 ** program. ** 7 ** ** 8 ** This programs execution syntax is as follows: ** 9 ** ** 10 ** ocic <program-path-and-filename> [ <switch>... ] ** 11 ** ** 12 ** Once executed, a display screen will be presented showing ** 13 ** the compilation options that will be used. The user will ** 14 ** have the opportunity to change options, specify new ones ** 15 ** and specify any program execution arguments to be used if ** 16 ** you select the "Execute" option. When you press the Enter ** 17 ** key the program will be compiled. ** 18 ** ** 19 ** The SCREEN SECTION contains an image of the screen. ** 20 ** ** 21 ** The "010-Parse-Args" section in the PROCEDURE DIVISION has ** 22 ** documentation on switches and their function. ** 23 ***************************************************************** 24 ** ** 25 ** AUTHOR: GARY L. CUTLER ** 26 ** CutlerGL@gmail.com ** 27 ** Copyright (C) 2009-2010, Gary L. Cutler, GPL ** 28 ** ** 29 ** DATE-WRITTEN: June 14, 2009 ** 30 ** ** 31 ***************************************************************** 32 ** Note: Depending on which extended DISPLAY handler you're ** 33 ** using (PDCurses, Curses, ...), you may need to un- ** 34 ** comment any source lines tagged with "SCROLL" in cols ** 35 ** 1-6 in order to have error messages scroll properly ** 36 ** in the OCic shell window. ** 37 ***************************************************************** 38 ** DATE CHANGE DESCRIPTION ** 39 ** ====== ==================================================== ** 40 ** GC0609 Don't display compiler messages file if compilation ** 41 ** Is successful. Also don't display messages if the ** 42 ** output file is busy (just put a message on the ** 43 ** screen, leave the OC screen up & let the user fix ** 44 ** the problem & resubmit. ** 45 ** GC0709 When 'EXECUTE' is selected, a 'FILE BUSY' error will ** 46 ** still cause the (old) executable to be launched. ** 47 ** Also, the 'EXTRA SWITCHES' field is being ignored. ** 48 ** Changed the title bar to lowlighted reverse video & ** 49 ** the message area to highlighted reverse-video. ** 50 ** GC0809 Add a SPACE in from of command-line args when ** 51 ** executing users program. Add a SPACE after the ** 52 ** -ftraceall switch when building cobc command. ** 53 ** GC0909 Convert to work on Cygwin/Linux as well as MinGW ** 54 ** GC0310 Virtualized the key codes for S-F1 thru S-F7 as they ** 55 ** differ depending upon whether PDCurses or NCurses is ** 56 ** being used. ** 57 ** GC0410 Introduced the cross-reference and source listing ** 58 ** features. Also fixed a bug in @EXTRA switch proces- ** 59 ** sing where garbage will result if more than the ** 60 ** @EXTRA switch is specified. ** 61 ***************************************************************** 62 ENVIRONMENT DIVISION. 63 CONFIGURATION SECTION. 64 REPOSITORY. 65 FUNCTION ALL INTRINSIC. 66 INPUT-OUTPUT SECTION. 67 FILE-CONTROL. 68 SELECT Bat-File ASSIGN TO Bat-File-Name 69 ORGANIZATION IS LINE SEQUENTIAL. 70 71 SELECT Cobc-Output ASSIGN TO Cobc-Output-File 72 ORGANIZATION IS LINE SEQUENTIAL. 73 74 SELECT Source-Code ASSIGN TO File-Name 75 ORGANIZATION IS LINE SEQUENTIAL 76 FILE STATUS IS FSM-Status. 77 DATA DIVISION. 78 FILE SECTION. 79 FD Bat-File. 80 01 Bat-File-Rec PIC X(2048). 81 82 FD Cobc-Output. 83 01 Cobc-Output-Rec PIC X(256). 84 85 FD Source-Code. 86 01 Source-Code-Record PIC X(80). 87 88 WORKING-STORAGE SECTION. 89 COPY screenio. 90 91 01 Bat-File-Name PIC X(256). 92 93GC0909 01 Cmd PIC X(512). 94 95 01 Cobc-Cmd PIC X(256). 96 97 01 Cobc-Output-File PIC X(256). 98 99 01 Command-Line-Args PIC X(256). 100 101 01 Config-File PIC X(12). 102 103GC0310 01 Config-Keys. 104GC0310 05 CK-S-F1 PIC 9(4). 105GC0310 05 CK-S-F2 PIC 9(4). 106GC0310 05 CK-S-F3 PIC 9(4). 107GC0310 05 CK-S-F4 PIC 9(4). 108GC0310 05 CK-S-F5 PIC 9(4). 109GC0310 05 CK-S-F6 PIC 9(4). 110GC0310 05 CK-S-F7 PIC 9(4). 111 112GC0909 01 Dir-Char PIC X(1). 113 114 01 Dummy PIC X(1). 115 116 01 Env-TEMP PIC X(256). 117 118 01 File-Name. 119 05 FN-Char OCCURS 256 TIMES PIC X(1). 120 121 01 File-Status-Message. 122 05 FILLER PIC X(13) VALUE 'Status Code: '. 123 05 FSM-Status PIC 9(2). 124 05 FILLER PIC X(11) VALUE ', Meaning: '. 125 05 FSM-Msg PIC X(25). 126 127 01 Flags. 128 05 F-Compilation-Succeeded PIC X(1). 129 88 88-Compile-OK VALUE 'Y'. 130GC0909 88 88-Compile-OK-Warn VALUE 'W'. 131 88 88-Compile-Failed VALUE 'N'. 132GC0609 05 F-Complete PIC X(1). 133GC0609 88 88-Complete VALUE 'Y'. 134GC0609 88 88-Not-Complete VALUE 'N'. 135GC0809 05 F-IDENT-DIVISION PIC X(1). 136GC0809 88 88-1st-Prog-Complete VALUE 'Y'. 137GC0809 88 88-More-To-1st-Prog VALUE 'N'. 138 05 F-LINKAGE-SECTION PIC X(1). 139 88 88-Compile-As-Subpgm VALUE 'Y'. 140 88 88-Compile-As-Mainpgm VALUE 'N'. 141 05 F-No-Switch-Changes PIC X(1). 142 88 88-No-Switch-Changes VALUE 'Y'. 143 88 88-Switch-Changes VALUE 'N'. 144GC0709 05 F-Output-File-Busy PIC X(1). 145GC0709 88 88-Output-File-Busy VALUE 'Y'. 146GC0709 88 88-Output-File-Avail VALUE 'N'. 147GC0809 05 F-Source-Record-Type PIC X(1). 148GC0809 88 88-Source-Rec-Linkage VALUE 'L'. 149GC0809 88 88-Source-Rec-Ident VALUE 'I'. 150GC0809 88 88-Source-Rec-IgnoCOB-COLOR-RED VALUE ' '. 151 05 F-Switch-Error PIC X(1). 152 88 88-Switch-Is-Bad VALUE 'Y'. 153 88 88-Switch-Is-Good VALUE 'N'. 154 155GC0909 01 Horizontal-Line PIC X(80). 156GC0909 157 01 I USAGE BINARY-LONG. 158 159 01 J USAGE BINARY-LONG. 160 161GC0909 01 MS USAGE BINARY-LONG. 162 163GC0909 01 ML USAGE BINARY-LONG. 164 165 01 OC-Compiled PIC XXXX/XX/XXBXX/XX. 166 167GC0909 01 OS-Type USAGE BINARY-LONG. 168GC0909 88 OS-Unknown VALUE 0. 169GC0909 88 OS-Windows VALUE 1. 170GC0909 88 OS-Cygwin VALUE 2. 171GC0909 88 OS-UNIX VALUE 3. 172 173GC0909 01 OS-Type-Literal PIC X(7). 174 175 01 Output-Message PIC X(80). 176 177 01 Path-Delimiter PIC X(1). 178 179 01 Prog-Folder PIC X(256). 180 181 01 Prog-Extension PIC X(30). 182 183 01 Prog-File-Name PIC X(40). 184 185 01 Prog-Name PIC X(31). 186 187 78 Selection-Char VALUE '>'. 188 189 01 Switch-Display. 190 05 SD-Switch-And-Value PIC X(19). 191 05 FILLER PIC X(1). 192 05 SD-Description PIC X(60). 193 194 01 Switch-Keyword PIC X(12). 195GC0410 88 Switch-Is-CONFIG VALUE '@CONFIG', '@C'. 196GC0410 88 Switch-Is-DEBUG VALUE '@DEBUG', '@D'. 197GC0410 88 Switch-Is-DLL VALUE '@DLL'. 198GC0410 88 Switch-Is-EXECUTE VALUE '@EXECUTE', '@E'. 199GC0410 88 Switch-Is-EXTRA VALUE '@EXTRA', '@EX'. 200GC0410 88 Switch-Is-NOTRUNC VALUE '@NOTRUNC', '@N'. 201GC0410 88 Switch-Is-TRACE VALUE '@TRACE', '@T'. 202GC0410 88 Switch-Is-SOURCE VALUE '@SOURCE', '@S'. 203GC0410 88 Switch-Is-XREF VALUE '@XREF', '@X'. 204 205 01 Switch-Keyword-And-Value PIC X(256). 206 207 01 Switch-Value. 208 05 SV-1 PIC X(1). 209 05 FILLER PIC X(255). 210 01 Switch-Value-Alt REDEFINES Switch-Value 211 PIC X(256). 212 88 Valid-Config-Filename 213 VALUE 'BS2000', 'COBOL85', 'COBOL2002', 'DEFAULT', 214 'IBM', 'MF', 'MVS'. 215 216 01 Switches. 217 05 S-ARGS PIC X(75) VALUE SPACES. 218 05 S-CfgS. 219 10 S-Cfg-BS2000 PIC X(1) VALUE ' '. 220 10 S-Cfg-COBOL85 PIC X(1) VALUE ' '. 221 10 S-Cfg-COBOL2002 PIC X(1) VALUE ' '. 222 10 S-Cfg-DEFAULT PIC X(1) VALUE Selection-Char. 223 10 S-Cfg-IBM PIC X(1) VALUE ' '. 224 10 S-Cfg-MF PIC X(1) VALUE ' '. 225 10 S-Cfg-MVS PIC X(1) VALUE ' '. 226 05 S-EXTRA PIC X(75) VALUE SPACES. 227 05 S-Yes-No-Switches. 228 10 S-DEBUG PIC X(1) VALUE 'N'. 229 10 S-DLL PIC X(1) VALUE 'N'. 230GC0410 10 S-XREF PIC X(1) VALUE 'N'. 231GC0410 10 S-SOURCE PIC X(1) VALUE 'N'. 232 10 S-EXECUTE PIC X(1) VALUE 'N'. 233 10 S-NOTRUNC PIC X(1) VALUE 'Y'. 234 10 S-SUBROUTINE PIC X(1) VALUE 'A'. 235 10 S-TRACE PIC X(1) VALUE 'N'. 236 10 S-TRACEALL PIC X(1) VALUE 'N'. 237 238 01 Tally USAGE BINARY-LONG. 239 240 SCREEN SECTION. 241 *> 242 *> Here is the layout of the OCic screen. 243 *> 244 *> Note that this program can utilize the traditional PC line-drawing characters, 245 *> if they are available. 246 *> 247 *> If this program is run on Windows, it must run with codepage 437 activated to 248 *> display the line-drawing characters. With a native Windows build or a 249 *> Windows/MinGW build, one could use the command "chcp 437" to set that codepage 250 *> for display within a Windows console window (that should be the default, though). 251 *> With a Windows/Cygwin build, set the environment variable CYGWIN to a value of 252 *> "codepage:oem" (this cannot be done from within the program though - you will 253 *> have to use the "Computer/Advanced System Settings/Environment Variables" (Vista or 254 *> Windows 7) function to define the variable. XP Users: use "My Computer/Properties/ 255 *> Advanced/Environment Variables". 256 *> 257 *> To use OCic without the line-drawing characters, comment-out the first set of 258 *> 78 "LD" items and uncomment the second. 259 *> 260 *> The following sample screen layout shows how the screen looks with line-drawing 261 *> characters disabled. 262 *> 263 *>=================================================================================== 264 *> OCic (2010/04/02 11:36) - OpenCOBOL V1.1 Interactive Compilation Windows 01 265 *> +-----------------------------------------------------------------------------+ 02 266 *> | Program: OCic F-Key: Select Opt | 03 267 *> | Folder: E:\OpenCOBOL\Samples Enter: Compile | 04 268 *> | Filename: OCic.cbl Esc: Quit | 05 269 *> +-----------------------------------------------------------------------------+ 06 270 *> On/Off Switches: Configuration: 07 271 *> +---------------------------------------------------------+-------------------+ 08 272 *> | F1 Compile debug lines F8 Produce source listing | S-F1 BS2000 | 09 273 *> | F2 Always make DLLs F9 Produce xref listing | S-F2 COBOL85 | 10 274 *> | F3 Pgm is a SUBROUTINE | S-F3 COBOL2002 | 11 275 *> | F4 Execute if compile OK | S-F4 > Default | 12 276 *> | F5 > No COMP/BINARY trunc | S-F5 IBM | 13 277 *> | F6 Trace procedures | S-F6 MicroFocus | 14 278 *> | F7 Trace proc + stmnts | S-F7 MVS | 15 279 *> +---------------------------------------------------------+-------------------+ 16 280 *> Additional "cobc" Switches (if any): 17 281 *> +-----------------------------------------------------------------------------+ 18 282 *> | -O2________________________________________________________________________ | 19 283 *> +-----------------------------------------------------------------------------+ 20 284 *> Program Execution Arguments (if any): 21 285 *> +-----------------------------------------------------------------------------+ 22 286 *> | ___________________________________________________________________________ | 23 287 *> +-----------------------------------------------------------------------------+ 24 288 *> OCic Copyright (C) 2009-2010, Gary L. Cutler, GPL 25 289 *>=================================================================================== 290 *>12345678901234567890123456789012345678901234567890123456789012345678901234567890 291 *> 1 2 3 4 5 6 7 8 292 *> 293 *> USE THESE CHARS FOR LINE-DRAWING IF YOU HAVE ACCESS TO PC-DOS CODEPAGE 437: 294 *> 295 78 LD-UL-Corner VALUE X"DA". 296 78 LD-LL-Corner VALUE X"C0". 297 78 LD-UR-Corner VALUE X"BF". 298 78 LD-LR-Corner VALUE X"D9". 299 78 LD-Upper-T VALUE X"C2". 300 78 LD-Lower-T VALUE X"C1". 301 78 LD-Horiz-Line VALUE X"C4". 302 78 LD-Vert-Line VALUE X"B3". 303 *> 304 *> USE THESE CHARS FOR LINE-DRAWING IF YOU DO NOT HAVE ACCESS TO PC-DOS CODEPAGE 437: 305 *> 306 *> 78 LD-UL-Corner VALUE '+'. 307 *> 78 LD-LL-Corner VALUE '+'. 308 *> 78 LD-UR-Corner VALUE '+'. 309 *> 78 LD-LR-Corner VALUE '+'. 310 *> 78 LD-Upper-T VALUE '+'. 311 *> 78 LD-Lower-T VALUE '+'. 312 *> 78 LD-Horiz-Line VALUE '-'. 313 *> 78 LD-Vert-Line VALUE '|'. 314 *> 315 01 Blank-Screen LINE 1 COLUMN 1 BLANK SCREEN. 316 317 01 Switches-Screen BACKGROUND-COLOR COB-COLOR-BLACK 318 FOREGROUND-COLOR COB-COLOR-WHITE AUTO. 319 *> 320 *> GENERAL SCREEN FRAMEWORK 321 *> 322 03 BACKGROUND-COLOR COB-COLOR-BLACK 323 FOREGROUND-COLOR COB-COLOR-BLUE HIGHLIGHT. 324 05 LINE 02 COL 02 VALUE LD-UL-Corner. 325 05 PIC X(77) FROM Horizontal-Line. 326 05 COL 80 VALUE LD-UR-Corner. 327 328 05 LINE 03 COL 02 VALUE LD-Vert-Line. 329 05 COL 80 VALUE LD-Vert-Line. 330 331 05 LINE 04 COL 02 VALUE LD-Vert-Line. 332 05 COL 80 VALUE LD-Vert-Line. 333 334 05 LINE 05 COL 02 VALUE LD-Vert-Line. 335 05 COL 80 VALUE LD-Vert-Line. 336 337 05 LINE 06 COL 02 VALUE LD-LL-Corner. 338 05 PIC X(77) FROM Horizontal-Line. 339 05 COL 80 VALUE LD-LR-Corner. 340 341 05 LINE 08 COL 02 VALUE LD-UL-Corner. 342 05 PIC X(57) FROM Horizontal-Line. 343 05 COL 60 VALUE LD-Upper-T. 344 05 PIC X(19) FROM Horizontal-Line. 345 05 COL 80 VALUE LD-UR-Corner. 346 347 05 LINE 09 COL 02 VALUE LD-Vert-Line. 348 05 COL 60 VALUE LD-Vert-Line. 349 05 COL 80 VALUE LD-Vert-Line. 350 351 05 LINE 10 COL 02 VALUE LD-Vert-Line. 352 05 COL 60 VALUE LD-Vert-Line. 353 05 COL 80 VALUE LD-Vert-Line. 354 355 05 LINE 11 COL 02 VALUE LD-Vert-Line. 356 05 COL 60 VALUE LD-Vert-Line. 357 05 COL 80 VALUE LD-Vert-Line. 358 359 05 LINE 12 COL 02 VALUE LD-Vert-Line. 360 05 COL 60 VALUE LD-Vert-Line. 361 05 COL 80 VALUE LD-Vert-Line. 362 363 05 LINE 13 COL 02 VALUE LD-Vert-Line. 364 05 COL 60 VALUE LD-Vert-Line. 365 05 COL 80 VALUE LD-Vert-Line. 366 367 05 LINE 14 COL 02 VALUE LD-Vert-Line. 368 05 COL 60 VALUE LD-Vert-Line. 369 05 COL 80 VALUE LD-Vert-Line. 370 371 05 LINE 15 COL 02 VALUE LD-Vert-Line. 372 05 COL 60 VALUE LD-Vert-Line. 373 05 COL 80 VALUE LD-Vert-Line. 374 375 05 LINE 16 COL 02 VALUE LD-LL-Corner. 376 05 PIC X(57) FROM Horizontal-Line. 377 05 COL 60 VALUE LD-Lower-T. 378 05 PIC X(19) FROM Horizontal-Line. 379 05 COL 80 VALUE LD-LR-Corner. 380 381 05 LINE 18 COL 02 VALUE LD-UL-Corner. 382 05 PIC X(77) FROM Horizontal-Line. 383 05 COL 80 VALUE LD-UR-Corner. 384 385 05 LINE 19 COL 02 VALUE LD-Vert-Line. 386 05 COL 80 VALUE LD-Vert-Line. 387 388 05 LINE 20 COL 02 VALUE LD-LL-Corner. 389 05 PIC X(77) FROM Horizontal-Line. 390 05 COL 80 VALUE LD-LR-Corner. 391 392 05 LINE 22 COL 02 VALUE LD-UL-Corner. 393 05 PIC X(77) FROM Horizontal-Line. 394 05 COL 80 VALUE LD-UR-Corner. 395 396 05 LINE 23 COL 02 VALUE LD-Vert-Line. 397 05 COL 80 VALUE LD-Vert-Line. 398 399 05 LINE 24 COL 02 VALUE LD-LL-Corner. 400 05 PIC X(77) FROM Horizontal-Line. 401 05 COL 80 VALUE LD-LR-Corner. 402 *> 403 *> TOP AND BOTTOM LINES 404 *> 405 03 BACKGROUND-COLOR COB-COLOR-BLUE BLINK 406 FOREGROUND-COLOR COB-COLOR-WHITE HIGHLIGHT. 407GC0410 05 LINE 01 COL 01 VALUE ' OCic ('. 408GC0410 05 PIC X(16) FROM OC-Compiled. 409GC0410 05 VALUE ') OpenCOBOL V1.1 06FEB2009 ' & 410GC0410 'Interactive Compilation '. 411GC0410 05 LINE 25 COL 01 PIC X(81) FROM Output-Message. 412 *> 413 *> LABELS 414 *> 415 03 BACKGROUND-COLOR COB-COLOR-BLACK 416 FOREGROUND-COLOR COB-COLOR-CYAN HIGHLIGHT. 417 05 LINE 07 COL 04 VALUE 'On/Off Switches:'. 418 05 COL 62 VALUE 'Configuration:'. 419 05 LINE 17 COL 04 VALUE 'Additional "cobc" Switches (if any 420 - '):'. 421 05 LINE 21 COL 04 VALUE 'Program Execution Arguments (if an 422 - 'y):'. 423 *> 424 *> TOP SECTION BACKGROUND 425 *> 426 03 BACKGROUND-COLOR COB-COLOR-BLACK 427 FOREGROUND-COLOR COB-COLOR-CYAN LOWLIGHT. 428 05 LINE 03 COL 04 VALUE 'Program: '. 429 05 LINE 04 COL 04 VALUE 'Folder: '. 430 05 LINE 05 COL 04 VALUE 'Filename: '. 431 432 05 LINE 03 COL 62 VALUE 'F-Key: Select Opt'. 433 05 LINE 04 COL 62 VALUE 'Enter: Compile '. 434 05 LINE 05 COL 62 VALUE 'Esc: Quit '. 435 *> 436 *> TOP SECTION PROGRAM INFO 437 *> 438 03 BACKGROUND-COLOR COB-COLOR-BLACK 439 FOREGROUND-COLOR COB-COLOR-WHITE HIGHLIGHT. 440 05 LINE 03 COL 14 PIC X(47) FROM Prog-Name. 441 05 LINE 04 COL 14 PIC X(47) FROM Prog-Folder. 442 05 LINE 05 COL 14 PIC X(47) FROM Prog-File-Name. 443 *> 444 *> MIDDLE LEFT SECTION F-KEYS 445 *> 446 03 BACKGROUND-COLOR COB-COLOR-BLACK 447 FOREGROUND-COLOR COB-COLOR-WHITE HIGHLIGHT. 448 05 LINE 09 COL 04 VALUE 'F1'. 449 05 LINE 10 COL 04 VALUE 'F2'. 450 05 LINE 11 COL 04 VALUE 'F3'. 451 05 LINE 12 COL 04 VALUE 'F4'. 452 05 LINE 13 COL 04 VALUE 'F5'. 453 05 LINE 14 COL 04 VALUE 'F6'. 454 05 LINE 15 COL 04 VALUE 'F7'. 455 05 LINE 09 COL 32 VALUE 'F8'. 456 05 LINE 10 COL 32 VALUE 'F9'. 457 *> 458 *> MIDDLE LEFT SECTION SWITCHES 459 *> 460 03 BACKGROUND-COLOR COB-COLOR-BLACK 461 FOREGROUND-COLOR COB-COLOR-RED HIGHLIGHT. 462 05 LINE 09 COL 07 PIC X(1) FROM S-DEBUG. 463 05 LINE 10 COL 07 PIC X(1) FROM S-DLL. 464 05 LINE 11 COL 07 PIC X(1) FROM S-SUBROUTINE. 465 05 LINE 12 COL 07 PIC X(1) FROM S-EXECUTE. 466 05 LINE 13 COL 07 PIC X(1) FROM S-NOTRUNC. 467 05 LINE 14 COL 07 PIC X(1) FROM S-TRACE. 468 05 LINE 15 COL 07 PIC X(1) FROM S-TRACEALL. 469 05 LINE 09 COL 35 PIC X(1) FROM S-SOURCE. 470 05 LINE 10 COL 35 PIC X(1) FROM S-XREF. 471 *> 472 *> MIDDLE LEFT SECTION BACKGROUND 473 *> 474 03 BACKGROUND-COLOR COB-COLOR-BLACK 475 FOREGROUND-COLOR COB-COLOR-CYAN LOWLIGHT. 476 05 LINE 09 COL 09 VALUE 'Compile debug lines '. 477 05 LINE 10 COL 09 VALUE 'Always make DLLs '. 478 05 LINE 11 COL 09 VALUE 'Pgm is a SUBROUTINE '. 479 05 LINE 12 COL 09 VALUE 'Execute if compile OK '. 480 05 LINE 13 COL 09 VALUE 'No COMP/BINARY trunc '. 481 05 LINE 14 COL 09 VALUE 'Trace procedures '. 482 05 LINE 15 COL 09 VALUE 'Trace proc + stmnts '. 483 05 LINE 09 COL 37 VALUE 'Produce source listing'. 484 05 LINE 10 COL 37 VALUE 'Produce xref listing '. 485 *> 486 *> MIDDLE RIGHT SECTION F-KEYS 487 *> 488 03 BACKGROUND-COLOR COB-COLOR-BLACK 489 FOREGROUND-COLOR COB-COLOR-WHITE HIGHLIGHT. 490 05 LINE 09 COL 62 VALUE 'S-F1'. 491 05 LINE 10 COL 62 VALUE 'S-F2'. 492 05 LINE 11 COL 62 VALUE 'S-F3'. 493 05 LINE 12 COL 62 VALUE 'S-F4'. 494 05 LINE 13 COL 62 VALUE 'S-F5'. 495 05 LINE 14 COL 62 VALUE 'S-F6'. 496 05 LINE 15 COL 62 VALUE 'S-F7'. 497 *> 498 *> MIDDLE RIGHT SECTION SWITCHES 499 *> 500 03 BACKGROUND-COLOR COB-COLOR-BLACK 501 FOREGROUND-COLOR COB-COLOR-RED HIGHLIGHT. 502 05 LINE 09 COL 67 PIC X(1) FROM S-Cfg-BS2000. 503 05 LINE 10 COL 67 PIC X(1) FROM S-Cfg-COBOL85. 504 05 LINE 11 COL 67 PIC X(1) FROM S-Cfg-COBOL2002. 505 05 LINE 12 COL 67 PIC X(1) FROM S-Cfg-DEFAULT. 506 05 LINE 13 COL 67 PIC X(1) FROM S-Cfg-IBM. 507 05 LINE 14 COL 67 PIC X(1) FROM S-Cfg-MF. 508 05 LINE 15 COL 67 PIC X(1) FROM S-Cfg-MVS. 509 *> 510 *> MIDDLE RIGHT SECTION BACKGROUND 511 *> 512 03 BACKGROUND-COLOR COB-COLOR-BLACK 513 FOREGROUND-COLOR COB-COLOR-CYAN LOWLIGHT. 514 05 LINE 09 COL 69 VALUE 'BS2000 '. 515 05 LINE 10 COL 69 VALUE 'COBOL85 '. 516 05 LINE 11 COL 69 VALUE 'COBOL2002 '. 517 05 LINE 12 COL 69 VALUE 'Default '. 518 05 LINE 13 COL 69 VALUE 'IBM '. 519 05 LINE 14 COL 69 VALUE 'MicroFocus'. 520 05 LINE 15 COL 69 VALUE 'MVS '. 521 *> 522 *> FREE-FORM OPTIONS FIELDS 523 *> 524 03 BACKGROUND-COLOR COB-COLOR-BLACK 525 FOREGROUND-COLOR COB-COLOR-WHITE HIGHLIGHT. 526 05 LINE 19 COL 04 PIC X(75) USING S-EXTRA. 527 05 LINE 23 COL 04 PIC X(75) USING S-ARGS. 528 / 529 PROCEDURE DIVISION. 530 ***************************************************************** 531 ** Legend to procedure names: ** 532 ** ** 533 ** 00x-xxx All MAIN driver procedures ** 534 ** 0xx-xxx All GLOBAL UTILITY procedures ** 535 ** 1xx-xxx All INITIALIZATION procedures ** 536 ** 2xx-xxx All CORE PROCESSING procedures ** 537 ** 9xx-xxx All TERMINATION procedures ** 538 ***************************************************************** 539 DECLARATIVES. 540 000-File-Error SECTION. 541 USE AFTER STANDARD ERROR PROCEDURE ON Source-Code. 542 000-Handle-Error. 543 COPY FileStat-Msgs 544 REPLACING STATUS BY FSM-Status 545 MSG BY FSM-Msg. 546 MOVE SPACES TO Output-Message 547 IF FSM-Status = 35 548 DISPLAY 549 'File not found: "' 550 TRIM(File-Name,TRAILING) 551 '"' 552 END-DISPLAY 553 ELSE 554 DISPLAY 555 'Error accessing file: "' 556 TRIM(File-Name,TRAILING) 557 '"' 558 END-DISPLAY 559 END-IF 560 GOBACK 561 . 562 END DECLARATIVES. 563 / 564 000-Main SECTION. 565 566 PERFORM 100-Initialization 567GC0609 SET 88-Not-Complete TO TRUE 568GC0609 PERFORM UNTIL 88-Complete 569GC0609 PERFORM 200-Let-User-Set-Switches 570GC0609 PERFORM 210-Run-Compiler 571GC0410 IF (88-Compile-OK OR 88-Compile-OK-Warn) 572GC0410 AND (S-XREF NOT = SPACE OR S-SOURCE NOT = SPACE) 573GC0410 PERFORM 220-Make-Listing 574GC0410 END-IF 575GC0709 IF (S-EXECUTE NOT = SPACES) 576GC0709 AND (88-Output-File-Avail) 577GC0609 PERFORM 230-Run-Program 578GC0609 END-IF 579GC0609 END-PERFORM 580 . 581 582 009-Done. 583 PERFORM 900-Terminate 584 . 585 * -- Control will NOT return 586 / 587 010-Parse-Args SECTION. 588 ***************************************************************** 589 ** Process a sequence of KEYWORD=VALUE items. These are items ** 590 ** specified on the command-line to provide the initial ** 591 ** options shown selected on the screen. When integrating ** 592 ** OCic into an edirot or framework, include these switches on ** 593 ** the ocic.exe command the editor/framework executes. Any ** 594 ** underlined choice is the default value for that switch. ** 595 ** ** 596 ** @CONFIG=BS2000|COBOL85|COBOL2002|DEFAULT|IBM|MF|MVS ** 597 ** ======= ** 598 ** This switch specifies the default cobc compiler configura- ** 599 ** tion file to be used ** 600 ** ** 601 ** @DEBUG=YES|NO ** 602 ** == ** 603 ** This switch specifies whether (YES) or not (NO) debugging ** 604 ** lines (those with a "D" in column 7) will be compiled. ** 605 ** ** 606 ** @DLL=YES|NO ** 607 ** == ** 608 ** Use this switch to force ALL compiled programs to be built ** 609 ** as DLLs ("@DLL=YES"). When main programs are built as DLLs ** 610 ** they must be executed using the cobcrun utility. When ** 611 ** "@DLL=NO" is in effect, main programs are generated as ** 612 ** actual "exe" files and only subprograms will be generated ** 613 ** as DLLs. ** 614 ** ** 615 ** @EXECUTE=YES|NO ** 616 ** == ** 617 ** This switch specifies whether ("@EXECUTE=YES") or not ** 618 ** ("@EXECUTE=NO") the program will be executed after it is ** 619 ** successfully compiled. ** 620 ** ** 621 ** @EXTRA=extra cobc argument(s) ** 622 ** ** 623 ** This switch allows you to specify additional cobc arguments ** 624 ** that aren't managed by the other OC switches. If used, ** 625 ** this must be the last switch specified on the command line, ** 626 ** as everything that follows the "=" will be placed on the ** 627 ** cobc command generated by OC. ** 628 ** ** 629 ** @NOTRUNC=YES|NO ** 630 ** === ** 631 ** This switch specifies whether (YES) or not (NO) the sup- ** 632 ** pression of binary field truncation will occur. If a PIC ** 633 ** 99 COMP field (one byte of storage), for example, is given ** 634 ** the value 123, it may have its value truncated to 23 when ** 635 ** DISPLAYed. Regardless of the NOTRUNC setting, internally ** 636 ** the full precision of the field (allowing a maximum value ** 637 ** of 255) will be preserved. Even though truncation - if it ** 638 ** does occur - would appear to have a minimal disruption on ** 639 ** program operation, it has a significant effect on program ** 640 ** run-time speed. ** 641 ** ** 642 ** @TRACE=YES|NO|ALL ** 643 ** == ** 644 ** This switch controls whether or not code will be added to ** 645 ** the object program to produce execution-time logic traces. ** 646 ** A specification of "@TRACE=NO" means no such code will be ** 647 ** produced. By specifying "@TRACE=YES", code will be genera- ** 648 ** ted to display procedure names as they are entered. A ** 649 ** "@TRACE=ALL" specification will generate not only procedure ** 650 ** traces (as "@TRACE=YES" would) but also statement-level ** 651 ** traces too! All trace output is written to STDERR, so ** 652 ** adding a "2>file" to the execution of the program will pipe ** 653 ** the trace output to a file. You may find it valuable to ** 654 ** add your own DISPLAY statements to the debugging output via ** 655 ** "DISPLAY xx UPON SYSERR" The SYSERR device corresponds to ** 656 ** the Windows or UNIX STDERR device and will therefore honor ** 657 ** any "2>file" placed at the end of your program's execution. ** 658 ** Add a "D" in column 7 and you can control the generation or ** 659 ** ignoring of these DISPLAY statements via the "@DEBUG" ** 660 ** switch. ** 661 ** ** 662GC0410** @SOURCE=YES|NO ** 663GC0410** == ** 664GC0410** Use this switch to produce a source listing of the program, ** 665GC0410** PROVIDED it compiles without errors. ** 666 ** ** 667GC0410** @XREF=YES|NO ** 668GC0410** == ** 669GC0410** Use this switch to produce a cross-reference listing of the ** 670GC0410** program, PROVIDED it compiles without errors. ** 671 ***************************************************************** 672 673 011-Init. 674 MOVE 1 TO I 675 . 676 677 012-Extract-Kwd-And-Value. 678 PERFORM UNTIL I NOT < LENGTH(Command-Line-Args) 679 MOVE I TO J 680 UNSTRING Command-Line-Args 681 DELIMITED BY ALL SPACES 682 INTO Switch-Keyword-And-Value 683 WITH POINTER I 684 END-UNSTRING 685 IF Switch-Keyword-And-Value NOT = SPACES 686 UNSTRING Switch-Keyword-And-Value 687 DELIMITED BY '=' 688 INTO Switch-Keyword, Switch-Value 689 END-UNSTRING 690 PERFORM 030-Process-Keyword 691 END-IF 692 END-PERFORM 693 . 694 695 019-Done. 696 EXIT. 697 698 ***************************************************************** 699 ** Since this program uses the SCREEN SECTION, it cannot do ** 700 ** conventional console DISPLAY operations. This routine ** 701 ** (which, I admit, is like using an H-bomb to hunt rabbits) ** 702 ** will submit an "ECHO" command to the system to simulate a ** 703 ** DISPLAY. ** 704 ***************************************************************** 705 021-Build-And-Issue-Command. 706 DISPLAY 707 Output-Message 708 END-DISPLAY 709 . 710 711 029-Done. 712 EXIT. 713 / 714 030-Process-Keyword SECTION. 715 ***************************************************************** 716 ** Process a single KEYWORD=VALUE item. ** 717 ***************************************************************** 718 719 031-Init. 720 MOVE UPPER-CASE(Switch-Keyword) TO Switch-Keyword 721 SET 88-Switch-Is-Good TO TRUE 722 . 723 724 032-Process. 725 EVALUATE TRUE 726 WHEN Switch-Is-EXTRA 727GC0410 MOVE J TO I 728 UNSTRING Command-Line-Args DELIMITED BY '=' 729 INTO Dummy, S-EXTRA 730GC0410 WITH POINTER I 731GC0410 END-UNSTRING 732 MOVE LENGTH(Command-Line-Args) TO I 733 WHEN Switch-Is-CONFIG 734 MOVE 'CONFIG' TO Switch-Keyword 735 MOVE UPPER-CASE(Switch-Value) 736 TO Switch-Value 737 EVALUATE Switch-Value 738 WHEN 'BS2000' 739 MOVE SPACES TO S-CfgS 740 MOVE Selection-Char TO S-Cfg-BS2000 741 WHEN 'COBOL85' 742 MOVE SPACES TO S-CfgS 743 MOVE Selection-Char TO S-Cfg-COBOL85 744 WHEN 'COBOL2002' 745 MOVE SPACES TO S-CfgS 746 MOVE Selection-Char TO S-Cfg-COBOL2002 747 WHEN 'DEFAULT' 748 MOVE SPACES TO S-CfgS 749 MOVE Selection-Char TO S-Cfg-DEFAULT 750 WHEN 'IBM' 751 MOVE SPACES TO S-CfgS 752 MOVE Selection-Char TO S-Cfg-IBM 753 WHEN 'MF' 754 MOVE SPACES TO S-CfgS 755 MOVE Selection-Char TO S-Cfg-MF 756 WHEN 'MVS' 757 MOVE SPACES TO S-CfgS 758 MOVE Selection-Char TO S-Cfg-MVS 759 WHEN OTHER 760 MOVE 'An invalid /CONFIG switch value ' & 761 'was specified on the command line ' & 762 '- ignored' 763 TO Output-Message 764 END-EVALUATE 765 WHEN Switch-Is-DEBUG 766 MOVE 'DEBUG' TO Switch-Keyword 767 MOVE UPPER-CASE(Switch-Value) 768 TO Switch-Value 769 PERFORM 040-Process-Yes-No-Value 770 IF 88-Switch-Is-Good 771 MOVE SV-1 TO S-DEBUG 772 END-IF 773GC0410 WHEN Switch-Is-DLL 774GC0410 MOVE 'DLL' TO Switch-Keyword 775GC0410 MOVE UPPER-CASE(Switch-Value) 776GC0410 TO Switch-Value 777GC0410 PERFORM 040-Process-Yes-No-Value 778GC0410 IF 88-Switch-Is-Good 779GC0410 MOVE SV-1 TO S-DLL 780GC0410 END-IF 781 WHEN Switch-Is-EXECUTE 782 MOVE 'EXECUTE' TO Switch-Keyword 783 MOVE UPPER-CASE(Switch-Value) 784 TO Switch-Value 785 PERFORM 040-Process-Yes-No-Value 786 IF 88-Switch-Is-Good 787 MOVE SV-1 TO S-EXECUTE 788 END-IF 789 WHEN Switch-Is-NOTRUNC 790 MOVE 'NOTRUNC' TO Switch-Keyword 791 MOVE UPPER-CASE(Switch-Value) 792 TO Switch-Value 793 PERFORM 040-Process-Yes-No-Value 794 IF 88-Switch-Is-Good 795 MOVE SV-1 TO S-NOTRUNC 796 END-IF 797GC0410 WHEN Switch-Is-SOURCE 798GC0410 MOVE 'SOURCE' TO Switch-Keyword 799GC0410 MOVE UPPER-CASE(Switch-Value) 800GC0410 TO Switch-Value 801GC0410 PERFORM 050-Process-Yes-No-All 802GC0410 IF 88-Switch-Is-Good 803GC0410 MOVE SV-1 TO S-SOURCE 804GC0410 END-IF 805 WHEN Switch-Is-TRACE 806 MOVE 'TRACE' TO Switch-Keyword 807 MOVE UPPER-CASE(Switch-Value) 808 TO Switch-Value 809 PERFORM 050-Process-Yes-No-All 810 IF 88-Switch-Is-Good 811 MOVE SV-1 TO S-TRACE 812 END-IF 813GC0410 WHEN Switch-Is-XREF 814GC0410 MOVE 'XREF' TO Switch-Keyword 815GC0410 MOVE UPPER-CASE(Switch-Value) 816GC0410 TO Switch-Value 817GC0410 PERFORM 050-Process-Yes-No-All 818GC0410 IF 88-Switch-Is-Good 819GC0410 MOVE SV-1 TO S-XREF 820GC0410 END-IF 821 WHEN OTHER 822 MOVE SPACES TO Output-Message 823 STRING '"' 824 TRIM(Switch-Keyword) 825 '" is not a valid switch ' & 826 '- ignored' 827 DELIMITED SIZE 828 INTO Output-Message 829 END-STRING 830 SET 88-Switch-Is-Bad TO TRUE 831 END-EVALUATE 832 . 833 834 039-Done. 835 EXIT. 836 / 837 040-Process-Yes-No-Value SECTION. 838 ***************************************************************** 839 ** Process a switch value of YES or NO ** 840 ***************************************************************** 841 842 042-Process. 843 EVALUATE SV-1 844 WHEN 'Y' 845 MOVE 'YES' TO Switch-Value 846 WHEN 'N' 847 MOVE 'NO' To Switch-Value 848 WHEN OTHER 849 MOVE SPACES TO Output-Message 850 STRING '*ERROR: "' TRIM(Switch-Value) 851 '" is not a valid value for the "' 852 TRIM(Switch-Keyword) '" switch' 853 DELIMITED SPACES 854 INTO Output-Message 855 END-STRING 856 SET 88-Switch-Is-Bad TO TRUE 857 END-EVALUATE 858 . 859 860 049-Done. 861 EXIT. 862 / 863 050-Process-Yes-No-All SECTION. 864 ***************************************************************** 865 ** Process a switch value of YES, NO or ALL ** 866 ***************************************************************** 867 868 052-Process. 869 IF SV-1 = 'A' 870 MOVE 'ALL' TO Switch-Value 871 ELSE 872 PERFORM 040-Process-Yes-No-Value 873 END-IF 874 . 875 876 059-Done. 877 EXIT. 878 / 879 060-Process-Yes-No-Auto SECTION. 880 ***************************************************************** 881 ** Process a switch value of YES, NO or AUTO ** 882 ***************************************************************** 883 884 061-Init. 885 IF SV-1 = 'A' 886 PERFORM 070-Find-LINKAGE-SECTION 887 IF 88-Compile-As-Subpgm 888 MOVE 'Y' TO Switch-Value 889 ELSE 890 MOVE 'N' TO Switch-Value 891 END-IF 892 ELSE 893 PERFORM 040-Process-Yes-No-Value 894 END-IF 895 . 896 / 897 070-Find-LINKAGE-SECTION SECTION. 898 ***************************************************************** 899 ** Determine if the program being compiled is a MAIN program ** 900 ***************************************************************** 901 902 071-Init. 903 OPEN INPUT Source-Code 904 SET 88-Compile-As-Mainpgm TO TRUE 905 SET 88-More-To-1st-Prog TO TRUE 906 PERFORM UNTIL 88-1st-Prog-Complete 907 READ Source-Code AT END 908 CLOSE Source-Code 909 EXIT SECTION 910 END-READ 911 CALL 'CHECKSOURCE' USING Source-Code-Record 912 F-Source-Record-Type 913 END-CALL 914 IF 88-Source-Rec-Ident 915 SET 88-1st-Prog-Complete TO TRUE 916 END-IF 917 END-PERFORM 918 . 919 920 072-Process-Source. 921 SET 88-Source-Rec-IgnoCOB-COLOR-RED TO TRUE 922 PERFORM UNTIL 88-Source-Rec-Linkage 923 OR 88-Source-Rec-Ident 924 READ Source-Code AT END 925 CLOSE Source-Code 926 EXIT SECTION 927 END-READ 928 CALL 'CHECKSOURCE' USING Source-Code-Record 929 F-Source-Record-Type 930 END-CALL 931 END-PERFORM 932 CLOSE Source-Code 933 IF 88-Source-Rec-Linkage 934 SET 88-Compile-As-Subpgm TO TRUE 935 END-IF 936 . 937 938 079-Done. 939 EXIT. 940 / 941 100-Initialization SECTION. 942 ***************************************************************** 943 ** Perform all program-wide initialization operations ** 944 ***************************************************************** 945 946 947GC0909 101-Determine-OS-Type. 948GC0909 CALL 'GETOSTYPE' 949GC0909 END-CALL 950GC0909 MOVE RETURN-CODE TO OS-Type 951GC0909 EVALUATE TRUE 952GC0909 WHEN OS-Unknown 953GC0909 MOVE '\' TO Dir-Char 954GC0909 MOVE 'Unknown' TO OS-Type-Literal 955GC0310 MOVE COB-SCR-F11 TO CK-S-F1 956GC0310 MOVE COB-SCR-F12 TO CK-S-F2 957GC0310 MOVE COB-SCR-F13 TO CK-S-F3 958GC0310 MOVE COB-SCR-F14 TO CK-S-F4 959GC0310 MOVE COB-SCR-F15 TO CK-S-F5 960GC0310 MOVE COB-SCR-F16 TO CK-S-F6 961GC0310 MOVE COB-SCR-F17 TO CK-S-F7 962GC0909 WHEN OS-Windows 963GC0909 MOVE '\' TO Dir-Char 964GC0909 MOVE 'Windows' TO OS-Type-Literal 965GC0310 MOVE COB-SCR-F13 TO CK-S-F1 966GC0310 MOVE COB-SCR-F14 TO CK-S-F2 967GC0310 MOVE COB-SCR-F15 TO CK-S-F3 968GC0310 MOVE COB-SCR-F16 TO CK-S-F4 969GC0310 MOVE COB-SCR-F17 TO CK-S-F5 970GC0310 MOVE COB-SCR-F18 TO CK-S-F6 971GC0310 MOVE COB-SCR-F19 TO CK-S-F7 972GC0909 WHEN OS-Cygwin 973GC0909 MOVE '/' TO Dir-Char 974GC0410 MOVE 'Cygwin' TO OS-Type-Literal 975GC0310 MOVE COB-SCR-F11 TO CK-S-F1 976GC0310 MOVE COB-SCR-F12 TO CK-S-F2 977GC0310 MOVE COB-SCR-F13 TO CK-S-F3 978GC0310 MOVE COB-SCR-F14 TO CK-S-F4 979GC0310 MOVE COB-SCR-F15 TO CK-S-F5 980GC0310 MOVE COB-SCR-F16 TO CK-S-F6 981GC0310 MOVE COB-SCR-F17 TO CK-S-F7 982GC0909 WHEN OS-UNIX 983GC0909 MOVE '/' TO Dir-Char 984GC0410 MOVE 'UNIX ' TO OS-Type-Literal 985GC0310 MOVE COB-SCR-F11 TO CK-S-F1 986GC0310 MOVE COB-SCR-F12 TO CK-S-F2 987GC0310 MOVE COB-SCR-F13 TO CK-S-F3 988GC0310 MOVE COB-SCR-F14 TO CK-S-F4 989GC0310 MOVE COB-SCR-F15 TO CK-S-F5 990GC0310 MOVE COB-SCR-F16 TO CK-S-F6 991GC0310 MOVE COB-SCR-F17 TO CK-S-F7 992GC0909 END-EVALUATE 993GC0909 . 994 995 102-Set-Environment-Vars. 996 SET ENVIRONMENT 'COB_SCREEN_EXCEPTIONS' TO 'Y' 997 SET ENVIRONMENT 'COB_SCREEN_ESC' TO 'Y' 998 . 999 1000 103-Generate-Cobc-Output-Fn. 1001 ACCEPT Env-TEMP 1002 FROM ENVIRONMENT "TEMP" 1003 END-ACCEPT 1004 MOVE SPACES TO Cobc-Output-File 1005 STRING TRIM(Env-TEMP,TRAILING) 1006GC0909 Dir-Char 1007GC0909 'OC-Messages.TXT' 1008 DELIMITED SIZE 1009 INTO Cobc-Output-File 1010 END-STRING 1011 . 1012 1013 104-Generate-Banner-Line-Info. 1014 MOVE WHEN-COMPILED (1:12) TO OC-Compiled 1015 INSPECT OC-Compiled 1016 REPLACING ALL '/' BY ':' 1017 AFTER INITIAL SPACE 1018 . 1019 1020 105-Establish-Switch-Settings. 1021 ACCEPT Command-Line-Args 1022 FROM COMMAND-LINE 1023 END-ACCEPT 1024 MOVE TRIM(Command-Line-Args, Leading) 1025 TO Command-Line-Args 1026 MOVE 0 TO Tally 1027GC0410 INSPECT Command-Line-Args TALLYING Tally FOR ALL '@' 1028 IF Tally = 0 1029 MOVE Command-Line-Args TO File-Name 1030 MOVE SPACES TO Command-Line-Args 1031 ELSE 1032GC0410 UNSTRING Command-Line-Args DELIMITED BY '@' 1033 INTO File-Name, Dummy 1034 END-UNSTRING 1035 INSPECT Command-Line-Args 1036GC0410 REPLACING FIRST '@' BY LOW-VALUES 1037 UNSTRING Command-Line-Args 1038 DELIMITED BY LOW-VALUES 1039 INTO Dummy, Cmd 1040 END-UNSTRING 1041 MOVE SPACES TO Command-Line-Args 1042GC0410 STRING '@' Cmd DELIMITED SIZE 1043 INTO Command-Line-Args 1044 END-STRING 1045 END-IF 1046 IF File-Name = SPACES 1047 DISPLAY 1048 'No program filename was specified' 1049 END-DISPLAY 1050 PERFORM 900-Terminate 1051 END-IF 1052 PERFORM 010-Parse-Args 1053 IF S-SUBROUTINE = 'A' 1054 MOVE 'S' TO Switch-Keyword 1055 MOVE 'A' TO Switch-Value 1056 PERFORM 070-Find-LINKAGE-SECTION 1057 IF 88-Compile-As-Subpgm 1058 MOVE 'Y' TO S-SUBROUTINE 1059 ELSE 1060 MOVE 'N' TO S-SUBROUTINE 1061 END-IF 1062 END-IF 1063 INSPECT S-Yes-No-Switches REPLACING ALL 'Y' BY Selection-Char 1064 INSPECT S-Yes-No-Switches REPLACING ALL 'N' BY ' ' 1065 . 1066 1067 106-Determine-Folder-Path. 1068 Move 256 TO I 1069GC0909 IF OS-Cygwin AND File-Name (2:1) = ':' 1070GC0909 MOVE '\' TO Dir-Char 1071GC0909 END-IF 1072 PERFORM UNTIL I = 0 OR FN-Char (I) = Dir-Char 1073 SUBTRACT 1 FROM I 1074 END-PERFORM 1075 IF I = 0 1076 MOVE SPACES TO Prog-Folder 1077 MOVE File-Name TO Prog-File-Name 1078 ELSE 1079 MOVE '*' TO FN-Char (I) 1080 UNSTRING File-Name DELIMITED BY '*' 1081 INTO Prog-Folder 1082 Prog-File-Name 1083 END-UNSTRING 1084 MOVE Dir-Char TO FN-Char (I) 1085 END-IF 1086 UNSTRING Prog-File-Name DELIMITED BY '.' 1087 INTO Prog-Name, Prog-Extension 1088 END-UNSTRING 1089 IF Prog-Folder = SPACES 1090 ACCEPT Prog-Folder 1091 FROM ENVIRONMENT 'CD' 1092 END-ACCEPT 1093GC0909 ELSE 1094GC0909 CALL "CBL_CHANGE_DIR" 1095GC0909 USING TRIM(Prog-Folder,TRAILING) 1096GC0909 END-CALL 1097 END-IF 1098GC0909 IF OS-Cygwin AND File-Name (2:1) = ':' 1099GC0909 MOVE '/' TO Dir-Char 1100GC0909 END-IF 1101 . 1102 1103GC0909 107-Other. 1104GC0909 MOVE ALL LD-Horiz-Line TO Horizontal-Line. 1105GC0410 MOVE CONCATENATE(' OCic for ', 1106GC0410 TRIM(OS-Type-Literal,Trailing), 1107GC0410 ' Copyright (C) 2009-2010, Gary L. Cutler,', 1108GC0410 ' GPL') 1109GC0410 TO Output-Message. 1110GC0909 . 1111GC0909 1112 109-Done. 1113 EXIT. 1114 / 1115 200-Let-User-Set-Switches SECTION. 1116 ***************************************************************** 1117 ** Show the user the current switch settings and allow them to ** 1118 ** be changed. ** 1119 ***************************************************************** 1120 1121 201-Init. 1122 SET 88-Switch-Changes TO TRUE 1123 . 1124 1125 202-Show-And-Change-Switches. 1126 PERFORM UNTIL 88-No-Switch-Changes 1127 ACCEPT 1128 Switches-Screen 1129 END-ACCEPT 1130 IF COB-CRT-STATUS > 0 1131 EVALUATE COB-CRT-STATUS 1132 WHEN COB-SCR-F1 1133 IF S-DEBUG = SPACE 1134 MOVE Selection-Char TO S-DEBUG 1135 ELSE 1136 MOVE ' ' TO S-DEBUG 1137 END-IF 1138 WHEN COB-SCR-F2 1139 IF S-DLL = SPACE 1140 MOVE Selection-Char TO S-DLL 1141 ELSE 1142 MOVE ' ' TO S-DLL 1143 END-IF 1144 WHEN COB-SCR-F3 1145 IF S-SUBROUTINE = SPACE 1146 MOVE Selection-Char TO S-SUBROUTINE 1147 MOVE ' ' TO S-EXECUTE 1148 ELSE 1149 MOVE ' ' TO S-SUBROUTINE 1150 END-IF 1151 WHEN COB-SCR-F4 1152 IF S-EXECUTE = SPACE 1153 AND S-SUBROUTINE = SPACE 1154 MOVE Selection-Char TO S-EXECUTE 1155 ELSE 1156 MOVE ' ' TO S-EXECUTE 1157 END-IF 1158 WHEN COB-SCR-F5 1159 IF S-NOTRUNC = SPACE 1160 MOVE Selection-Char TO S-NOTRUNC 1161 ELSE 1162 MOVE ' ' TO S-NOTRUNC 1163 END-IF 1164 WHEN COB-SCR-F6 1165 IF S-TRACE = SPACE 1166 MOVE Selection-Char TO S-TRACE 1167 MOVE ' ' TO S-TRACEALL 1168 ELSE 1169 MOVE ' ' TO S-TRACE 1170 END-IF 1171 WHEN COB-SCR-F7 1172 IF S-TRACEALL = SPACE 1173 MOVE Selection-Char TO S-TRACEALL 1174 MOVE ' ' TO S-TRACE 1175 ELSE 1176 MOVE ' ' TO S-TRACEALL 1177 END-IF 1178GC0410 WHEN COB-SCR-F8 1179GC0410 IF S-SOURCE = SPACE 1180GC0410 MOVE Selection-Char TO S-SOURCE 1181GC0410 ELSE 1182GC0410 MOVE ' ' TO S-SOURCE 1183GC0410 END-IF 1184GC0410 WHEN COB-SCR-F9 1185GC0410 IF S-XREF = SPACE 1186GC0410 MOVE Selection-Char TO S-XREF 1187GC0410 ELSE 1188GC0410 MOVE ' ' TO S-XREF 1189GC0410 END-IF 1190 WHEN COB-SCR-ESC 1191 PERFORM 900-Terminate 1192GC0310 WHEN CK-S-F1 1193 MOVE SPACES TO S-CfgS 1194 MOVE Selection-Char TO S-Cfg-BS2000 1195GC0310 WHEN CK-S-F2 1196 MOVE SPACES TO S-CfgS 1197 MOVE Selection-Char TO S-Cfg-COBOL85 1198GC0310 WHEN CK-S-F3 1199 MOVE SPACES TO S-CfgS 1200 MOVE Selection-Char TO S-Cfg-COBOL2002 1201GC0310 WHEN CK-S-F4 1202 MOVE SPACES TO S-CfgS 1203 MOVE Selection-Char TO S-Cfg-DEFAULT 1204GC0310 WHEN CK-S-F5 1205 MOVE SPACES TO S-CfgS 1206 MOVE Selection-Char TO S-Cfg-IBM 1207GC0310 WHEN CK-S-F6 1208 MOVE SPACES TO S-CfgS 1209 MOVE Selection-Char TO S-Cfg-MF 1210GC0310 WHEN CK-S-F7 1211 MOVE SPACES TO S-CfgS 1212 MOVE Selection-Char TO S-Cfg-MVS 1213 WHEN OTHER 1214 MOVE 'An unsupported key was pressed' 1215 TO Output-Message 1216 END-EVALUATE 1217 ELSE 1218 SET 88-No-Switch-Changes TO TRUE 1219 END-IF 1220 END-PERFORM 1221 . 1222 1223 209-Done. 1224 EXIT. 1225 / 1226 210-Run-Compiler SECTION. 1227 ***************************************************************** 1228 ** Run the compiler using the switch settings we've prepared. ** 1229 ***************************************************************** 1230 1231 211-Init. 1232 MOVE SPACES TO Cmd 1233 Cobc-Cmd 1234 Output-Message 1235 DISPLAY 1236 Switches-Screen 1237 END-DISPLAY 1238 MOVE 1 TO I 1239 EVALUATE TRUE 1240 WHEN S-Cfg-BS2000 NOT = SPACES 1241 MOVE 'bs2000' TO Config-File 1242 WHEN S-Cfg-COBOL85 NOT = SPACES 1243 MOVE 'cobol85' TO Config-File 1244 WHEN S-Cfg-COBOL2002 NOT = SPACES 1245 MOVE 'cobol2002' TO Config-File 1246 WHEN S-Cfg-IBM NOT = SPACES 1247 MOVE 'ibm' TO Config-File 1248 WHEN S-Cfg-MF NOT = SPACES 1249 MOVE 'mf' TO Config-File 1250 WHEN S-Cfg-MVS NOT = SPACES 1251 MOVE 'mvs' TO Config-File 1252 WHEN OTHER 1253 MOVE 'default' TO Config-File 1254 END-EVALUATE 1255 . 1256 1257 212-Build-Compile-Command. 1258GC0909 MOVE SPACES TO Cobc-Cmd 1259GC0909 STRING 'cobc -std=' 1260GC0909 TRIM(Config-File,TRAILING) 1261GC0909 ' ' 1262GC0909 INTO Cobc-Cmd 1263GC0909 WITH POINTER I 1264GC0909 END-STRING 1265 IF S-SUBROUTINE NOT = ' ' 1266 STRING '-m ' 1267 DELIMITED SIZE INTO Cobc-Cmd 1268 WITH POINTER I 1269 END-STRING 1270 ELSE 1271 STRING '-x ' 1272 DELIMITED SIZE INTO Cobc-Cmd 1273 WITH POINTER I 1274 END-STRING 1275 END-IF 1276 IF S-DEBUG NOT = ' ' 1277 STRING '-fdebugging-line ' 1278 DELIMITED SIZE INTO Cobc-Cmd 1279 WITH POINTER I 1280 END-STRING 1281 END-IF 1282 IF S-NOTRUNC NOT = ' ' 1283 STRING '-fnotrunc ' 1284 DELIMITED SIZE INTO Cobc-Cmd 1285 WITH POINTER I 1286 END-STRING 1287 END-IF 1288 IF S-TRACEALL NOT = ' ' 1289GC0809 STRING '-ftraceall ' 1290 DELIMITED SIZE INTO Cobc-Cmd 1291 WITH POINTER I 1292 END-STRING 1293 END-IF 1294 IF S-TRACE NOT = ' ' 1295 STRING '-ftrace ' 1296 DELIMITED SIZE INTO Cobc-Cmd 1297 WITH POINTER I 1298 END-STRING 1299 END-IF 1300 1301GC0709 IF S-EXTRA > SPACES 1302GC0709 STRING ' ' 1303GC0709 TRIM(S-Extra,TRAILING) 1304GC0709 ' ' 1305GC0709 DELIMITED SIZE INTO Cobc-Cmd 1306GC0709 WITH POINTER I 1307GC0709 END-STRING 1308GC0709 END-IF 1309GC0909 STRING TRIM(Prog-File-Name,TRAILING) 1310GC0909 DELIMITED SIZE INTO Cobc-Cmd 1311GC0909 WITH POINTER I 1312GC0909 END-STRING 1313 . 1314 1315 213-Run-Compiler. 1316GC0410 MOVE ' Compiling...' TO Output-Message 1317GC0410 DISPLAY 1318GC0410 Switches-Screen 1319GC0410 END-DISPLAY 1320GC0609 SET 88-Output-File-Avail TO TRUE 1321 MOVE SPACES TO Cmd 1322 STRING TRIM(Cobc-Cmd,TRAILING) 1323 ' 2>' 1324 TRIM(Cobc-Output-File,TRAILING) 1325 DELIMITED SIZE 1326 INTO Cmd 1327 END-STRING 1328 CALL 'SYSTEM' 1329 USING TRIM(Cmd,TRAILING) 1330 END-CALL 1331GC0909 IF RETURN-CODE = 0 1332GC0909 SET 88-Compile-OK TO TRUE 1333GC0909 ELSE 1334GC0909 SET 88-Compile-Failed TO TRUE 1335GC0909 END-IF 1336GC0909 IF 88-Compile-OK 1337GC0909 OPEN INPUT Cobc-Output 1338GC0909 READ Cobc-Output 1339GC0909 AT END 1340GC0909 CONTINUE 1341GC0909 NOT AT END 1342GC0909 SET 88-Compile-OK-Warn TO TRUE 1343GC0909 END-READ 1344GC0909 CLOSE Cobc-Output 1345GC0909 END-IF 1346GC0909 MOVE SPACES TO Output-Message 1347 IF 88-Compile-OK 1348GC0909 MOVE ' Compilation Was Successful' TO Output-Message 1349GC0909 DISPLAY 1350GC0909 Switches-Screen 1351GC0909 END-DISPLAY 1352GC0909 CALL 'C$SLEEP' 1353GC0909 USING 2 1354GC0909 END-CALL 1355GC0909 MOVE SPACES TO Output-Message 1356GC0609 SET 88-Complete TO TRUE 1357 ELSE 1358GC0909 DISPLAY 1359GC0909 Blank-Screen 1360GC0909 END-DISPLAY 1361GC0909 IF 88-Compile-OK-Warn 1362GC0909 DISPLAY ' Compilation was successful, but ' & 1363GC0909 'warnings were generated:' 1364SCROLL* AT LINE 24 COLUMN 1 1365SCROLL* WITH SCROLL UP 1 LINE 1366GC0909 END-DISPLAY 1367GC0909 ELSE 1368GC0909 DISPLAY 'Compilation Failed:' 1369SCROLL* AT LINE 24 COLUMN 1 1370SCROLL* WITH SCROLL UP 1 LINE 1371GC0909 END-DISPLAY 1372GC0909 END-IF 1373GC0609 SET 88-Compile-Failed TO TRUE 1374GC0609 SET 88-Complete TO TRUE 1375GC0909 DISPLAY ' ' 1376SCROLL* AT LINE 24 COLUMN 1 1377SCROLL* WITH SCROLL UP 1 LINE 1378GC0909 END-DISPLAY 1379GC0909 OPEN INPUT Cobc-Output 1380GC0909 PERFORM FOREVER 1381GC0909 READ Cobc-Output AT END 1382GC0909 EXIT PERFORM 1383GC0909 END-READ 1384GC0909 DISPLAY TRIM(Cobc-Output-Rec,TRAILING) 1385SCROLL* AT LINE 24 COLUMN 1 1386SCROLL* WITH SCROLL UP 1 LINE 1387GC0909 END-DISPLAY 1388GC0909 END-PERFORM 1389GC0909 CLOSE Cobc-Output 1390GC0909 DISPLAY ' ' 1391SCROLL* AT LINE 24 COLUMN 1 1392SCROLL* WITH SCROLL UP 2 LINES 1393GC0909 END-DISPLAY 1394GC0909 DISPLAY 'Press ENTER to close:' 1395SCROLL* AT LINE 24 COLUMN 1 1396SCROLL* WITH SCROLL UP 1 LINE 1397GC0909 END-DISPLAY 1398GC0909 ACCEPT Dummy 1399GC0909 FROM CONSOLE 1400GC0909 END-ACCEPT 1401GC0909 DISPLAY 1402GC0909 Blank-Screen 1403GC0909 END-DISPLAY 1404 END-IF 1405 . 1406 1407 219-Done. 1408 IF 88-Compile-Failed 1409 PERFORM 900-Terminate 1410 END-IF 1411 . 1412 / 1413GC0410 220-Make-Listing SECTION. 1414GC0410***************************************************************** 1415GC0410** Generate a source and/or xref listing using XREF ** 1416GC0410***************************************************************** 1417GC0410 1418GC0410 221-Init. 1419GC0410 MOVE ' Generating cross-reference listing...' 1420GC0410 TO Output-Message 1421GC0410 DISPLAY 1422GC0410 Switches-Screen 1423GC0410 END-DISPLAY 1424GC0410 CALL "CBL_DELETE_FILE" 1425GC0410 USING CONCATENATE(TRIM(Prog-Name,Trailing),".lst") 1426GC0410 END-CALL 1427GC0410 MOVE 0 TO RETURN-CODE 1428GC0410 . 1429GC0410 1430GC0410 213-Run-OCXref. 1431GC0410 MOVE SPACES TO Output-Message 1432GC0410 CALL 'LISTING' 1433GC0410 USING S-SOURCE 1434GC0410 S-XREF 1435GC0410 File-Name 1436GC0410 ON EXCEPTION 1437GC0410 MOVE ' LISTING module is not available' 1438GC0410 TO Output-Message 1439GC0410 MOVE 1 TO RETURN-CODE 1440GC0410 END-CALL 1441GC0410 IF RETURN-CODE = 0 1442GC0410 MOVE ' Listing generated' 1443GC0410 TO Output-Message 1444GC0410 IF OS-Windows OR OS-Cygwin 1445GC0410 MOVE SPACES TO Cmd 1446GC0410 STRING 1447GC0410 'cmd /c ' 1448GC0410 TRIM(Prog-Name,TRAILING) 1449GC0410 '.lst' 1450GC0410 DELIMITED SIZE INTO Cmd 1451GC0410 END-STRING 1452GC0410 CALL 'SYSTEM' 1453GC0410 USING TRIM(Cmd,TRAILING) 1454GC0410 END-CALL 1455GC0410 END-IF 1456GC0410 ELSE 1457GC0410 IF Output-Message = SPACES 1458GC0410 MOVE ' Listing generation failed' 1459GC0410 TO Output-Message 1460GC0410 END-IF 1461GC0410 END-IF 1462GC0410 DISPLAY 1463GC0410 Switches-Screen 1464GC0410 END-DISPLAY 1465GC0410 CALL 'C$SLEEP' 1466GC0410 USING 2 1467GC0410 END-CALL 1468GC0410 . 1469 / 1470 230-Run-Program SECTION. 1471 ***************************************************************** 1472 ** Run the compiled program ** 1473 ***************************************************************** 1474 1475 232-Build-Command. 1476GC0909 MOVE SPACES TO Cmd 1477GC0909 MOVE 1 TO I 1478 IF S-SUBROUTINE NOT = ' ' 1479 OR S-DLL NOT = ' ' 1480 STRING 'cobcrun ' DELIMITED SIZE 1481 INTO Cmd 1482 WITH POINTER I 1483 END-STRING 1484 END-IF 1485 IF Prog-Folder NOT = SPACES 1486GC0909 IF OS-Cygwin AND Prog-Folder (2:1) = ':' 1487GC0909 STRING '/cygdrive/' 1488GC0909 INTO Cmd 1489GC0909 WITH POINTER I 1490GC0909 END-STRING 1491GC0909 STRING LOWER-CASE(Prog-Folder (1:1)) 1492GC0909 INTO Cmd 1493GC0909 WITH POINTER I 1494GC0909 END-STRING 1495GC0909 PERFORM VARYING J FROM 3 BY 1 1496GC0909 UNTIL J > LENGTH(TRIM(Prog-Folder)) 1497GC0909 IF Prog-Folder (J:1) = '\' 1498GC0909 STRING '/' 1499GC0909 INTO Cmd 1500GC0909 WITH POINTER I 1501GC0909 END-STRING 1502GC0909 ELSE 1503GC0909 STRING Prog-Folder (J:1) 1504GC0909 INTO Cmd 1505GC0909 WITH POINTER I 1506GC0909 END-STRING 1507GC0909 END-IF 1508GC0909 END-PERFORM 1509GC0909 ELSE 1510GC0410 STRING '"' TRIM(Prog-Folder,TRAILING) 1511GC0909 INTO Cmd 1512GC0909 WITH POINTER I 1513GC0909 END-STRING 1514GC0909 END-IF 1515GC0909 STRING Dir-Char 1516GC0909 INTO Cmd 1517GC0909 WITH POINTER I 1518GC0909 END-STRING 1519GC0909 ELSE 1520GC0909 IF OS-Cygwin OR OS-UNIX 1521GC0909 STRING './' 1522GC0909 INTO Cmd 1523GC0909 WITH POINTER I 1524GC0909 END-STRING 1525GC0909 END-IF 1526 END-IF 1527GC0909 STRING TRIM(Prog-Name,TRAILING) 1528GC0909 INTO Cmd 1529GC0909 WITH POINTER I 1530GC0909 END-STRING 1531GC0909 IF S-SUBROUTINE = ' ' 1532GC0909 AND S-DLL NOT = ' ' 1533GC0909 STRING '.exe' DELIMITED SIZE 1534 INTO Cmd 1535 WITH POINTER I 1536 END-STRING 1537 END-IF 1538 IF S-ARGS NOT = SPACES 1539GC0809 STRING ' ' TRIM(S-ARGS,TRAILING) 1540 INTO Cmd 1541 WITH POINTER I 1542 END-STRING 1543 END-IF 1544 IF OS-Unknown OR OS-Windows 1545GC0410 STRING '"&&pause' 1546 INTO Cmd 1547 WITH POINTER I 1548 END-STRING 1549 ELSE 1550 STRING ';echo "Press ENTER to close...";read' 1551 INTO Cmd 1552 WITH POINTER I 1553 END-STRING 1554 END-IF 1555 . 1556 1557 233-Run-Program. 1558GC0909 DISPLAY 1559GC0909 Blank-Screen 1560GC0909 END-DISPLAY 1561 1562 CALL 'SYSTEM' 1563 USING TRIM(Cmd,TRAILING) 1564 END-CALL 1565 PERFORM 900-Terminate 1566 . 1567 1568 239-Done. 1569 EXIT. 1570 / 1571 900-Terminate SECTION. 1572 ***************************************************************** 1573 ** Display a message and halt the program ** 1574 ***************************************************************** 1575 1576 901-Display-Message. 1577GC0909 IF Output-Message > SPACES 1578GC0909 DISPLAY 1579GC0909 Switches-Screen 1580GC0909 END-DISPLAY 1581GC0909 CALL 'C$SLEEP' 1582GC0909 USING 2 1583GC0909 END-CALL 1584GC0909 END-IF 1585 DISPLAY 1586 Blank-Screen 1587 END-DISPLAY 1588 . 1589 1590 909-Done. 1591 GOBACK 1592 . 1593 1594 END PROGRAM OCic. 1595 1596 IDENTIFICATION DIVISION. 1597 PROGRAM-ID. GETOSTYPE. 1598 ***************************************************************** 1599 ** This subprogram determine the OS type the program is run- ** 1600 ** ning under, passing that result back in RETURN-CODE as fol- ** 1601 ** lows: ** 1602 ** ** 1603 ** 0: Cannot be determined ** 1604 ** 1: Native Windows or Windows/MinGW ** 1605 ** 2: Cygwin ** 1606 ** 3: UNIX/Linux/MacOS ** 1607 ***************************************************************** 1608 ** DATE CHANGE DESCRIPTION ** 1609 ** ====== ==================================================== ** 1610 ** GC0909 Initial coding. ** 1611 ***************************************************************** 1612 ENVIRONMENT DIVISION. 1613 CONFIGURATION SECTION. 1614 REPOSITORY. 1615 FUNCTION ALL INTRINSIC. 1616 DATA DIVISION. 1617 WORKING-STORAGE SECTION. 1618 01 Env-Path PIC X(1024). 1619 01 Tally USAGE BINARY-LONG. 1620 PROCEDURE DIVISION. 1621 000-Main SECTION. 1622 010-Get-TEMP-Var. 1623 MOVE SPACES TO Env-Path 1624 ACCEPT Env-Path 1625 FROM ENVIRONMENT "PATH" 1626 ON EXCEPTION 1627 MOVE 0 TO RETURN-CODE 1628 GOBACK 1629 END-ACCEPT 1630 IF Env-Path = SPACES 1631 MOVE 0 TO RETURN-CODE 1632 ELSE 1633 MOVE 0 TO Tally 1634 INSPECT Env-Path 1635 TALLYING Tally FOR ALL ";" 1636 IF Tally = 0 *> Must be some form of UNIX 1637 MOVE 0 TO Tally 1638 INSPECT Env-Path 1639 TALLYING TALLY FOR ALL "/cygdrive/" 1640 IF Tally = 0 *> UNIX/MacOS 1641 MOVE 3 TO RETURN-CODE 1642 ELSE *> Cygwin 1643 MOVE 2 TO RETURN-CODE 1644 END-IF 1645 ELSE *> Assume Windows[/MinGW] 1646 MOVE 1 TO RETURN-CODE 1647 END-IF 1648 END-IF 1649 GOBACK 1650 . 1651 END PROGRAM GETOSTYPE. 1652 1653 IDENTIFICATION DIVISION. 1654 PROGRAM-ID. CHECKSOURCE. 1655 ***************************************************************** 1656 ** This subprogram will scan a line of source code it is given ** 1657 ** looking for "LINKAGE SECTION" or "IDENTIFICATION DIVISION". ** 1658 ** ** 1659 ** ****NOTE**** ****NOTE**** ****NOTE**** ****NOTE*** ** 1660 ** ** 1661 ** These two strings must be found IN THEIR ENTIRETY within ** 1662 ** the 1st 80 columns of program source records, and cannot ** 1663 ** follow either a "*>" sequence OR a "*" in col 7. ** 1664 ***************************************************************** 1665 ** DATE CHANGE DESCRIPTION ** 1666 ** ====== ==================================================== ** 1667 ** GC0809 Initial coding. ** 1668 ***************************************************************** 1669 ENVIRONMENT DIVISION. 1670 CONFIGURATION SECTION. 1671 REPOSITORY. 1672 FUNCTION ALL INTRINSIC. 1673 DATA DIVISION. 1674 WORKING-STORAGE SECTION. 1675 01 Compressed-Src. 1676 05 CS-Char OCCURS 80 TIMES PIC X(1). 1677 1678 01 Flags. 1679 05 F-Found-SPACE PIC X(1). 1680 88 88-Skipping-SPACE VALUE 'Y'. 1681 88 88-Not-Skipping-SPACE VALUE 'N'. 1682 1683 01 I USAGE BINARY-CHAR. 1684 1685 01 J USAGE BINARY-CHAR. 1686 LINKAGE SECTION. 1687 01 Argument-1. 1688 02 A1-Char OCCURS 80 TIMES PIC X(1). 1689 1690 01 Argument-2 PIC X(1). 1691 88 88-A2-LINKAGE-SECTION VALUE 'L'. 1692 88 88-A2-IDENTIFICATION-DIVISION VALUE 'I'. 1693 88 88-A2-Nothing-Special VALUE ' '. 1694 PROCEDURE DIVISION USING Argument-1, Argument-2. 1695 000-Main SECTION. 1696 1697 010-Initialize. 1698 SET 88-A2-Nothing-Special TO TRUE 1699 IF A1-Char (7) = '*' 1700 GOBACK 1701 END-IF 1702 . 1703 1704 020-Compress-Multiple-SPACES. 1705 SET 88-Not-Skipping-SPACE TO TRUE 1706 MOVE 0 TO J 1707 MOVE SPACES TO Compressed-Src 1708 PERFORM VARYING I FROM 1 BY 1 1709 UNTIL I > 80 1710 IF A1-Char (I) = SPACE 1711 IF 88-Not-Skipping-SPACE 1712 ADD 1 TO J 1713 MOVE UPPER-CASE(A1-Char (I)) TO CS-Char (J) 1714 SET 88-Skipping-SPACE TO TRUE 1715 END-IF 1716 ELSE 1717 SET 88-Not-Skipping-SPACE TO TRUE 1718 ADD 1 TO J 1719 MOVE A1-Char (I) TO CS-Char (J) 1720 END-IF 1721 END-PERFORM 1722 . 1723 1724 030-Scan-Compressed-Src. 1725 PERFORM VARYING I FROM 1 BY 1 1726 UNTIL I > 66 1727 EVALUATE TRUE 1728 WHEN CS-Char (I) = '*' 1729 IF Compressed-Src (I : 2) = '*>' 1730 GOBACK 1731 END-IF 1732 WHEN (CS-Char (I) = 'L') AND (I < 66) 1733 IF Compressed-Src (I : 15) = 'LINKAGE SECTION' 1734 SET 88-A2-LINKAGE-SECTION TO TRUE 1735 GOBACK 1736 END-IF 1737 WHEN (CS-Char (I) = 'I') AND (I < 58) 1738 IF Compressed-Src (I : 23) = 'IDENTIFICATION ' & 1739 'DIVISION' 1740 SET 88-A2-IDENTIFICATION-DIVISION TO TRUE 1741 GOBACK 1742 END-IF 1743 END-EVALUATE 1744 END-PERFORM 1745 . 1746 1747 099-Never-Found-Either-One. 1748 GOBACK 1749 . 1750 END PROGRAM CHECKSOURCE. 1751 1752 IDENTIFICATION DIVISION. 1753 PROGRAM-ID. LISTING. 1754 ***************************************************************** 1755 ** This subprogram generates a cross-reference listing of an ** 1756 ** OpenCOBOL program. ** 1757 ** ** 1758 ** Linkage: CALL "LISTING" USING <source> ** 1759 ** <xref> ** 1760 ** <filename> ** 1761 ** ** 1762 ** Where: ** 1763 ** <source> is a PIC X(1) flag indicating ** 1764 ** whether or not a source listing ** 1765 ** should be produced (space=NO, ** 1766 ** non-space=yes) ** 1767 ** <xref> is a PIC X(1) flag indicating ** 1768 ** whether or not an xref listing ** 1769 ** should be produced (space=NO, ** 1770 ** non-space=yes) ** 1771 ** <filename> is the [path]filename of the ** 1772 ** program being listed and/or ** 1773 ** xreffed in a PIC X(256) form. ** 1774 ***************************************************************** 1775 ** ** 1776 ** AUTHOR: GARY L. CUTLER ** 1777 ** CutlerGL@gmail.com ** 1778 ** Copyright (C) 2010, Gary L. Cutler, GPL ** 1779 ** ** 1780 ** DATE-WRITTEN: April 1, 2010 ** 1781 ** ** 1782 ***************************************************************** 1783 ** DATE CHANGE DESCRIPTION ** 1784 ** ====== ==================================================== ** 1785 ** GC0410 Initial coding ** 1786 ** GC0710 Handle duplicate data names (i.e. "CORRESPONDING" or ** 1787 ** qualified items) better; ignore "END PROGRAM" recs ** 1788 ** so program name doesn't appear in listing. ** 1789 ***************************************************************** 1790 ENVIRONMENT DIVISION. 1791 CONFIGURATION SECTION. 1792 REPOSITORY. 1793 FUNCTION ALL INTRINSIC. 1794 INPUT-OUTPUT SECTION. 1795 FILE-CONTROL. 1796 SELECT Expand-Code ASSIGN TO Expanded-Src-Filename 1797 ORGANIZATION IS LINE SEQUENTIAL. 1798 SELECT Report-File ASSIGN TO Report-Filename 1799 ORGANIZATION IS LINE SEQUENTIAL. 1800 SELECT Sort-File ASSIGN TO DISK. 1801 SELECT Source-Code ASSIGN TO Src-Filename 1802 ORGANIZATION IS LINE SEQUENTIAL. 1803 DATA DIVISION. 1804 FILE SECTION. 1805 FD Expand-Code. 1806 01 Expand-Code-Rec. 1807 05 ECR-1 PIC X. 1808 05 ECR-2-256 PIC X(256). 1809 01 Expand-Code-Rec-Alt. 1810 05 ECR-1-128 PIC X(128). 1811 05 ECR-129-256 PIC X(128). 1812 1813 FD Report-File. 1814 01 Report-Rec PIC X(135). 1815 1816 SD Sort-File. 1817 01 Sort-Rec. 1818 05 SR-Prog-ID PIC X(15). 1819 05 SR-Token-UC PIC X(32). 1820 05 SR-Token PIC X(32). 1821 05 SR-Section PIC X(15). 1822 05 SR-Line-No-Def PIC 9(6). 1823 05 SR-Reference. 1824 10 SR-Line-No-Ref PIC 9(6). 1825 10 SR-Ref-Flag PIC X(1). 1826 1827 FD Source-Code. 1828 01 Source-Code-Rec. 1829GC0410 05 SCR-1-128. 1830GC0410 10 FILLER PIC X(6). 1831GC0410 10 SCR-7 PIC X(1). 1832GC0410 10 FILLER PIC X(121). 1833 05 SCR-129-256 PIC X(128). 1834 1835 WORKING-STORAGE SECTION. 1836 78 Line-Nos-Per-Rec VALUE 8. 1837 1838 01 Cmd PIC X(256). 1839 1840 01 Delim PIC X(2). 1841 1842 01 Detail-Line-S. 1843 05 DLS-Line-No PIC ZZZZZ9. 1844 05 FILLER PIC X(1). 1845 05 DLS-Statement PIC X(128). 1846 1847 01 Detail-Line-X. 1848 05 DLX-Prog-ID PIC X(15). 1849 05 FILLER PIC X(1). 1850 05 DLX-Token PIC X(32). 1851 05 FILLER PIC X(1). 1852 05 DLX-Line-No-Def PIC ZZZZZ9. 1853 05 FILLER PIC X(1). 1854 05 DLX-Section PIC X(15). 1855 05 FILLER PIC X(1). 1856 05 DLX-Reference OCCURS Line-Nos-Per-Rec TIMES. 1857 10 DLX-Line-No-Ref PIC ZZZZZ9. 1858 10 DLX-Ref-Flag PIC X(1). 1859 10 FILLER PIC X(1). 1860 1861 01 Dummy PIC X(1). 1862 1863 01 Env-TEMP PIC X(256). 1864 1865 01 Expanded-Src-Filename PIC X(256). 1866 1867 01 Filename PIC X(256). 1868 1869 01 Flags. 1870GC0710 05 F-Duplicate PIC X(1). 1871 05 F-First-Record PIC X(1). 1872 05 F-In-Which-Pgm PIC X(1). 1873 88 In-Main-Module VALUE 'M'. 1874 88 In-Copybook VALUE 'C'. 1875 05 F-Last-Token-Ended-Sent PIC X(1). 1876 05 F-Processing-PICTURE PIC X(1). 1877 05 F-Token-Ended-Sentence PIC X(1). 1878GC0710 05 F-Verb-Has-Been-Found PIC X(1). 1879 1880 01 Group-Indicators. 1881 05 GI-Prog-ID PIC X(15). 1882 05 GI-Token PIC X(32). 1883 1884 01 Heading-1S. 1885 05 FILLER PIC X(125) VALUE 1886 "OpenCOBOL 1.1 06FEB2009 Source Listing - " & 1887 "OCic Copyright (C) 2009-2010, Gary L. Cutler, GPL". 1888 05 H1S-Date PIC 9999/99/99. 1889 1890 01 Heading-1X. 1891 05 FILLER PIC X(125) VALUE 1892 "OpenCOBOL 1.1 06FEB2009 Cross-Reference Listing - " & 1893 "OCic Copyright (C) 2009-2010, Gary L. Cutler, GPL". 1894 05 H1X-Date PIC 9999/99/99. 1895 1896 01 Heading-2 PIC X(135). 1897 1898 01 Heading-4S PIC X(16) VALUE 1899 "Line Statement". 1900 1901 01 Heading-4X PIC X(96) VALUE 1902 "PROGRAM-ID Identifier/Register/Function Defn Wher 1903 - "e Defined References (* = Updated)". 1904 1905 01 Heading-5S PIC X(135) VALUE 1906 "====== ===================================================== 1907 - "============================================================ 1908 - "===============". 1909 1910 01 Heading-5X PIC X(135) VALUE 1911 "=============== ================================ ====== ==== 1912 - "=========== ================================================ 1913 - "===============". 1914 1915 01 Held-Reference PIC X(100). 1916 1917 01 I USAGE BINARY-LONG. 1918 1919 01 J USAGE BINARY-LONG. 1920 1921 01 Lines-Left USAGE BINARY-LONG. 1922 1923 01 Lines-Per-Page USAGE BINARY-LONG. 1924 1925 01 Lines-Per-Page-ENV PIC X(256). 1926 1927 01 Num-UserNames USAGE BINARY-LONG. 1928 1929 01 PIC-X10 PIC X(10). 1930 1931 01 PIC-X32 PIC X(32). 1932 1933 01 PIC-X256 PIC X(256). 1934 1935 01 Program-Path PIC X(256). 1936 1937 01 Report-Filename PIC X(256). 1938 1939 01 Reserved-Words. 1940 05 FILLER PIC X(33) VALUE "IABS". 1941 05 FILLER PIC X(33) VALUE "VACCEPT". 1942 05 FILLER PIC X(33) VALUE " ACCESS". 1943 05 FILLER PIC X(33) VALUE "IACOS". 1944 05 FILLER PIC X(33) VALUE " ACTIVE-CLASS". 1945 05 FILLER PIC X(33) VALUE "VADD". 1946 05 FILLER PIC X(33) VALUE " ADDRESS". 1947 05 FILLER PIC X(33) VALUE " ADVANCING". 1948 05 FILLER PIC X(33) VALUE "KAFTER". 1949 05 FILLER PIC X(33) VALUE " ALIGNED". 1950 05 FILLER PIC X(33) VALUE " ALL". 1951 05 FILLER PIC X(33) VALUE "VALLOCATE". 1952 05 FILLER PIC X(33) VALUE " ALPHABET". 1953 05 FILLER PIC X(33) VALUE " ALPHABETIC". 1954 05 FILLER PIC X(33) VALUE " ALPHABETIC-LOWER". 1955 05 FILLER PIC X(33) VALUE " ALPHABETIC-UPPER". 1956 05 FILLER PIC X(33) VALUE " ALPHANUMERIC". 1957 05 FILLER PIC X(33) VALUE " ALPHANUMERIC-EDITED". 1958 05 FILLER PIC X(33) VALUE " ALSO". 1959 05 FILLER PIC X(33) VALUE "VALTER". 1960 05 FILLER PIC X(33) VALUE " ALTERNATE". 1961 05 FILLER PIC X(33) VALUE " AND". 1962 05 FILLER PIC X(33) VALUE "IANNUITY". 1963 05 FILLER PIC X(33) VALUE " ANY". 1964 05 FILLER PIC X(33) VALUE " ANYCASE". 1965 05 FILLER PIC X(33) VALUE " ARE". 1966 05 FILLER PIC X(33) VALUE " AREA". 1967 05 FILLER PIC X(33) VALUE " AREAS". 1968 05 FILLER PIC X(33) VALUE " ARGUMENT-NUMBER". 1969 05 FILLER PIC X(33) VALUE " ARGUMENT-VALUE". 1970 05 FILLER PIC X(33) VALUE " AS". 1971 05 FILLER PIC X(33) VALUE " ASCENDING". 1972 05 FILLER PIC X(33) VALUE "IASIN". 1973 05 FILLER PIC X(33) VALUE " ASSIGN". 1974 05 FILLER PIC X(33) VALUE " AT". 1975 05 FILLER PIC X(33) VALUE "IATAN". 1976 05 FILLER PIC X(33) VALUE " AUTHOR". 1977 05 FILLER PIC X(33) VALUE " AUTO". 1978 05 FILLER PIC X(33) VALUE " AUTO-SKIP". 1979 05 FILLER PIC X(33) VALUE " AUTOMATIC". 1980 05 FILLER PIC X(33) VALUE " AUTOTERMINATE". 1981 05 FILLER PIC X(33) VALUE " BACKGROUND-COLOR". 1982 05 FILLER PIC X(33) VALUE " BASED". 1983 05 FILLER PIC X(33) VALUE " BEEP". 1984 05 FILLER PIC X(33) VALUE " BEFORE". 1985 05 FILLER PIC X(33) VALUE " BELL". 1986 05 FILLER PIC X(33) VALUE " BINARY". 1987 05 FILLER PIC X(33) VALUE " BINARY-C-LONG". 1988 05 FILLER PIC X(33) VALUE " BINARY-CHAR". 1989 05 FILLER PIC X(33) VALUE " BINARY-DOUBLE". 1990 05 FILLER PIC X(33) VALUE " BINARY-LONG". 1991 05 FILLER PIC X(33) VALUE " BINARY-SHORT". 1992 05 FILLER PIC X(33) VALUE " BIT". 1993 05 FILLER PIC X(33) VALUE " BLANK". 1994 05 FILLER PIC X(33) VALUE " BLINK". 1995 05 FILLER PIC X(33) VALUE " BLOCK". 1996 05 FILLER PIC X(33) VALUE " BOOLEAN". 1997 05 FILLER PIC X(33) VALUE " BOTTOM". 1998 05 FILLER PIC X(33) VALUE "YBY". 1999 05 FILLER PIC X(33) VALUE "IBYTE-LENGTH". 2000 05 FILLER PIC X(33) VALUE "MC01". 2001 05 FILLER PIC X(33) VALUE "MC02". 2002 05 FILLER PIC X(33) VALUE "MC03". 2003 05 FILLER PIC X(33) VALUE "MC04". 2004 05 FILLER PIC X(33) VALUE "MC05". 2005 05 FILLER PIC X(33) VALUE "MC06". 2006 05 FILLER PIC X(33) VALUE "MC07". 2007 05 FILLER PIC X(33) VALUE "MC08". 2008 05 FILLER PIC X(33) VALUE "MC09". 2009 05 FILLER PIC X(33) VALUE "MC10". 2010 05 FILLER PIC X(33) VALUE "MC11". 2011 05 FILLER PIC X(33) VALUE "MC12". 2012 05 FILLER PIC X(33) VALUE "VCALL". 2013 05 FILLER PIC X(33) VALUE "VCANCEL". 2014 05 FILLER PIC X(33) VALUE " CF". 2015 05 FILLER PIC X(33) VALUE " CH". 2016 05 FILLER PIC X(33) VALUE " CHAINING". 2017 05 FILLER PIC X(33) VALUE "ICHAR". 2018 05 FILLER PIC X(33) VALUE " CHARACTER". 2019 05 FILLER PIC X(33) VALUE " CHARACTERS". 2020 05 FILLER PIC X(33) VALUE " CLASS". 2021 05 FILLER PIC X(33) VALUE " CLASS-ID". 2022 05 FILLER PIC X(33) VALUE "VCLOSE". 2023 05 FILLER PIC X(33) VALUE "ICOB-CRT-STATUS". 2024 05 FILLER PIC X(33) VALUE " CODE". 2025 05 FILLER PIC X(33) VALUE " CODE-SET". 2026 05 FILLER PIC X(33) VALUE " COL". 2027 05 FILLER PIC X(33) VALUE " COLLATING". 2028 05 FILLER PIC X(33) VALUE " COLS". 2029 05 FILLER PIC X(33) VALUE " COLUMN". 2030 05 FILLER PIC X(33) VALUE " COLUMNS". 2031 05 FILLER PIC X(33) VALUE "ICOMBINED-DATETIME". 2032 05 FILLER PIC X(33) VALUE " COMMA". 2033 05 FILLER PIC X(33) VALUE " COMMAND-LINE". 2034 05 FILLER PIC X(33) VALUE "VCOMMIT". 2035 05 FILLER PIC X(33) VALUE " COMMON". 2036 05 FILLER PIC X(33) VALUE " COMP". 2037 05 FILLER PIC X(33) VALUE " COMP-1". 2038 05 FILLER PIC X(33) VALUE " COMP-2". 2039 05 FILLER PIC X(33) VALUE " COMP-3". 2040 05 FILLER PIC X(33) VALUE " COMP-4". 2041 05 FILLER PIC X(33) VALUE " COMP-5". 2042 05 FILLER PIC X(33) VALUE " COMP-X". 2043 05 FILLER PIC X(33) VALUE " COMPUTATIONAL". 2044 05 FILLER PIC X(33) VALUE " COMPUTATIONAL-1". 2045 05 FILLER PIC X(33) VALUE " COMPUTATIONAL-2". 2046 05 FILLER PIC X(33) VALUE " COMPUTATIONAL-3". 2047 05 FILLER PIC X(33) VALUE " COMPUTATIONAL-4". 2048 05 FILLER PIC X(33) VALUE " COMPUTATIONAL-5". 2049 05 FILLER PIC X(33) VALUE " COMPUTATIONAL-X". 2050 05 FILLER PIC X(33) VALUE "VCOMPUTE". 2051 05 FILLER PIC X(33) VALUE "ICONCATENATE". 2052 05 FILLER PIC X(33) VALUE " CONDITION". 2053 05 FILLER PIC X(33) VALUE "KCONFIGURATION". 2054 05 FILLER PIC X(33) VALUE "MCONSOLE". 2055 05 FILLER PIC X(33) VALUE " CONSTANT". 2056 05 FILLER PIC X(33) VALUE " CONTAINS". 2057 05 FILLER PIC X(33) VALUE " CONTENT". 2058 05 FILLER PIC X(33) VALUE "VCONTINUE". 2059 05 FILLER PIC X(33) VALUE " CONTROL". 2060 05 FILLER PIC X(33) VALUE " CONTROLS". 2061 05 FILLER PIC X(33) VALUE "KCONVERTING". 2062 05 FILLER PIC X(33) VALUE " COPY". 2063 05 FILLER PIC X(33) VALUE " CORR". 2064 05 FILLER PIC X(33) VALUE " CORRESPONDING". 2065 05 FILLER PIC X(33) VALUE "ICOS". 2066 05 FILLER PIC X(33) VALUE "KCOUNT". 2067 05 FILLER PIC X(33) VALUE " CRT". 2068 05 FILLER PIC X(33) VALUE " CURRENCY". 2069 05 FILLER PIC X(33) VALUE "ICURRENT-DATE". 2070 05 FILLER PIC X(33) VALUE " CURSOR". 2071 05 FILLER PIC X(33) VALUE " CYCLE". 2072 05 FILLER PIC X(33) VALUE "KDATA". 2073 05 FILLER PIC X(33) VALUE " DATA-POINTER". 2074 05 FILLER PIC X(33) VALUE " DATE". 2075 05 FILLER PIC X(33) VALUE " DATE-COMPILED". 2076 05 FILLER PIC X(33) VALUE " DATE-MODIFIED". 2077 05 FILLER PIC X(33) VALUE "IDATE-OF-INTEGER". 2078 05 FILLER PIC X(33) VALUE "IDATE-TO-YYYYMMDD". 2079 05 FILLER PIC X(33) VALUE " DATE-WRITTEN". 2080 05 FILLER PIC X(33) VALUE " DAY". 2081 05 FILLER PIC X(33) VALUE "IDAY-OF-INTEGER". 2082 05 FILLER PIC X(33) VALUE " DAY-OF-WEEK". 2083 05 FILLER PIC X(33) VALUE "IDAY-TO-YYYYDDD". 2084 05 FILLER PIC X(33) VALUE " DE". 2085 05 FILLER PIC X(33) VALUE " DEBUGGING". 2086 05 FILLER PIC X(33) VALUE " DECIMAL-POINT". 2087 05 FILLER PIC X(33) VALUE " DECLARATIVES". 2088 05 FILLER PIC X(33) VALUE " DEFAULT". 2089 05 FILLER PIC X(33) VALUE "VDELETE". 2090 05 FILLER PIC X(33) VALUE " DELIMITED". 2091 05 FILLER PIC X(33) VALUE "KDELIMITER". 2092 05 FILLER PIC X(33) VALUE " DEPENDING". 2093 05 FILLER PIC X(33) VALUE " DESCENDING". 2094 05 FILLER PIC X(33) VALUE " DESTINATION". 2095 05 FILLER PIC X(33) VALUE " DETAIL". 2096 05 FILLER PIC X(33) VALUE " DISABLE". 2097 05 FILLER PIC X(33) VALUE " DISK". 2098 05 FILLER PIC X(33) VALUE "VDISPLAY". 2099 05 FILLER PIC X(33) VALUE "VDIVIDE". 2100 05 FILLER PIC X(33) VALUE "KDIVISION". 2101 05 FILLER PIC X(33) VALUE "KDOWN". 2102 05 FILLER PIC X(33) VALUE " DUPLICATES". 2103 05 FILLER PIC X(33) VALUE " DYNAMIC". 2104 05 FILLER PIC X(33) VALUE "IE". 2105 05 FILLER PIC X(33) VALUE " EBCDIC". 2106 05 FILLER PIC X(33) VALUE " EC". 2107 05 FILLER PIC X(33) VALUE "VELSE". 2108GC0710 05 FILLER PIC X(33) VALUE "KEND". 2109 05 FILLER PIC X(33) VALUE " END-ACCEPT". 2110 05 FILLER PIC X(33) VALUE " END-ADD". 2111 05 FILLER PIC X(33) VALUE " END-CALL". 2112 05 FILLER PIC X(33) VALUE " END-COMPUTE". 2113 05 FILLER PIC X(33) VALUE " END-DELETE". 2114 05 FILLER PIC X(33) VALUE " END-DISPLAY". 2115 05 FILLER PIC X(33) VALUE " END-DIVIDE". 2116 05 FILLER PIC X(33) VALUE " END-EVALUATE". 2117 05 FILLER PIC X(33) VALUE " END-IF". 2118 05 FILLER PIC X(33) VALUE " END-MULTIPLY". 2119 05 FILLER PIC X(33) VALUE " END-OF-PAGE". 2120 05 FILLER PIC X(33) VALUE " END-PERFORM". 2121 05 FILLER PIC X(33) VALUE " END-READ". 2122 05 FILLER PIC X(33) VALUE " END-RETURN". 2123 05 FILLER PIC X(33) VALUE " END-REWRITE". 2124 05 FILLER PIC X(33) VALUE " END-SEARCH". 2125 05 FILLER PIC X(33) VALUE " END-START". 2126 05 FILLER PIC X(33) VALUE " END-STRING". 2127 05 FILLER PIC X(33) VALUE " END-SUBTRACT". 2128 05 FILLER PIC X(33) VALUE " END-UNSTRING". 2129 05 FILLER PIC X(33) VALUE " END-WRITE". 2130 05 FILLER PIC X(33) VALUE "VENTRY". 2131 05 FILLER PIC X(33) VALUE "KENVIRONMENT". 2132 05 FILLER PIC X(33) VALUE " ENVIRONMENT-NAME". 2133 05 FILLER PIC X(33) VALUE " ENVIRONMENT-VALUE". 2134 05 FILLER PIC X(33) VALUE " EO". 2135 05 FILLER PIC X(33) VALUE " EOL". 2136 05 FILLER PIC X(33) VALUE " EOP". 2137 05 FILLER PIC X(33) VALUE " EOS". 2138 05 FILLER PIC X(33) VALUE " EQUAL". 2139 05 FILLER PIC X(33) VALUE "KEQUALS". 2140 05 FILLER PIC X(33) VALUE " ERASE". 2141 05 FILLER PIC X(33) VALUE " ERROR". 2142 05 FILLER PIC X(33) VALUE " ESCAPE". 2143 05 FILLER PIC X(33) VALUE "VEVALUATE". 2144 05 FILLER PIC X(33) VALUE " EXCEPTION". 2145 05 FILLER PIC X(33) VALUE "IEXCEPTION-FILE". 2146 05 FILLER PIC X(33) VALUE "IEXCEPTION-LOCATION". 2147 05 FILLER PIC X(33) VALUE " EXCEPTION-OBJECT". 2148 05 FILLER PIC X(33) VALUE "IEXCEPTION-STATEMENT". 2149 05 FILLER PIC X(33) VALUE "IEXCEPTION-STATUS". 2150 05 FILLER PIC X(33) VALUE " EXCLUSIVE". 2151 05 FILLER PIC X(33) VALUE "VEXIT". 2152 05 FILLER PIC X(33) VALUE "IEXP". 2153 05 FILLER PIC X(33) VALUE "IEXP10". 2154 05 FILLER PIC X(33) VALUE " EXTEND". 2155 05 FILLER PIC X(33) VALUE " EXTERNAL". 2156 05 FILLER PIC X(33) VALUE "IFACTORIAL". 2157 05 FILLER PIC X(33) VALUE " FACTORY". 2158 05 FILLER PIC X(33) VALUE " FALSE". 2159 05 FILLER PIC X(33) VALUE "KFD". 2160 05 FILLER PIC X(33) VALUE "KFILE". 2161 05 FILLER PIC X(33) VALUE " FILE-CONTROL". 2162 05 FILLER PIC X(33) VALUE " FILE-ID". 2163 05 FILLER PIC X(33) VALUE " FILLER". 2164 05 FILLER PIC X(33) VALUE " FINAL". 2165 05 FILLER PIC X(33) VALUE " FIRST". 2166 05 FILLER PIC X(33) VALUE " FLOAT-BINARY-16". 2167 05 FILLER PIC X(33) VALUE " FLOAT-BINARY-34". 2168 05 FILLER PIC X(33) VALUE " FLOAT-BINARY-7". 2169 05 FILLER PIC X(33) VALUE " FLOAT-DECIMAL-16". 2170 05 FILLER PIC X(33) VALUE " FLOAT-DECIMAL-34". 2171 05 FILLER PIC X(33) VALUE " FLOAT-EXTENDED". 2172 05 FILLER PIC X(33) VALUE " FLOAT-LONG". 2173 05 FILLER PIC X(33) VALUE " FLOAT-SHORT". 2174 05 FILLER PIC X(33) VALUE " FOOTING". 2175 05 FILLER PIC X(33) VALUE " FOR". 2176 05 FILLER PIC X(33) VALUE " FOREGROUND-COLOR". 2177 05 FILLER PIC X(33) VALUE " FOREVER". 2178 05 FILLER PIC X(33) VALUE " FORMAT". 2179 05 FILLER PIC X(33) VALUE "MFORMFEED". 2180 05 FILLER PIC X(33) VALUE "IFRACTION-PART". 2181 05 FILLER PIC X(33) VALUE "VFREE". 2182 05 FILLER PIC X(33) VALUE " FROM". 2183 05 FILLER PIC X(33) VALUE " FULL". 2184 05 FILLER PIC X(33) VALUE " FUNCTION". 2185 05 FILLER PIC X(33) VALUE " FUNCTION-ID". 2186 05 FILLER PIC X(33) VALUE " FUNCTION-POINTER". 2187 05 FILLER PIC X(33) VALUE "VGENERATE". 2188 05 FILLER PIC X(33) VALUE " GET". 2189 05 FILLER PIC X(33) VALUE "KGIVING". 2190 05 FILLER PIC X(33) VALUE " GLOBAL". 2191 05 FILLER PIC X(33) VALUE "VGO". 2192 05 FILLER PIC X(33) VALUE "VGOBACK". 2193 05 FILLER PIC X(33) VALUE " GREATER". 2194 05 FILLER PIC X(33) VALUE " GROUP". 2195 05 FILLER PIC X(33) VALUE " GROUP-USAGE". 2196 05 FILLER PIC X(33) VALUE " HEADING". 2197 05 FILLER PIC X(33) VALUE " HIGH-VALUE". 2198 05 FILLER PIC X(33) VALUE " HIGH-VALUES". 2199 05 FILLER PIC X(33) VALUE " HIGHLIGHT". 2200 05 FILLER PIC X(33) VALUE " I-O". 2201 05 FILLER PIC X(33) VALUE " I-O-CONTROL". 2202 05 FILLER PIC X(33) VALUE "KID". 2203 05 FILLER PIC X(33) VALUE "KIDENTIFICATION". 2204 05 FILLER PIC X(33) VALUE "VIF". 2205 05 FILLER PIC X(33) VALUE " IGNORE". 2206 05 FILLER PIC X(33) VALUE " IGNORING". 2207 05 FILLER PIC X(33) VALUE " IN". 2208 05 FILLER PIC X(33) VALUE " INDEX". 2209 05 FILLER PIC X(33) VALUE "KINDEXED". 2210 05 FILLER PIC X(33) VALUE " INDICATE". 2211 05 FILLER PIC X(33) VALUE " INFINITY". 2212 05 FILLER PIC X(33) VALUE " INHERITS". 2213 05 FILLER PIC X(33) VALUE " INITIAL". 2214 05 FILLER PIC X(33) VALUE " INITIALISED". 2215 05 FILLER PIC X(33) VALUE "VINITIALIZE". 2216 05 FILLER PIC X(33) VALUE " INITIALIZED". 2217 05 FILLER PIC X(33) VALUE "VINITIATE". 2218 05 FILLER PIC X(33) VALUE " INPUT". 2219 05 FILLER PIC X(33) VALUE "KINPUT-OUTPUT". 2220 05 FILLER PIC X(33) VALUE "VINSPECT". 2221 05 FILLER PIC X(33) VALUE " INSTALLATION". 2222 05 FILLER PIC X(33) VALUE "IINTEGER". 2223 05 FILLER PIC X(33) VALUE "IINTEGER-OF-DATE". 2224 05 FILLER PIC X(33) VALUE "IINTEGER-OF-DAY". 2225 05 FILLER PIC X(33) VALUE "IINTEGER-PART". 2226 05 FILLER PIC X(33) VALUE " INTERFACE". 2227 05 FILLER PIC X(33) VALUE " INTERFACE-ID". 2228 05 FILLER PIC X(33) VALUE "KINTO". 2229 05 FILLER PIC X(33) VALUE " INTRINSIC". 2230 05 FILLER PIC X(33) VALUE " INVALID". 2231 05 FILLER PIC X(33) VALUE " INVOKE". 2232 05 FILLER PIC X(33) VALUE " IS". 2233 05 FILLER PIC X(33) VALUE " JUST". 2234 05 FILLER PIC X(33) VALUE " JUSTIFIED". 2235 05 FILLER PIC X(33) VALUE " KEY". 2236 05 FILLER PIC X(33) VALUE " LABEL". 2237 05 FILLER PIC X(33) VALUE " LAST". 2238 05 FILLER PIC X(33) VALUE " LEADING". 2239 05 FILLER PIC X(33) VALUE " LEFT". 2240 05 FILLER PIC X(33) VALUE " LEFT-JUSTIFY". 2241 05 FILLER PIC X(33) VALUE "ILENGTH". 2242 05 FILLER PIC X(33) VALUE " LESS". 2243 05 FILLER PIC X(33) VALUE " LIMIT". 2244 05 FILLER PIC X(33) VALUE " LIMITS". 2245 05 FILLER PIC X(33) VALUE " LINAGE". 2246 05 FILLER PIC X(33) VALUE "ILINAGE-COUNTER". 2247 05 FILLER PIC X(33) VALUE " LINE". 2248 05 FILLER PIC X(33) VALUE " LINE-COUNTER". 2249 05 FILLER PIC X(33) VALUE " LINES". 2250 05 FILLER PIC X(33) VALUE "KLINKAGE". 2251 05 FILLER PIC X(33) VALUE "KLOCAL-STORAGE". 2252 05 FILLER PIC X(33) VALUE " LOCALE". 2253 05 FILLER PIC X(33) VALUE "ILOCALE-DATE". 2254 05 FILLER PIC X(33) VALUE "ILOCALE-TIME". 2255 05 FILLER PIC X(33) VALUE "ILOCALE-TIME-FROM-SECONDS". 2256 05 FILLER PIC X(33) VALUE " LOCK". 2257 05 FILLER PIC X(33) VALUE "ILOG". 2258 05 FILLER PIC X(33) VALUE "ILOG10". 2259 05 FILLER PIC X(33) VALUE " LOW-VALUE". 2260 05 FILLER PIC X(33) VALUE " LOW-VALUES". 2261 05 FILLER PIC X(33) VALUE " LOWER". 2262 05 FILLER PIC X(33) VALUE "ILOWER-CASE". 2263 05 FILLER PIC X(33) VALUE " LOWLIGHT". 2264 05 FILLER PIC X(33) VALUE " MANUAL". 2265 05 FILLER PIC X(33) VALUE "IMAX". 2266 05 FILLER PIC X(33) VALUE "IMEAN". 2267 05 FILLER PIC X(33) VALUE "IMEDIAN". 2268 05 FILLER PIC X(33) VALUE " MEMORY". 2269 05 FILLER PIC X(33) VALUE "VMERGE". 2270 05 FILLER PIC X(33) VALUE " METHOD". 2271 05 FILLER PIC X(33) VALUE " METHOD-ID". 2272 05 FILLER PIC X(33) VALUE "IMIDRANGE". 2273 05 FILLER PIC X(33) VALUE "IMIN". 2274 05 FILLER PIC X(33) VALUE " MINUS". 2275 05 FILLER PIC X(33) VALUE "IMOD". 2276 05 FILLER PIC X(33) VALUE " MODE". 2277 05 FILLER PIC X(33) VALUE "VMOVE". 2278 05 FILLER PIC X(33) VALUE " MULTIPLE". 2279 05 FILLER PIC X(33) VALUE "VMULTIPLY". 2280 05 FILLER PIC X(33) VALUE " NATIONAL". 2281 05 FILLER PIC X(33) VALUE " NATIONAL-EDITED". 2282 05 FILLER PIC X(33) VALUE " NATIVE". 2283 05 FILLER PIC X(33) VALUE " NEGATIVE". 2284 05 FILLER PIC X(33) VALUE " NESTED". 2285 05 FILLER PIC X(33) VALUE "VNEXT". 2286 05 FILLER PIC X(33) VALUE " NO". 2287 05 FILLER PIC X(33) VALUE " NOT". 2288 05 FILLER PIC X(33) VALUE " NULL". 2289 05 FILLER PIC X(33) VALUE " NULLS". 2290 05 FILLER PIC X(33) VALUE " NUMBER". 2291 05 FILLER PIC X(33) VALUE "INUMBER-OF-CALL-PARAMETERS". 2292 05 FILLER PIC X(33) VALUE " NUMBERS". 2293 05 FILLER PIC X(33) VALUE " NUMERIC". 2294 05 FILLER PIC X(33) VALUE " NUMERIC-EDITED". 2295 05 FILLER PIC X(33) VALUE "INUMVAL". 2296 05 FILLER PIC X(33) VALUE "INUMVAL-C". 2297 05 FILLER PIC X(33) VALUE " OBJECT". 2298 05 FILLER PIC X(33) VALUE " OBJECT-COMPUTER". 2299 05 FILLER PIC X(33) VALUE " OBJECT-REFERENCE". 2300 05 FILLER PIC X(33) VALUE " OCCURS". 2301 05 FILLER PIC X(33) VALUE " OF". 2302 05 FILLER PIC X(33) VALUE " OFF". 2303 05 FILLER PIC X(33) VALUE " OMITTED". 2304 05 FILLER PIC X(33) VALUE " ON". 2305 05 FILLER PIC X(33) VALUE " ONLY". 2306 05 FILLER PIC X(33) VALUE "VOPEN". 2307 05 FILLER PIC X(33) VALUE " OPTIONAL". 2308 05 FILLER PIC X(33) VALUE " OPTIONS". 2309 05 FILLER PIC X(33) VALUE " OR". 2310 05 FILLER PIC X(33) VALUE "IORD". 2311 05 FILLER PIC X(33) VALUE "IORD-MAX". 2312 05 FILLER PIC X(33) VALUE "IORD-MIN". 2313 05 FILLER PIC X(33) VALUE " ORDER". 2314 05 FILLER PIC X(33) VALUE " ORGANIZATION". 2315 05 FILLER PIC X(33) VALUE " OTHER". 2316 05 FILLER PIC X(33) VALUE " OUTPUT". 2317 05 FILLER PIC X(33) VALUE " OVERFLOW". 2318 05 FILLER PIC X(33) VALUE " OVERLINE". 2319 05 FILLER PIC X(33) VALUE " OVERRIDE". 2320 05 FILLER PIC X(33) VALUE " PACKED-DECIMAL". 2321 05 FILLER PIC X(33) VALUE " PADDING". 2322 05 FILLER PIC X(33) VALUE " PAGE". 2323 05 FILLER PIC X(33) VALUE " PAGE-COUNTER". 2324 05 FILLER PIC X(33) VALUE " PARAGRAPH". 2325 05 FILLER PIC X(33) VALUE "VPERFORM". 2326 05 FILLER PIC X(33) VALUE " PF". 2327 05 FILLER PIC X(33) VALUE " PH". 2328 05 FILLER PIC X(33) VALUE "IPI". 2329 05 FILLER PIC X(33) VALUE "KPIC". 2330 05 FILLER PIC X(33) VALUE "KPICTURE". 2331 05 FILLER PIC X(33) VALUE " PLUS". 2332 05 FILLER PIC X(33) VALUE "KPOINTER". 2333 05 FILLER PIC X(33) VALUE " POSITION". 2334 05 FILLER PIC X(33) VALUE " POSITIVE". 2335 05 FILLER PIC X(33) VALUE " PRESENT". 2336 05 FILLER PIC X(33) VALUE "IPRESENT-VALUE". 2337 05 FILLER PIC X(33) VALUE " PREVIOUS". 2338 05 FILLER PIC X(33) VALUE "MPRINTER". 2339 05 FILLER PIC X(33) VALUE " PRINTING". 2340 05 FILLER PIC X(33) VALUE "KPROCEDURE". 2341 05 FILLER PIC X(33) VALUE " PROCEDURE-POINTER". 2342 05 FILLER PIC X(33) VALUE " PROCEDURES". 2343 05 FILLER PIC X(33) VALUE " PROCEED". 2344 05 FILLER PIC X(33) VALUE " PROGRAM". 2345 05 FILLER PIC X(33) VALUE "KPROGRAM-ID". 2346 05 FILLER PIC X(33) VALUE " PROGRAM-POINTER". 2347 05 FILLER PIC X(33) VALUE " PROMPT". 2348 05 FILLER PIC X(33) VALUE " PROPERTY". 2349 05 FILLER PIC X(33) VALUE " PROTOTYPE". 2350 05 FILLER PIC X(33) VALUE " QUOTE". 2351 05 FILLER PIC X(33) VALUE " QUOTES". 2352 05 FILLER PIC X(33) VALUE " RAISE". 2353 05 FILLER PIC X(33) VALUE " RAISING". 2354 05 FILLER PIC X(33) VALUE "IRANDOM". 2355 05 FILLER PIC X(33) VALUE "IRANGE". 2356 05 FILLER PIC X(33) VALUE " RD". 2357 05 FILLER PIC X(33) VALUE "VREAD". 2358 05 FILLER PIC X(33) VALUE "VREADY". 2359 05 FILLER PIC X(33) VALUE " RECORD". 2360 05 FILLER PIC X(33) VALUE " RECORDING". 2361 05 FILLER PIC X(33) VALUE " RECORDS". 2362 05 FILLER PIC X(33) VALUE " RECURSIVE". 2363 05 FILLER PIC X(33) VALUE "KREDEFINES". 2364 05 FILLER PIC X(33) VALUE " REEL". 2365 05 FILLER PIC X(33) VALUE " REFERENCE". 2366 05 FILLER PIC X(33) VALUE " RELATIVE". 2367 05 FILLER PIC X(33) VALUE "VRELEASE". 2368 05 FILLER PIC X(33) VALUE "IREM". 2369 05 FILLER PIC X(33) VALUE " REMAINDER". 2370 05 FILLER PIC X(33) VALUE " REMARKS". 2371 05 FILLER PIC X(33) VALUE " REMOVAL". 2372 05 FILLER PIC X(33) VALUE "KRENAMES". 2373 05 FILLER PIC X(33) VALUE "KREPLACING". 2374 05 FILLER PIC X(33) VALUE "KREPORT". 2375 05 FILLER PIC X(33) VALUE " REPORTING". 2376 05 FILLER PIC X(33) VALUE " REPORTS". 2377 05 FILLER PIC X(33) VALUE " REPOSITORY". 2378 05 FILLER PIC X(33) VALUE " REPRESENTS-NOT-A-NUMBER". 2379 05 FILLER PIC X(33) VALUE " REQUIRED". 2380 05 FILLER PIC X(33) VALUE " RESERVE". 2381 05 FILLER PIC X(33) VALUE " RESUME". 2382 05 FILLER PIC X(33) VALUE " RETRY". 2383 05 FILLER PIC X(33) VALUE "VRETURN". 2384 05 FILLER PIC X(33) VALUE "IRETURN-CODE". 2385 05 FILLER PIC X(33) VALUE "KRETURNING". 2386 05 FILLER PIC X(33) VALUE "IREVERSE". 2387 05 FILLER PIC X(33) VALUE " REVERSE-VIDEO". 2388 05 FILLER PIC X(33) VALUE " REWIND". 2389 05 FILLER PIC X(33) VALUE "VREWRITE". 2390 05 FILLER PIC X(33) VALUE " RF". 2391 05 FILLER PIC X(33) VALUE " RH". 2392 05 FILLER PIC X(33) VALUE " RIGHT". 2393 05 FILLER PIC X(33) VALUE " RIGHT-JUSTIFY". 2394 05 FILLER PIC X(33) VALUE "VROLLBACK". 2395 05 FILLER PIC X(33) VALUE " ROUNDED". 2396 05 FILLER PIC X(33) VALUE " RUN". 2397 05 FILLER PIC X(33) VALUE " SAME". 2398 05 FILLER PIC X(33) VALUE "KSCREEN". 2399 05 FILLER PIC X(33) VALUE " SCROLL". 2400 05 FILLER PIC X(33) VALUE "KSD". 2401 05 FILLER PIC X(33) VALUE "VSEARCH". 2402 05 FILLER PIC X(33) VALUE "ISECONDS-FROM-FORMATTED-TIME". 2403 05 FILLER PIC X(33) VALUE "ISECONDS-PAST-MIDNIGHT". 2404 05 FILLER PIC X(33) VALUE "KSECTION". 2405 05 FILLER PIC X(33) VALUE " SECURE". 2406 05 FILLER PIC X(33) VALUE " SECURITY". 2407 05 FILLER PIC X(33) VALUE " SEGMENT-LIMIT". 2408 05 FILLER PIC X(33) VALUE " SELECT". 2409 05 FILLER PIC X(33) VALUE " SELF". 2410 05 FILLER PIC X(33) VALUE " SENTENCE". 2411 05 FILLER PIC X(33) VALUE " SEPARATE". 2412 05 FILLER PIC X(33) VALUE " SEQUENCE". 2413 05 FILLER PIC X(33) VALUE " SEQUENTIAL". 2414 05 FILLER PIC X(33) VALUE "VSET". 2415 05 FILLER PIC X(33) VALUE " SHARING". 2416 05 FILLER PIC X(33) VALUE "ISIGN". 2417 05 FILLER PIC X(33) VALUE " SIGNED". 2418 05 FILLER PIC X(33) VALUE " SIGNED-INT". 2419 05 FILLER PIC X(33) VALUE " SIGNED-LONG". 2420 05 FILLER PIC X(33) VALUE " SIGNED-SHORT". 2421 05 FILLER PIC X(33) VALUE "ISIN". 2422 05 FILLER PIC X(33) VALUE " SIZE". 2423 05 FILLER PIC X(33) VALUE "VSORT". 2424 05 FILLER PIC X(33) VALUE " SORT-MERGE". 2425 05 FILLER PIC X(33) VALUE "ISORT-RETURN". 2426 05 FILLER PIC X(33) VALUE " SOURCE". 2427 05 FILLER PIC X(33) VALUE " SOURCE-COMPUTER". 2428 05 FILLER PIC X(33) VALUE " SOURCES". 2429 05 FILLER PIC X(33) VALUE " SPACE". 2430 05 FILLER PIC X(33) VALUE " SPACE-FILL". 2431 05 FILLER PIC X(33) VALUE " SPACES". 2432 05 FILLER PIC X(33) VALUE " SPECIAL-NAMES". 2433 05 FILLER PIC X(33) VALUE "ISQRT". 2434 05 FILLER PIC X(33) VALUE " STANDARD". 2435 05 FILLER PIC X(33) VALUE " STANDARD-1". 2436 05 FILLER PIC X(33) VALUE " STANDARD-2". 2437 05 FILLER PIC X(33) VALUE "ISTANDARD-DEVIATION". 2438 05 FILLER PIC X(33) VALUE "VSTART". 2439 05 FILLER PIC X(33) VALUE " STATUS". 2440 05 FILLER PIC X(33) VALUE "VSTOP". 2441 05 FILLER PIC X(33) VALUE "ISTORED-CHAR-LENGTH". 2442 05 FILLER PIC X(33) VALUE "VSTRING". 2443 05 FILLER PIC X(33) VALUE "ISUBSTITUTE". 2444 05 FILLER PIC X(33) VALUE "ISUBSTITUTE-CASE". 2445 05 FILLER PIC X(33) VALUE "VSUBTRACT". 2446 05 FILLER PIC X(33) VALUE "ISUM". 2447 05 FILLER PIC X(33) VALUE " SUPER". 2448 05 FILLER PIC X(33) VALUE "VSUPPRESS". 2449 05 FILLER PIC X(33) VALUE "MSWITCH-1". 2450 05 FILLER PIC X(33) VALUE "MSWITCH-2". 2451 05 FILLER PIC X(33) VALUE "MSWITCH-3". 2452 05 FILLER PIC X(33) VALUE "MSWITCH-4". 2453 05 FILLER PIC X(33) VALUE "MSWITCH-5". 2454 05 FILLER PIC X(33) VALUE "MSWITCH-6". 2455 05 FILLER PIC X(33) VALUE "MSWITCH-7". 2456 05 FILLER PIC X(33) VALUE "MSWITCH-8". 2457 05 FILLER PIC X(33) VALUE " SYMBOLIC". 2458 05 FILLER PIC X(33) VALUE " SYNC". 2459 05 FILLER PIC X(33) VALUE " SYNCHRONIZED". 2460 05 FILLER PIC X(33) VALUE "MSYSERR". 2461 05 FILLER PIC X(33) VALUE "MSYSIN". 2462 05 FILLER PIC X(33) VALUE "MSYSIPT". 2463 05 FILLER PIC X(33) VALUE "MSYSLIST". 2464 05 FILLER PIC X(33) VALUE "MSYSLST". 2465 05 FILLER PIC X(33) VALUE "MSYSOUT". 2466 05 FILLER PIC X(33) VALUE " SYSTEM-DEFAULT". 2467 05 FILLER PIC X(33) VALUE " TABLE". 2468 05 FILLER PIC X(33) VALUE "KTALLYING". 2469 05 FILLER PIC X(33) VALUE "ITAN". 2470 05 FILLER PIC X(33) VALUE " TAPE". 2471 05 FILLER PIC X(33) VALUE "VTERMINATE". 2472 05 FILLER PIC X(33) VALUE " TEST". 2473 05 FILLER PIC X(33) VALUE "ITEST-DATE-YYYYMMDD". 2474 05 FILLER PIC X(33) VALUE "ITEST-DAY-YYYYDDD". 2475 05 FILLER PIC X(33) VALUE " THAN". 2476 05 FILLER PIC X(33) VALUE " THEN". 2477 05 FILLER PIC X(33) VALUE " THROUGH". 2478 05 FILLER PIC X(33) VALUE " THRU". 2479 05 FILLER PIC X(33) VALUE " TIME". 2480 05 FILLER PIC X(33) VALUE " TIMES". 2481 05 FILLER PIC X(33) VALUE "KTO". 2482 05 FILLER PIC X(33) VALUE " TOP". 2483 05 FILLER PIC X(33) VALUE " TRAILING". 2484 05 FILLER PIC X(33) VALUE " TRAILING-SIGN". 2485 05 FILLER PIC X(33) VALUE "VTRANSFORM". 2486 05 FILLER PIC X(33) VALUE "ITRIM". 2487 05 FILLER PIC X(33) VALUE " TRUE". 2488 05 FILLER PIC X(33) VALUE " TYPE". 2489 05 FILLER PIC X(33) VALUE " TYPEDEF". 2490 05 FILLER PIC X(33) VALUE " UNDERLINE". 2491 05 FILLER PIC X(33) VALUE " UNIT". 2492 05 FILLER PIC X(33) VALUE " UNIVERSAL". 2493 05 FILLER PIC X(33) VALUE "VUNLOCK". 2494 05 FILLER PIC X(33) VALUE " UNSIGNED". 2495 05 FILLER PIC X(33) VALUE " UNSIGNED-INT". 2496 05 FILLER PIC X(33) VALUE " UNSIGNED-LONG". 2497 05 FILLER PIC X(33) VALUE " UNSIGNED-SHORT". 2498 05 FILLER PIC X(33) VALUE "VUNSTRING". 2499 05 FILLER PIC X(33) VALUE " UNTIL". 2500 05 FILLER PIC X(33) VALUE "KUP". 2501 05 FILLER PIC X(33) VALUE " UPDATE". 2502 05 FILLER PIC X(33) VALUE " UPON". 2503 05 FILLER PIC X(33) VALUE " UPPER". 2504 05 FILLER PIC X(33) VALUE "IUPPER-CASE". 2505 05 FILLER PIC X(33) VALUE " USAGE". 2506 05 FILLER PIC X(33) VALUE "VUSE". 2507 05 FILLER PIC X(33) VALUE " USER-DEFAULT". 2508 05 FILLER PIC X(33) VALUE "KUSING". 2509 05 FILLER PIC X(33) VALUE " VAL-STATUS". 2510 05 FILLER PIC X(33) VALUE " VALID". 2511 05 FILLER PIC X(33) VALUE " VALIDATE". 2512 05 FILLER PIC X(33) VALUE " VALIDATE-STATUS". 2513 05 FILLER PIC X(33) VALUE " VALUE". 2514 05 FILLER PIC X(33) VALUE " VALUES". 2515 05 FILLER PIC X(33) VALUE "IVARIANCE". 2516 05 FILLER PIC X(33) VALUE "KVARYING". 2517 05 FILLER PIC X(33) VALUE " WAIT". 2518 05 FILLER PIC X(33) VALUE "VWHEN". 2519 05 FILLER PIC X(33) VALUE "IWHEN-COMPILED". 2520 05 FILLER PIC X(33) VALUE " WITH". 2521 05 FILLER PIC X(33) VALUE " WORDS". 2522 05 FILLER PIC X(33) VALUE "KWORKING-STORAGE". 2523 05 FILLER PIC X(33) VALUE "VWRITE". 2524 05 FILLER PIC X(33) VALUE "IYEAR-TO-YYYY". 2525 05 FILLER PIC X(33) VALUE " YYYYDDD". 2526 05 FILLER PIC X(33) VALUE " YYYYMMDD". 2527 05 FILLER PIC X(33) VALUE " ZERO". 2528 05 FILLER PIC X(33) VALUE " ZERO-FILL". 2529 05 FILLER PIC X(33) VALUE " ZEROES". 2530 05 FILLER PIC X(33) VALUE " ZEROS". 2531 01 Reserved-Word-Table REDEFINES Reserved-Words. 2532 05 Reserved-Word OCCURS 591 TIMES 2533 ASCENDING KEY RW-Word 2534 INDEXED RW-Idx. 2535 10 RW-Type PIC X(1). 2536 10 RW-Word PIC X(32). 2537 2538 01 Saved-Section PIC X(15). 2539 2540 01 Search-Token PIC X(32). 2541 2542 01 Source-Line-No PIC 9(6). 2543 2544 01 Src-Ptr USAGE BINARY-LONG. 2545 2546 01 Syntax-Parsing-Items. 2547 05 SPI-Current-Char PIC X(1). 2548 88 Current-Char-Is-Punct VALUE "=", "(", ")", "*", "/", 2549 "&", ";", ",", "<", ">", 2550 ":". 2551 88 Current-Char-Is-Quote VALUE '"', "'". 2552 88 Current-Char-Is-X VALUE "x", "X". 2553 88 Current-Char-Is-Z VALUE "z", "Z". 2554 05 SPI-Current-Division PIC X(1). 2555 88 In-IDENTIFICATION-DIVISION VALUE "I", "?". 2556 88 In-ENVIRONMENT-DIVISION VALUE "E". 2557 88 In-DATA-DIVISION VALUE "D". 2558 88 In-PROCEDURE-DIVISION VALUE "P". 2559 05 SPI-Current-Line-No PIC 9(6). 2560 05 SPI-Current-Program-ID. 2561 10 FILLER PIC X(12). 2562 10 SPI-CP-13-15 PIC X(3). 2563 05 SPI-Current-Section. 2564 10 SPI-CS-1 PIC X(1). 2565 10 SPI-CS-2-14. 2566 15 FILLER PIC X(10). 2567 15 SPI-CS-11-14 PIC X(3). 2568 10 SPI-CS-15 PIC X(1). 2569 05 SPI-Current-Token PIC X(32). 2570 05 SPI-Current-Token-UC PIC X(32). 2571 05 SPI-Current-Verb PIC X(12). 2572 05 SPI-Next-Char PIC X(1). 2573 88 Next-Char-Is-Quote VALUE '"', "'". 2574 05 SPI-Prior-Token PIC X(32). 2575 05 SPI-Token-Type PIC X(1). 2576 88 Token-Is-EOF VALUE HIGH-VALUES. 2577 88 Token-Is-Identifier VALUE "I". 2578 88 Token-Is-Key-Word VALUE "K", "V". 2579 88 Token-Is-Literal-Alpha VALUE "L". 2580 88 Token-Is-Literal-Number VALUE "N". 2581 88 Token-Is-Verb VALUE "V". 2582GC0710 88 Token-Is-Reserved-Word VALUE " ". 2583 2584 01 Tally USAGE BINARY-LONG. 2585 2586 01 Todays-Date PIC 9(8). 2587 2588 LINKAGE SECTION. 2589 01 Produce-Source-Listing PIC X(1). 2590 01 Produce-Xref-Listing PIC X(1). 2591 01 Src-Filename PIC X(256). 2592 / 2593 PROCEDURE DIVISION USING Produce-Source-Listing 2594 Produce-Xref-Listing 2595 Src-Filename. 2596 000-Main SECTION. 2597 001-Init. 2598 PERFORM 100-Initialization 2599 PERFORM 200-Execute-cobc 2600 OPEN OUTPUT Report-File 2601 IF Produce-Source-Listing NOT = SPACE 2602 PERFORM 500-Produce-Source-Listing 2603 END-IF 2604 IF Produce-Xref-Listing NOT = SPACE 2605 SORT Sort-File 2606 ASCENDING KEY SR-Prog-ID 2607 SR-Token-UC 2608 SR-Line-No-Ref 2609 INPUT PROCEDURE 300-Tokenize-Source 2610 OUTPUT PROCEDURE 400-Produce-Xref-Listing 2611 END-IF 2612 CLOSE Report-File 2613 GOBACK 2614 . 2615 / 2616 100-Initialization SECTION. 2617 ***************************************************************** 2618 ** Perform all program-wide initialization operations ** 2619 ***************************************************************** 2620 END PROGRAM LISTING. 2621